1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2018 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 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
605 type, lists the only ways a character length value of * can be used:
606 dummy arguments of procedures, named constants, and function results
607 in external functions. Internal function results and results of module
608 procedures are not on this list, ergo, not permitted. */
610 if (sym
->result
->ts
.type
== BT_CHARACTER
)
612 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
613 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
615 /* See if this is a module-procedure and adapt error message
618 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
619 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
621 gfc_error (module_proc
622 ? G_("Character-valued module procedure %qs at %L"
623 " must not be assumed length")
624 : G_("Character-valued internal function %qs at %L"
625 " must not be assumed length"),
626 sym
->name
, &sym
->declared_at
);
632 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
633 introduce duplicates. */
636 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
638 gfc_formal_arglist
*f
, *new_arglist
;
641 for (; new_args
!= NULL
; new_args
= new_args
->next
)
643 new_sym
= new_args
->sym
;
644 /* See if this arg is already in the formal argument list. */
645 for (f
= proc
->formal
; f
; f
= f
->next
)
647 if (new_sym
== f
->sym
)
654 /* Add a new argument. Argument order is not important. */
655 new_arglist
= gfc_get_formal_arglist ();
656 new_arglist
->sym
= new_sym
;
657 new_arglist
->next
= proc
->formal
;
658 proc
->formal
= new_arglist
;
663 /* Flag the arguments that are not present in all entries. */
666 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
668 gfc_formal_arglist
*f
, *head
;
671 for (f
= proc
->formal
; f
; f
= f
->next
)
676 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
678 if (new_args
->sym
== f
->sym
)
685 f
->sym
->attr
.not_always_present
= 1;
690 /* Resolve alternate entry points. If a symbol has multiple entry points we
691 create a new master symbol for the main routine, and turn the existing
692 symbol into an entry point. */
695 resolve_entries (gfc_namespace
*ns
)
697 gfc_namespace
*old_ns
;
701 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
702 static int master_count
= 0;
704 if (ns
->proc_name
== NULL
)
707 /* No need to do anything if this procedure doesn't have alternate entry
712 /* We may already have resolved alternate entry points. */
713 if (ns
->proc_name
->attr
.entry_master
)
716 /* If this isn't a procedure something has gone horribly wrong. */
717 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
719 /* Remember the current namespace. */
720 old_ns
= gfc_current_ns
;
724 /* Add the main entry point to the list of entry points. */
725 el
= gfc_get_entry_list ();
726 el
->sym
= ns
->proc_name
;
728 el
->next
= ns
->entries
;
730 ns
->proc_name
->attr
.entry
= 1;
732 /* If it is a module function, it needs to be in the right namespace
733 so that gfc_get_fake_result_decl can gather up the results. The
734 need for this arose in get_proc_name, where these beasts were
735 left in their own namespace, to keep prior references linked to
736 the entry declaration.*/
737 if (ns
->proc_name
->attr
.function
738 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
741 /* Do the same for entries where the master is not a module
742 procedure. These are retained in the module namespace because
743 of the module procedure declaration. */
744 for (el
= el
->next
; el
; el
= el
->next
)
745 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
746 && el
->sym
->attr
.mod_proc
)
750 /* Add an entry statement for it. */
751 c
= gfc_get_code (EXEC_ENTRY
);
756 /* Create a new symbol for the master function. */
757 /* Give the internal function a unique name (within this file).
758 Also include the function name so the user has some hope of figuring
759 out what is going on. */
760 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
761 master_count
++, ns
->proc_name
->name
);
762 gfc_get_ha_symbol (name
, &proc
);
763 gcc_assert (proc
!= NULL
);
765 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
766 if (ns
->proc_name
->attr
.subroutine
)
767 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
771 gfc_typespec
*ts
, *fts
;
772 gfc_array_spec
*as
, *fas
;
773 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
775 fas
= ns
->entries
->sym
->as
;
776 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
777 fts
= &ns
->entries
->sym
->result
->ts
;
778 if (fts
->type
== BT_UNKNOWN
)
779 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
780 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
782 ts
= &el
->sym
->result
->ts
;
784 as
= as
? as
: el
->sym
->result
->as
;
785 if (ts
->type
== BT_UNKNOWN
)
786 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
788 if (! gfc_compare_types (ts
, fts
)
789 || (el
->sym
->result
->attr
.dimension
790 != ns
->entries
->sym
->result
->attr
.dimension
)
791 || (el
->sym
->result
->attr
.pointer
792 != ns
->entries
->sym
->result
->attr
.pointer
))
794 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
795 && gfc_compare_array_spec (as
, fas
) == 0)
796 gfc_error ("Function %s at %L has entries with mismatched "
797 "array specifications", ns
->entries
->sym
->name
,
798 &ns
->entries
->sym
->declared_at
);
799 /* The characteristics need to match and thus both need to have
800 the same string length, i.e. both len=*, or both len=4.
801 Having both len=<variable> is also possible, but difficult to
802 check at compile time. */
803 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
804 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
805 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
807 && ts
->u
.cl
->length
->expr_type
808 != fts
->u
.cl
->length
->expr_type
)
810 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
811 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
812 fts
->u
.cl
->length
->value
.integer
) != 0)))
813 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
814 "entries returning variables of different "
815 "string lengths", ns
->entries
->sym
->name
,
816 &ns
->entries
->sym
->declared_at
);
821 sym
= ns
->entries
->sym
->result
;
822 /* All result types the same. */
824 if (sym
->attr
.dimension
)
825 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
826 if (sym
->attr
.pointer
)
827 gfc_add_pointer (&proc
->attr
, NULL
);
831 /* Otherwise the result will be passed through a union by
833 proc
->attr
.mixed_entry_master
= 1;
834 for (el
= ns
->entries
; el
; el
= el
->next
)
836 sym
= el
->sym
->result
;
837 if (sym
->attr
.dimension
)
839 if (el
== ns
->entries
)
840 gfc_error ("FUNCTION result %s can't be an array in "
841 "FUNCTION %s at %L", sym
->name
,
842 ns
->entries
->sym
->name
, &sym
->declared_at
);
844 gfc_error ("ENTRY result %s can't be an array in "
845 "FUNCTION %s at %L", sym
->name
,
846 ns
->entries
->sym
->name
, &sym
->declared_at
);
848 else if (sym
->attr
.pointer
)
850 if (el
== ns
->entries
)
851 gfc_error ("FUNCTION result %s can't be a POINTER in "
852 "FUNCTION %s at %L", sym
->name
,
853 ns
->entries
->sym
->name
, &sym
->declared_at
);
855 gfc_error ("ENTRY result %s can't be a POINTER in "
856 "FUNCTION %s at %L", sym
->name
,
857 ns
->entries
->sym
->name
, &sym
->declared_at
);
862 if (ts
->type
== BT_UNKNOWN
)
863 ts
= gfc_get_default_type (sym
->name
, NULL
);
867 if (ts
->kind
== gfc_default_integer_kind
)
871 if (ts
->kind
== gfc_default_real_kind
872 || ts
->kind
== gfc_default_double_kind
)
876 if (ts
->kind
== gfc_default_complex_kind
)
880 if (ts
->kind
== gfc_default_logical_kind
)
884 /* We will issue error elsewhere. */
892 if (el
== ns
->entries
)
893 gfc_error ("FUNCTION result %s can't be of type %s "
894 "in FUNCTION %s at %L", sym
->name
,
895 gfc_typename (ts
), ns
->entries
->sym
->name
,
898 gfc_error ("ENTRY result %s can't be of type %s "
899 "in FUNCTION %s at %L", sym
->name
,
900 gfc_typename (ts
), ns
->entries
->sym
->name
,
907 proc
->attr
.access
= ACCESS_PRIVATE
;
908 proc
->attr
.entry_master
= 1;
910 /* Merge all the entry point arguments. */
911 for (el
= ns
->entries
; el
; el
= el
->next
)
912 merge_argument_lists (proc
, el
->sym
->formal
);
914 /* Check the master formal arguments for any that are not
915 present in all entry points. */
916 for (el
= ns
->entries
; el
; el
= el
->next
)
917 check_argument_lists (proc
, el
->sym
->formal
);
919 /* Use the master function for the function body. */
920 ns
->proc_name
= proc
;
922 /* Finalize the new symbols. */
923 gfc_commit_symbols ();
925 /* Restore the original namespace. */
926 gfc_current_ns
= old_ns
;
930 /* Resolve common variables. */
932 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
934 gfc_symbol
*csym
= common_block
->head
;
936 for (; csym
; csym
= csym
->common_next
)
938 /* gfc_add_in_common may have been called before, but the reported errors
939 have been ignored to continue parsing.
940 We do the checks again here. */
941 if (!csym
->attr
.use_assoc
)
942 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
944 if (csym
->value
|| csym
->attr
.data
)
946 if (!csym
->ns
->is_block_data
)
947 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
948 "but only in BLOCK DATA initialization is "
949 "allowed", csym
->name
, &csym
->declared_at
);
950 else if (!named_common
)
951 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
952 "in a blank COMMON but initialization is only "
953 "allowed in named common blocks", csym
->name
,
957 if (UNLIMITED_POLY (csym
))
958 gfc_error_now ("%qs in cannot appear in COMMON at %L "
959 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
961 if (csym
->ts
.type
!= BT_DERIVED
)
964 if (!(csym
->ts
.u
.derived
->attr
.sequence
965 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
966 gfc_error_now ("Derived type variable %qs in COMMON at %L "
967 "has neither the SEQUENCE nor the BIND(C) "
968 "attribute", csym
->name
, &csym
->declared_at
);
969 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
970 gfc_error_now ("Derived type variable %qs in COMMON at %L "
971 "has an ultimate component that is "
972 "allocatable", csym
->name
, &csym
->declared_at
);
973 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
974 gfc_error_now ("Derived type variable %qs in COMMON at %L "
975 "may not have default initializer", csym
->name
,
978 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
979 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
983 /* Resolve common blocks. */
985 resolve_common_blocks (gfc_symtree
*common_root
)
990 if (common_root
== NULL
)
993 if (common_root
->left
)
994 resolve_common_blocks (common_root
->left
);
995 if (common_root
->right
)
996 resolve_common_blocks (common_root
->right
);
998 resolve_common_vars (common_root
->n
.common
, true);
1000 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
1001 &common_root
->n
.common
->where
))
1004 /* The common name is a global name - in Fortran 2003 also if it has a
1005 C binding name, since Fortran 2008 only the C binding name is a global
1007 if (!common_root
->n
.common
->binding_label
1008 || gfc_notification_std (GFC_STD_F2008
))
1010 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1011 common_root
->n
.common
->name
);
1013 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1014 && gsym
->type
== GSYM_COMMON
1015 && ((common_root
->n
.common
->binding_label
1016 && (!gsym
->binding_label
1017 || strcmp (common_root
->n
.common
->binding_label
,
1018 gsym
->binding_label
) != 0))
1019 || (!common_root
->n
.common
->binding_label
1020 && gsym
->binding_label
)))
1022 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1023 "identifier and must thus have the same binding name "
1024 "as the same-named COMMON block at %L: %s vs %s",
1025 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1027 common_root
->n
.common
->binding_label
1028 ? common_root
->n
.common
->binding_label
: "(blank)",
1029 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1033 if (gsym
&& gsym
->type
!= GSYM_COMMON
1034 && !common_root
->n
.common
->binding_label
)
1036 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1038 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1042 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1044 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1045 "%L sharing the identifier with global non-COMMON-block "
1046 "entity at %L", common_root
->n
.common
->name
,
1047 &common_root
->n
.common
->where
, &gsym
->where
);
1052 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1053 gsym
->type
= GSYM_COMMON
;
1054 gsym
->where
= common_root
->n
.common
->where
;
1060 if (common_root
->n
.common
->binding_label
)
1062 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1063 common_root
->n
.common
->binding_label
);
1064 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1066 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1067 "global identifier as entity at %L",
1068 &common_root
->n
.common
->where
,
1069 common_root
->n
.common
->binding_label
, &gsym
->where
);
1074 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1075 gsym
->type
= GSYM_COMMON
;
1076 gsym
->where
= common_root
->n
.common
->where
;
1082 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1086 if (sym
->attr
.flavor
== FL_PARAMETER
)
1087 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1088 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1090 if (sym
->attr
.external
)
1091 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1092 sym
->name
, &common_root
->n
.common
->where
);
1094 if (sym
->attr
.intrinsic
)
1095 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1096 sym
->name
, &common_root
->n
.common
->where
);
1097 else if (sym
->attr
.result
1098 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1099 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1100 "that is also a function result", sym
->name
,
1101 &common_root
->n
.common
->where
);
1102 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1103 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1104 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1105 "that is also a global procedure", sym
->name
,
1106 &common_root
->n
.common
->where
);
1110 /* Resolve contained function types. Because contained functions can call one
1111 another, they have to be worked out before any of the contained procedures
1114 The good news is that if a function doesn't already have a type, the only
1115 way it can get one is through an IMPLICIT type or a RESULT variable, because
1116 by definition contained functions are contained namespace they're contained
1117 in, not in a sibling or parent namespace. */
1120 resolve_contained_functions (gfc_namespace
*ns
)
1122 gfc_namespace
*child
;
1125 resolve_formal_arglists (ns
);
1127 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1129 /* Resolve alternate entry points first. */
1130 resolve_entries (child
);
1132 /* Then check function return types. */
1133 resolve_contained_fntype (child
->proc_name
, child
);
1134 for (el
= child
->entries
; el
; el
= el
->next
)
1135 resolve_contained_fntype (el
->sym
, child
);
1141 /* A Parameterized Derived Type constructor must contain values for
1142 the PDT KIND parameters or they must have a default initializer.
1143 Go through the constructor picking out the KIND expressions,
1144 storing them in 'param_list' and then call gfc_get_pdt_instance
1145 to obtain the PDT instance. */
1147 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1150 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1152 param
= gfc_get_actual_arglist ();
1154 param_list
= param_tail
= param
;
1157 param_tail
->next
= param
;
1158 param_tail
= param_tail
->next
;
1161 param_tail
->name
= c
->name
;
1163 param_tail
->expr
= gfc_copy_expr (expr
);
1164 else if (c
->initializer
)
1165 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1168 param_tail
->spec_type
= SPEC_ASSUMED
;
1169 if (c
->attr
.pdt_kind
)
1171 gfc_error ("The KIND parameter %qs in the PDT constructor "
1172 "at %C has no value", param
->name
);
1181 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1182 gfc_symbol
*derived
)
1184 gfc_constructor
*cons
= NULL
;
1185 gfc_component
*comp
;
1188 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1189 cons
= gfc_constructor_first (expr
->value
.constructor
);
1194 comp
= derived
->components
;
1196 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1199 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1200 && comp
->ts
.type
== BT_DERIVED
)
1202 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1206 else if (comp
->ts
.type
== BT_DERIVED
)
1208 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1212 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1213 && derived
->attr
.pdt_template
)
1215 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1224 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1225 static bool resolve_fl_struct (gfc_symbol
*sym
);
1228 /* Resolve all of the elements of a structure constructor and make sure that
1229 the types are correct. The 'init' flag indicates that the given
1230 constructor is an initializer. */
1233 resolve_structure_cons (gfc_expr
*expr
, int init
)
1235 gfc_constructor
*cons
;
1236 gfc_component
*comp
;
1242 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1244 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1245 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1247 resolve_fl_struct (expr
->ts
.u
.derived
);
1249 /* If this is a Parameterized Derived Type template, find the
1250 instance corresponding to the PDT kind parameters. */
1251 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1254 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1257 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1259 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1262 gfc_free_actual_arglist (param_list
);
1264 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1269 cons
= gfc_constructor_first (expr
->value
.constructor
);
1271 /* A constructor may have references if it is the result of substituting a
1272 parameter variable. In this case we just pull out the component we
1275 comp
= expr
->ref
->u
.c
.sym
->components
;
1277 comp
= expr
->ts
.u
.derived
->components
;
1279 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1286 /* Unions use an EXPR_NULL contrived expression to tell the translation
1287 phase to generate an initializer of the appropriate length.
1289 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1292 if (!gfc_resolve_expr (cons
->expr
))
1298 rank
= comp
->as
? comp
->as
->rank
: 0;
1299 if (comp
->ts
.type
== BT_CLASS
1300 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1301 && CLASS_DATA (comp
)->as
)
1302 rank
= CLASS_DATA (comp
)->as
->rank
;
1304 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1305 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1307 gfc_error ("The rank of the element in the structure "
1308 "constructor at %L does not match that of the "
1309 "component (%d/%d)", &cons
->expr
->where
,
1310 cons
->expr
->rank
, rank
);
1314 /* If we don't have the right type, try to convert it. */
1316 if (!comp
->attr
.proc_pointer
&&
1317 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1319 if (strcmp (comp
->name
, "_extends") == 0)
1321 /* Can afford to be brutal with the _extends initializer.
1322 The derived type can get lost because it is PRIVATE
1323 but it is not usage constrained by the standard. */
1324 cons
->expr
->ts
= comp
->ts
;
1326 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1328 gfc_error ("The element in the structure constructor at %L, "
1329 "for pointer component %qs, is %s but should be %s",
1330 &cons
->expr
->where
, comp
->name
,
1331 gfc_basic_typename (cons
->expr
->ts
.type
),
1332 gfc_basic_typename (comp
->ts
.type
));
1337 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1343 /* For strings, the length of the constructor should be the same as
1344 the one of the structure, ensure this if the lengths are known at
1345 compile time and when we are dealing with PARAMETER or structure
1347 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1348 && comp
->ts
.u
.cl
->length
1349 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1350 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1351 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1352 && cons
->expr
->rank
!= 0
1353 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1354 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1356 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1357 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1359 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1360 to make use of the gfc_resolve_character_array_constructor
1361 machinery. The expression is later simplified away to
1362 an array of string literals. */
1363 gfc_expr
*para
= cons
->expr
;
1364 cons
->expr
= gfc_get_expr ();
1365 cons
->expr
->ts
= para
->ts
;
1366 cons
->expr
->where
= para
->where
;
1367 cons
->expr
->expr_type
= EXPR_ARRAY
;
1368 cons
->expr
->rank
= para
->rank
;
1369 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1370 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1371 para
, &cons
->expr
->where
);
1374 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1376 /* Rely on the cleanup of the namespace to deal correctly with
1377 the old charlen. (There was a block here that attempted to
1378 remove the charlen but broke the chain in so doing.) */
1379 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1380 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1381 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1382 gfc_resolve_character_array_constructor (cons
->expr
);
1386 if (cons
->expr
->expr_type
== EXPR_NULL
1387 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1388 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1389 || (comp
->ts
.type
== BT_CLASS
1390 && (CLASS_DATA (comp
)->attr
.class_pointer
1391 || CLASS_DATA (comp
)->attr
.allocatable
))))
1394 gfc_error ("The NULL in the structure constructor at %L is "
1395 "being applied to component %qs, which is neither "
1396 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1400 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1402 /* Check procedure pointer interface. */
1403 gfc_symbol
*s2
= NULL
;
1408 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1411 s2
= c2
->ts
.interface
;
1414 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1416 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1417 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1419 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1421 s2
= cons
->expr
->symtree
->n
.sym
;
1422 name
= cons
->expr
->symtree
->n
.sym
->name
;
1425 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1426 err
, sizeof (err
), NULL
, NULL
))
1428 gfc_error_opt (OPT_Wargument_mismatch
,
1429 "Interface mismatch for procedure-pointer "
1430 "component %qs in structure constructor at %L:"
1431 " %s", comp
->name
, &cons
->expr
->where
, err
);
1436 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1437 || cons
->expr
->expr_type
== EXPR_NULL
)
1440 a
= gfc_expr_attr (cons
->expr
);
1442 if (!a
.pointer
&& !a
.target
)
1445 gfc_error ("The element in the structure constructor at %L, "
1446 "for pointer component %qs should be a POINTER or "
1447 "a TARGET", &cons
->expr
->where
, comp
->name
);
1452 /* F08:C461. Additional checks for pointer initialization. */
1456 gfc_error ("Pointer initialization target at %L "
1457 "must not be ALLOCATABLE", &cons
->expr
->where
);
1462 gfc_error ("Pointer initialization target at %L "
1463 "must have the SAVE attribute", &cons
->expr
->where
);
1467 /* F2003, C1272 (3). */
1468 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1469 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1470 || gfc_is_coindexed (cons
->expr
));
1471 if (impure
&& gfc_pure (NULL
))
1474 gfc_error ("Invalid expression in the structure constructor for "
1475 "pointer component %qs at %L in PURE procedure",
1476 comp
->name
, &cons
->expr
->where
);
1480 gfc_unset_implicit_pure (NULL
);
1487 /****************** Expression name resolution ******************/
1489 /* Returns 0 if a symbol was not declared with a type or
1490 attribute declaration statement, nonzero otherwise. */
1493 was_declared (gfc_symbol
*sym
)
1499 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1502 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1503 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1504 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1505 || a
.asynchronous
|| a
.codimension
)
1512 /* Determine if a symbol is generic or not. */
1515 generic_sym (gfc_symbol
*sym
)
1519 if (sym
->attr
.generic
||
1520 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1523 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1526 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1533 return generic_sym (s
);
1540 /* Determine if a symbol is specific or not. */
1543 specific_sym (gfc_symbol
*sym
)
1547 if (sym
->attr
.if_source
== IFSRC_IFBODY
1548 || sym
->attr
.proc
== PROC_MODULE
1549 || sym
->attr
.proc
== PROC_INTERNAL
1550 || sym
->attr
.proc
== PROC_ST_FUNCTION
1551 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1552 || sym
->attr
.external
)
1555 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1558 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1560 return (s
== NULL
) ? 0 : specific_sym (s
);
1564 /* Figure out if the procedure is specific, generic or unknown. */
1567 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1570 procedure_kind (gfc_symbol
*sym
)
1572 if (generic_sym (sym
))
1573 return PTYPE_GENERIC
;
1575 if (specific_sym (sym
))
1576 return PTYPE_SPECIFIC
;
1578 return PTYPE_UNKNOWN
;
1581 /* Check references to assumed size arrays. The flag need_full_assumed_size
1582 is nonzero when matching actual arguments. */
1584 static int need_full_assumed_size
= 0;
1587 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1589 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1592 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1593 What should it be? */
1594 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1595 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1596 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1598 gfc_error ("The upper bound in the last dimension must "
1599 "appear in the reference to the assumed size "
1600 "array %qs at %L", sym
->name
, &e
->where
);
1607 /* Look for bad assumed size array references in argument expressions
1608 of elemental and array valued intrinsic procedures. Since this is
1609 called from procedure resolution functions, it only recurses at
1613 resolve_assumed_size_actual (gfc_expr
*e
)
1618 switch (e
->expr_type
)
1621 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1626 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1627 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1638 /* Check a generic procedure, passed as an actual argument, to see if
1639 there is a matching specific name. If none, it is an error, and if
1640 more than one, the reference is ambiguous. */
1642 count_specific_procs (gfc_expr
*e
)
1649 sym
= e
->symtree
->n
.sym
;
1651 for (p
= sym
->generic
; p
; p
= p
->next
)
1652 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1654 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1660 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1664 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1665 "argument at %L", sym
->name
, &e
->where
);
1671 /* See if a call to sym could possibly be a not allowed RECURSION because of
1672 a missing RECURSIVE declaration. This means that either sym is the current
1673 context itself, or sym is the parent of a contained procedure calling its
1674 non-RECURSIVE containing procedure.
1675 This also works if sym is an ENTRY. */
1678 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1680 gfc_symbol
* proc_sym
;
1681 gfc_symbol
* context_proc
;
1682 gfc_namespace
* real_context
;
1684 if (sym
->attr
.flavor
== FL_PROGRAM
1685 || gfc_fl_struct (sym
->attr
.flavor
))
1688 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1690 /* If we've got an ENTRY, find real procedure. */
1691 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1692 proc_sym
= sym
->ns
->entries
->sym
;
1696 /* If sym is RECURSIVE, all is well of course. */
1697 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1700 /* Find the context procedure's "real" symbol if it has entries.
1701 We look for a procedure symbol, so recurse on the parents if we don't
1702 find one (like in case of a BLOCK construct). */
1703 for (real_context
= context
; ; real_context
= real_context
->parent
)
1705 /* We should find something, eventually! */
1706 gcc_assert (real_context
);
1708 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1709 : real_context
->proc_name
);
1711 /* In some special cases, there may not be a proc_name, like for this
1713 real(bad_kind()) function foo () ...
1714 when checking the call to bad_kind ().
1715 In these cases, we simply return here and assume that the
1720 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1724 /* A call from sym's body to itself is recursion, of course. */
1725 if (context_proc
== proc_sym
)
1728 /* The same is true if context is a contained procedure and sym the
1730 if (context_proc
->attr
.contained
)
1732 gfc_symbol
* parent_proc
;
1734 gcc_assert (context
->parent
);
1735 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1736 : context
->parent
->proc_name
);
1738 if (parent_proc
== proc_sym
)
1746 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1747 its typespec and formal argument list. */
1750 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1752 gfc_intrinsic_sym
* isym
= NULL
;
1758 /* Already resolved. */
1759 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1762 /* We already know this one is an intrinsic, so we don't call
1763 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1764 gfc_find_subroutine directly to check whether it is a function or
1767 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1769 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1770 isym
= gfc_intrinsic_subroutine_by_id (id
);
1772 else if (sym
->intmod_sym_id
)
1774 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1775 isym
= gfc_intrinsic_function_by_id (id
);
1777 else if (!sym
->attr
.subroutine
)
1778 isym
= gfc_find_function (sym
->name
);
1780 if (isym
&& !sym
->attr
.subroutine
)
1782 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1783 && !sym
->attr
.implicit_type
)
1784 gfc_warning (OPT_Wsurprising
,
1785 "Type specified for intrinsic function %qs at %L is"
1786 " ignored", sym
->name
, &sym
->declared_at
);
1788 if (!sym
->attr
.function
&&
1789 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1794 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1796 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1798 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1799 " specifier", sym
->name
, &sym
->declared_at
);
1803 if (!sym
->attr
.subroutine
&&
1804 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1809 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1814 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1816 sym
->attr
.pure
= isym
->pure
;
1817 sym
->attr
.elemental
= isym
->elemental
;
1819 /* Check it is actually available in the standard settings. */
1820 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1822 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1823 "available in the current standard settings but %s. Use "
1824 "an appropriate %<-std=*%> option or enable "
1825 "%<-fall-intrinsics%> in order to use it.",
1826 sym
->name
, &sym
->declared_at
, symstd
);
1834 /* Resolve a procedure expression, like passing it to a called procedure or as
1835 RHS for a procedure pointer assignment. */
1838 resolve_procedure_expression (gfc_expr
* expr
)
1842 if (expr
->expr_type
!= EXPR_VARIABLE
)
1844 gcc_assert (expr
->symtree
);
1846 sym
= expr
->symtree
->n
.sym
;
1848 if (sym
->attr
.intrinsic
)
1849 gfc_resolve_intrinsic (sym
, &expr
->where
);
1851 if (sym
->attr
.flavor
!= FL_PROCEDURE
1852 || (sym
->attr
.function
&& sym
->result
== sym
))
1855 /* A non-RECURSIVE procedure that is used as procedure expression within its
1856 own body is in danger of being called recursively. */
1857 if (is_illegal_recursion (sym
, gfc_current_ns
))
1858 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1859 " itself recursively. Declare it RECURSIVE or use"
1860 " %<-frecursive%>", sym
->name
, &expr
->where
);
1866 /* Resolve an actual argument list. Most of the time, this is just
1867 resolving the expressions in the list.
1868 The exception is that we sometimes have to decide whether arguments
1869 that look like procedure arguments are really simple variable
1873 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1874 bool no_formal_args
)
1877 gfc_symtree
*parent_st
;
1879 gfc_component
*comp
;
1880 int save_need_full_assumed_size
;
1881 bool return_value
= false;
1882 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1885 first_actual_arg
= true;
1887 for (; arg
; arg
= arg
->next
)
1892 /* Check the label is a valid branching target. */
1895 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1897 gfc_error ("Label %d referenced at %L is never defined",
1898 arg
->label
->value
, &arg
->label
->where
);
1902 first_actual_arg
= false;
1906 if (e
->expr_type
== EXPR_VARIABLE
1907 && e
->symtree
->n
.sym
->attr
.generic
1909 && count_specific_procs (e
) != 1)
1912 if (e
->ts
.type
!= BT_PROCEDURE
)
1914 save_need_full_assumed_size
= need_full_assumed_size
;
1915 if (e
->expr_type
!= EXPR_VARIABLE
)
1916 need_full_assumed_size
= 0;
1917 if (!gfc_resolve_expr (e
))
1919 need_full_assumed_size
= save_need_full_assumed_size
;
1923 /* See if the expression node should really be a variable reference. */
1925 sym
= e
->symtree
->n
.sym
;
1927 if (sym
->attr
.flavor
== FL_PROCEDURE
1928 || sym
->attr
.intrinsic
1929 || sym
->attr
.external
)
1933 /* If a procedure is not already determined to be something else
1934 check if it is intrinsic. */
1935 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1936 sym
->attr
.intrinsic
= 1;
1938 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1940 gfc_error ("Statement function %qs at %L is not allowed as an "
1941 "actual argument", sym
->name
, &e
->where
);
1944 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1945 sym
->attr
.subroutine
);
1946 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1948 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1949 "actual argument", sym
->name
, &e
->where
);
1952 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1953 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1955 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1956 " used as actual argument at %L",
1957 sym
->name
, &e
->where
))
1961 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1963 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1964 "allowed as an actual argument at %L", sym
->name
,
1968 /* Check if a generic interface has a specific procedure
1969 with the same name before emitting an error. */
1970 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1973 /* Just in case a specific was found for the expression. */
1974 sym
= e
->symtree
->n
.sym
;
1976 /* If the symbol is the function that names the current (or
1977 parent) scope, then we really have a variable reference. */
1979 if (gfc_is_function_return_value (sym
, sym
->ns
))
1982 /* If all else fails, see if we have a specific intrinsic. */
1983 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1985 gfc_intrinsic_sym
*isym
;
1987 isym
= gfc_find_function (sym
->name
);
1988 if (isym
== NULL
|| !isym
->specific
)
1990 gfc_error ("Unable to find a specific INTRINSIC procedure "
1991 "for the reference %qs at %L", sym
->name
,
1996 sym
->attr
.intrinsic
= 1;
1997 sym
->attr
.function
= 1;
2000 if (!gfc_resolve_expr (e
))
2005 /* See if the name is a module procedure in a parent unit. */
2007 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2010 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2012 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2016 if (parent_st
== NULL
)
2019 sym
= parent_st
->n
.sym
;
2020 e
->symtree
= parent_st
; /* Point to the right thing. */
2022 if (sym
->attr
.flavor
== FL_PROCEDURE
2023 || sym
->attr
.intrinsic
2024 || sym
->attr
.external
)
2026 if (!gfc_resolve_expr (e
))
2032 e
->expr_type
= EXPR_VARIABLE
;
2034 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2035 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2036 && CLASS_DATA (sym
)->as
))
2038 e
->rank
= sym
->ts
.type
== BT_CLASS
2039 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2040 e
->ref
= gfc_get_ref ();
2041 e
->ref
->type
= REF_ARRAY
;
2042 e
->ref
->u
.ar
.type
= AR_FULL
;
2043 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2044 ? CLASS_DATA (sym
)->as
: sym
->as
;
2047 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2048 primary.c (match_actual_arg). If above code determines that it
2049 is a variable instead, it needs to be resolved as it was not
2050 done at the beginning of this function. */
2051 save_need_full_assumed_size
= need_full_assumed_size
;
2052 if (e
->expr_type
!= EXPR_VARIABLE
)
2053 need_full_assumed_size
= 0;
2054 if (!gfc_resolve_expr (e
))
2056 need_full_assumed_size
= save_need_full_assumed_size
;
2059 /* Check argument list functions %VAL, %LOC and %REF. There is
2060 nothing to do for %REF. */
2061 if (arg
->name
&& arg
->name
[0] == '%')
2063 if (strncmp ("%VAL", arg
->name
, 4) == 0)
2065 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2067 gfc_error ("By-value argument at %L is not of numeric "
2074 gfc_error ("By-value argument at %L cannot be an array or "
2075 "an array section", &e
->where
);
2079 /* Intrinsics are still PROC_UNKNOWN here. However,
2080 since same file external procedures are not resolvable
2081 in gfortran, it is a good deal easier to leave them to
2083 if (ptype
!= PROC_UNKNOWN
2084 && ptype
!= PROC_DUMMY
2085 && ptype
!= PROC_EXTERNAL
2086 && ptype
!= PROC_MODULE
)
2088 gfc_error ("By-value argument at %L is not allowed "
2089 "in this context", &e
->where
);
2094 /* Statement functions have already been excluded above. */
2095 else if (strncmp ("%LOC", arg
->name
, 4) == 0
2096 && e
->ts
.type
== BT_PROCEDURE
)
2098 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2100 gfc_error ("Passing internal procedure at %L by location "
2101 "not allowed", &e
->where
);
2107 comp
= gfc_get_proc_ptr_comp(e
);
2108 if (e
->expr_type
== EXPR_VARIABLE
2109 && comp
&& comp
->attr
.elemental
)
2111 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2112 "allowed as an actual argument at %L", comp
->name
,
2116 /* Fortran 2008, C1237. */
2117 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2118 && gfc_has_ultimate_pointer (e
))
2120 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2121 "component", &e
->where
);
2125 first_actual_arg
= false;
2128 return_value
= true;
2131 actual_arg
= actual_arg_sav
;
2132 first_actual_arg
= first_actual_arg_sav
;
2134 return return_value
;
2138 /* Do the checks of the actual argument list that are specific to elemental
2139 procedures. If called with c == NULL, we have a function, otherwise if
2140 expr == NULL, we have a subroutine. */
2143 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2145 gfc_actual_arglist
*arg0
;
2146 gfc_actual_arglist
*arg
;
2147 gfc_symbol
*esym
= NULL
;
2148 gfc_intrinsic_sym
*isym
= NULL
;
2150 gfc_intrinsic_arg
*iformal
= NULL
;
2151 gfc_formal_arglist
*eformal
= NULL
;
2152 bool formal_optional
= false;
2153 bool set_by_optional
= false;
2157 /* Is this an elemental procedure? */
2158 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2160 if (expr
->value
.function
.esym
!= NULL
2161 && expr
->value
.function
.esym
->attr
.elemental
)
2163 arg0
= expr
->value
.function
.actual
;
2164 esym
= expr
->value
.function
.esym
;
2166 else if (expr
->value
.function
.isym
!= NULL
2167 && expr
->value
.function
.isym
->elemental
)
2169 arg0
= expr
->value
.function
.actual
;
2170 isym
= expr
->value
.function
.isym
;
2175 else if (c
&& c
->ext
.actual
!= NULL
)
2177 arg0
= c
->ext
.actual
;
2179 if (c
->resolved_sym
)
2180 esym
= c
->resolved_sym
;
2182 esym
= c
->symtree
->n
.sym
;
2185 if (!esym
->attr
.elemental
)
2191 /* The rank of an elemental is the rank of its array argument(s). */
2192 for (arg
= arg0
; arg
; arg
= arg
->next
)
2194 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2196 rank
= arg
->expr
->rank
;
2197 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2198 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2199 set_by_optional
= true;
2201 /* Function specific; set the result rank and shape. */
2205 if (!expr
->shape
&& arg
->expr
->shape
)
2207 expr
->shape
= gfc_get_shape (rank
);
2208 for (i
= 0; i
< rank
; i
++)
2209 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2216 /* If it is an array, it shall not be supplied as an actual argument
2217 to an elemental procedure unless an array of the same rank is supplied
2218 as an actual argument corresponding to a nonoptional dummy argument of
2219 that elemental procedure(12.4.1.5). */
2220 formal_optional
= false;
2222 iformal
= isym
->formal
;
2224 eformal
= esym
->formal
;
2226 for (arg
= arg0
; arg
; arg
= arg
->next
)
2230 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2231 formal_optional
= true;
2232 eformal
= eformal
->next
;
2234 else if (isym
&& iformal
)
2236 if (iformal
->optional
)
2237 formal_optional
= true;
2238 iformal
= iformal
->next
;
2241 formal_optional
= true;
2243 if (pedantic
&& arg
->expr
!= NULL
2244 && arg
->expr
->expr_type
== EXPR_VARIABLE
2245 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2248 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2249 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2251 gfc_warning (OPT_Wpedantic
,
2252 "%qs at %L is an array and OPTIONAL; IF IT IS "
2253 "MISSING, it cannot be the actual argument of an "
2254 "ELEMENTAL procedure unless there is a non-optional "
2255 "argument with the same rank (12.4.1.5)",
2256 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2260 for (arg
= arg0
; arg
; arg
= arg
->next
)
2262 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2265 /* Being elemental, the last upper bound of an assumed size array
2266 argument must be present. */
2267 if (resolve_assumed_size_actual (arg
->expr
))
2270 /* Elemental procedure's array actual arguments must conform. */
2273 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2280 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2281 is an array, the intent inout/out variable needs to be also an array. */
2282 if (rank
> 0 && esym
&& expr
== NULL
)
2283 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2284 arg
= arg
->next
, eformal
= eformal
->next
)
2285 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2286 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2287 && arg
->expr
&& arg
->expr
->rank
== 0)
2289 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2290 "ELEMENTAL subroutine %qs is a scalar, but another "
2291 "actual argument is an array", &arg
->expr
->where
,
2292 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2293 : "INOUT", eformal
->sym
->name
, esym
->name
);
2300 /* This function does the checking of references to global procedures
2301 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2302 77 and 95 standards. It checks for a gsymbol for the name, making
2303 one if it does not already exist. If it already exists, then the
2304 reference being resolved must correspond to the type of gsymbol.
2305 Otherwise, the new symbol is equipped with the attributes of the
2306 reference. The corresponding code that is called in creating
2307 global entities is parse.c.
2309 In addition, for all but -std=legacy, the gsymbols are used to
2310 check the interfaces of external procedures from the same file.
2311 The namespace of the gsymbol is resolved and then, once this is
2312 done the interface is checked. */
2316 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2318 if (!gsym_ns
->proc_name
->attr
.recursive
)
2321 if (sym
->ns
== gsym_ns
)
2324 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2331 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2333 if (gsym_ns
->entries
)
2335 gfc_entry_list
*entry
= gsym_ns
->entries
;
2337 for (; entry
; entry
= entry
->next
)
2339 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2341 if (strcmp (gsym_ns
->proc_name
->name
,
2342 sym
->ns
->proc_name
->name
) == 0)
2346 && strcmp (gsym_ns
->proc_name
->name
,
2347 sym
->ns
->parent
->proc_name
->name
) == 0)
2356 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2359 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2361 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2363 for ( ; arg
; arg
= arg
->next
)
2368 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2370 strncpy (errmsg
, _("allocatable argument"), err_len
);
2373 else if (arg
->sym
->attr
.asynchronous
)
2375 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2378 else if (arg
->sym
->attr
.optional
)
2380 strncpy (errmsg
, _("optional argument"), err_len
);
2383 else if (arg
->sym
->attr
.pointer
)
2385 strncpy (errmsg
, _("pointer argument"), err_len
);
2388 else if (arg
->sym
->attr
.target
)
2390 strncpy (errmsg
, _("target argument"), err_len
);
2393 else if (arg
->sym
->attr
.value
)
2395 strncpy (errmsg
, _("value argument"), err_len
);
2398 else if (arg
->sym
->attr
.volatile_
)
2400 strncpy (errmsg
, _("volatile argument"), err_len
);
2403 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2405 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2408 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2410 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2413 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2415 strncpy (errmsg
, _("coarray argument"), err_len
);
2418 else if (false) /* (2d) TODO: parametrized derived type */
2420 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2423 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2425 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2428 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2430 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2433 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2435 /* As assumed-type is unlimited polymorphic (cf. above).
2436 See also TS 29113, Note 6.1. */
2437 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2442 if (sym
->attr
.function
)
2444 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2446 if (res
->attr
.dimension
) /* (3a) */
2448 strncpy (errmsg
, _("array result"), err_len
);
2451 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2453 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2456 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2457 && res
->ts
.u
.cl
->length
2458 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2460 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2465 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2467 strncpy (errmsg
, _("elemental procedure"), err_len
);
2470 else if (sym
->attr
.is_bind_c
) /* (5) */
2472 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2481 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2482 gfc_actual_arglist
**actual
, int sub
)
2486 enum gfc_symbol_type type
;
2489 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2491 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
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_dt_list
*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 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
;
2985 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2986 int *f ATTRIBUTE_UNUSED
)
2990 /* Don't bother recursing into other statement functions
2991 since they will be checked individually for purity. */
2992 if (e
->expr_type
!= EXPR_FUNCTION
2994 || e
->symtree
->n
.sym
== sym
2995 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2998 return pure_function (e
, &name
) ? false : true;
3003 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3005 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3009 /* Check if an impure function is allowed in the current context. */
3011 static bool check_pure_function (gfc_expr
*e
)
3013 const char *name
= NULL
;
3014 if (!pure_function (e
, &name
) && name
)
3018 gfc_error ("Reference to impure function %qs at %L inside a "
3019 "FORALL %s", name
, &e
->where
,
3020 forall_flag
== 2 ? "mask" : "block");
3023 else if (gfc_do_concurrent_flag
)
3025 gfc_error ("Reference to impure function %qs at %L inside a "
3026 "DO CONCURRENT %s", name
, &e
->where
,
3027 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3030 else if (gfc_pure (NULL
))
3032 gfc_error ("Reference to impure function %qs at %L "
3033 "within a PURE procedure", name
, &e
->where
);
3036 gfc_unset_implicit_pure (NULL
);
3042 /* Update current procedure's array_outer_dependency flag, considering
3043 a call to procedure SYM. */
3046 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3048 /* Check to see if this is a sibling function that has not yet
3050 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3051 for (; sibling
; sibling
= sibling
->sibling
)
3053 if (sibling
->proc_name
== sym
)
3055 gfc_resolve (sibling
);
3060 /* If SYM has references to outer arrays, so has the procedure calling
3061 SYM. If SYM is a procedure pointer, we can assume the worst. */
3062 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3063 && gfc_current_ns
->proc_name
)
3064 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3068 /* Resolve a function call, which means resolving the arguments, then figuring
3069 out which entity the name refers to. */
3072 resolve_function (gfc_expr
*expr
)
3074 gfc_actual_arglist
*arg
;
3078 procedure_type p
= PROC_INTRINSIC
;
3079 bool no_formal_args
;
3083 sym
= expr
->symtree
->n
.sym
;
3085 /* If this is a procedure pointer component, it has already been resolved. */
3086 if (gfc_is_proc_ptr_comp (expr
))
3089 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3091 if (sym
&& sym
->attr
.intrinsic
3092 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3093 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3096 if (sym
&& sym
->attr
.intrinsic
3097 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3100 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3102 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3106 /* If this ia a deferred TBP with an abstract interface (which may
3107 of course be referenced), expr->value.function.esym will be set. */
3108 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3110 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3111 sym
->name
, &expr
->where
);
3115 /* Switch off assumed size checking and do this again for certain kinds
3116 of procedure, once the procedure itself is resolved. */
3117 need_full_assumed_size
++;
3119 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3120 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3122 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3123 inquiry_argument
= true;
3124 no_formal_args
= sym
&& is_external_proc (sym
)
3125 && gfc_sym_get_dummy_args (sym
) == NULL
;
3127 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3130 inquiry_argument
= false;
3134 inquiry_argument
= false;
3136 /* Resume assumed_size checking. */
3137 need_full_assumed_size
--;
3139 /* If the procedure is external, check for usage. */
3140 if (sym
&& is_external_proc (sym
))
3141 resolve_global_procedure (sym
, &expr
->where
,
3142 &expr
->value
.function
.actual
, 0);
3144 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3146 && sym
->ts
.u
.cl
->length
== NULL
3148 && !sym
->ts
.deferred
3149 && expr
->value
.function
.esym
== NULL
3150 && !sym
->attr
.contained
)
3152 /* Internal procedures are taken care of in resolve_contained_fntype. */
3153 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3154 "be used at %L since it is not a dummy argument",
3155 sym
->name
, &expr
->where
);
3159 /* See if function is already resolved. */
3161 if (expr
->value
.function
.name
!= NULL
3162 || expr
->value
.function
.isym
!= NULL
)
3164 if (expr
->ts
.type
== BT_UNKNOWN
)
3170 /* Apply the rules of section 14.1.2. */
3172 switch (procedure_kind (sym
))
3175 t
= resolve_generic_f (expr
);
3178 case PTYPE_SPECIFIC
:
3179 t
= resolve_specific_f (expr
);
3183 t
= resolve_unknown_f (expr
);
3187 gfc_internal_error ("resolve_function(): bad function type");
3191 /* If the expression is still a function (it might have simplified),
3192 then we check to see if we are calling an elemental function. */
3194 if (expr
->expr_type
!= EXPR_FUNCTION
)
3197 temp
= need_full_assumed_size
;
3198 need_full_assumed_size
= 0;
3200 if (!resolve_elemental_actual (expr
, NULL
))
3203 if (omp_workshare_flag
3204 && expr
->value
.function
.esym
3205 && ! gfc_elemental (expr
->value
.function
.esym
))
3207 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3208 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3213 #define GENERIC_ID expr->value.function.isym->id
3214 else if (expr
->value
.function
.actual
!= NULL
3215 && expr
->value
.function
.isym
!= NULL
3216 && GENERIC_ID
!= GFC_ISYM_LBOUND
3217 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3218 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3219 && GENERIC_ID
!= GFC_ISYM_LEN
3220 && GENERIC_ID
!= GFC_ISYM_LOC
3221 && GENERIC_ID
!= GFC_ISYM_C_LOC
3222 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3224 /* Array intrinsics must also have the last upper bound of an
3225 assumed size array argument. UBOUND and SIZE have to be
3226 excluded from the check if the second argument is anything
3229 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3231 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3232 && arg
== expr
->value
.function
.actual
3233 && arg
->next
!= NULL
&& arg
->next
->expr
)
3235 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3238 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3241 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3246 if (arg
->expr
!= NULL
3247 && arg
->expr
->rank
> 0
3248 && resolve_assumed_size_actual (arg
->expr
))
3254 need_full_assumed_size
= temp
;
3256 if (!check_pure_function(expr
))
3259 /* Functions without the RECURSIVE attribution are not allowed to
3260 * call themselves. */
3261 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3264 esym
= expr
->value
.function
.esym
;
3266 if (is_illegal_recursion (esym
, gfc_current_ns
))
3268 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3269 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3270 " function %qs is not RECURSIVE",
3271 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3273 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3274 " is not RECURSIVE", esym
->name
, &expr
->where
);
3280 /* Character lengths of use associated functions may contains references to
3281 symbols not referenced from the current program unit otherwise. Make sure
3282 those symbols are marked as referenced. */
3284 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3285 && expr
->value
.function
.esym
->attr
.use_assoc
)
3287 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3290 /* Make sure that the expression has a typespec that works. */
3291 if (expr
->ts
.type
== BT_UNKNOWN
)
3293 if (expr
->symtree
->n
.sym
->result
3294 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3295 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3296 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3299 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3301 if (expr
->value
.function
.esym
)
3302 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3304 update_current_proc_array_outer_dependency (sym
);
3307 /* typebound procedure: Assume the worst. */
3308 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3314 /************* Subroutine resolution *************/
3317 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3324 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3328 else if (gfc_do_concurrent_flag
)
3330 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3334 else if (gfc_pure (NULL
))
3336 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3340 gfc_unset_implicit_pure (NULL
);
3346 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3350 if (sym
->attr
.generic
)
3352 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3355 c
->resolved_sym
= s
;
3356 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3361 /* TODO: Need to search for elemental references in generic interface. */
3364 if (sym
->attr
.intrinsic
)
3365 return gfc_intrinsic_sub_interface (c
, 0);
3372 resolve_generic_s (gfc_code
*c
)
3377 sym
= c
->symtree
->n
.sym
;
3381 m
= resolve_generic_s0 (c
, sym
);
3384 else if (m
== MATCH_ERROR
)
3388 if (sym
->ns
->parent
== NULL
)
3390 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3394 if (!generic_sym (sym
))
3398 /* Last ditch attempt. See if the reference is to an intrinsic
3399 that possesses a matching interface. 14.1.2.4 */
3400 sym
= c
->symtree
->n
.sym
;
3402 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3404 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3405 sym
->name
, &c
->loc
);
3409 m
= gfc_intrinsic_sub_interface (c
, 0);
3413 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3414 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3420 /* Resolve a subroutine call known to be specific. */
3423 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3427 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3429 if (sym
->attr
.dummy
)
3431 sym
->attr
.proc
= PROC_DUMMY
;
3435 sym
->attr
.proc
= PROC_EXTERNAL
;
3439 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3442 if (sym
->attr
.intrinsic
)
3444 m
= gfc_intrinsic_sub_interface (c
, 1);
3448 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3449 "with an intrinsic", sym
->name
, &c
->loc
);
3457 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3459 c
->resolved_sym
= sym
;
3460 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3468 resolve_specific_s (gfc_code
*c
)
3473 sym
= c
->symtree
->n
.sym
;
3477 m
= resolve_specific_s0 (c
, sym
);
3480 if (m
== MATCH_ERROR
)
3483 if (sym
->ns
->parent
== NULL
)
3486 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3492 sym
= c
->symtree
->n
.sym
;
3493 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3494 sym
->name
, &c
->loc
);
3500 /* Resolve a subroutine call not known to be generic nor specific. */
3503 resolve_unknown_s (gfc_code
*c
)
3507 sym
= c
->symtree
->n
.sym
;
3509 if (sym
->attr
.dummy
)
3511 sym
->attr
.proc
= PROC_DUMMY
;
3515 /* See if we have an intrinsic function reference. */
3517 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3519 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3524 /* The reference is to an external name. */
3527 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3529 c
->resolved_sym
= sym
;
3531 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3535 /* Resolve a subroutine call. Although it was tempting to use the same code
3536 for functions, subroutines and functions are stored differently and this
3537 makes things awkward. */
3540 resolve_call (gfc_code
*c
)
3543 procedure_type ptype
= PROC_INTRINSIC
;
3544 gfc_symbol
*csym
, *sym
;
3545 bool no_formal_args
;
3547 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3549 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3551 gfc_error ("%qs at %L has a type, which is not consistent with "
3552 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3556 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3559 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3560 sym
= st
? st
->n
.sym
: NULL
;
3561 if (sym
&& csym
!= sym
3562 && sym
->ns
== gfc_current_ns
3563 && sym
->attr
.flavor
== FL_PROCEDURE
3564 && sym
->attr
.contained
)
3567 if (csym
->attr
.generic
)
3568 c
->symtree
->n
.sym
= sym
;
3571 csym
= c
->symtree
->n
.sym
;
3575 /* If this ia a deferred TBP, c->expr1 will be set. */
3576 if (!c
->expr1
&& csym
)
3578 if (csym
->attr
.abstract
)
3580 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3581 csym
->name
, &c
->loc
);
3585 /* Subroutines without the RECURSIVE attribution are not allowed to
3587 if (is_illegal_recursion (csym
, gfc_current_ns
))
3589 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3590 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3591 "as subroutine %qs is not RECURSIVE",
3592 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3594 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3595 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3601 /* Switch off assumed size checking and do this again for certain kinds
3602 of procedure, once the procedure itself is resolved. */
3603 need_full_assumed_size
++;
3606 ptype
= csym
->attr
.proc
;
3608 no_formal_args
= csym
&& is_external_proc (csym
)
3609 && gfc_sym_get_dummy_args (csym
) == NULL
;
3610 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3613 /* Resume assumed_size checking. */
3614 need_full_assumed_size
--;
3616 /* If external, check for usage. */
3617 if (csym
&& is_external_proc (csym
))
3618 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3621 if (c
->resolved_sym
== NULL
)
3623 c
->resolved_isym
= NULL
;
3624 switch (procedure_kind (csym
))
3627 t
= resolve_generic_s (c
);
3630 case PTYPE_SPECIFIC
:
3631 t
= resolve_specific_s (c
);
3635 t
= resolve_unknown_s (c
);
3639 gfc_internal_error ("resolve_subroutine(): bad function type");
3643 /* Some checks of elemental subroutine actual arguments. */
3644 if (!resolve_elemental_actual (NULL
, c
))
3648 update_current_proc_array_outer_dependency (csym
);
3650 /* Typebound procedure: Assume the worst. */
3651 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3657 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3658 op1->shape and op2->shape are non-NULL return true if their shapes
3659 match. If both op1->shape and op2->shape are non-NULL return false
3660 if their shapes do not match. If either op1->shape or op2->shape is
3661 NULL, return true. */
3664 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3671 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3673 for (i
= 0; i
< op1
->rank
; i
++)
3675 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3677 gfc_error ("Shapes for operands at %L and %L are not conformable",
3678 &op1
->where
, &op2
->where
);
3688 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3689 For example A .AND. B becomes IAND(A, B). */
3691 logical_to_bitwise (gfc_expr
*e
)
3693 gfc_expr
*tmp
, *op1
, *op2
;
3695 gfc_actual_arglist
*args
= NULL
;
3697 gcc_assert (e
->expr_type
== EXPR_OP
);
3699 isym
= GFC_ISYM_NONE
;
3700 op1
= e
->value
.op
.op1
;
3701 op2
= e
->value
.op
.op2
;
3703 switch (e
->value
.op
.op
)
3706 isym
= GFC_ISYM_NOT
;
3709 isym
= GFC_ISYM_IAND
;
3712 isym
= GFC_ISYM_IOR
;
3714 case INTRINSIC_NEQV
:
3715 isym
= GFC_ISYM_IEOR
;
3718 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3719 Change the old expression to NEQV, which will get replaced by IEOR,
3720 and wrap it in NOT. */
3721 tmp
= gfc_copy_expr (e
);
3722 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3723 tmp
= logical_to_bitwise (tmp
);
3724 isym
= GFC_ISYM_NOT
;
3729 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3732 /* Inherit the original operation's operands as arguments. */
3733 args
= gfc_get_actual_arglist ();
3737 args
->next
= gfc_get_actual_arglist ();
3738 args
->next
->expr
= op2
;
3741 /* Convert the expression to a function call. */
3742 e
->expr_type
= EXPR_FUNCTION
;
3743 e
->value
.function
.actual
= args
;
3744 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3745 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3746 e
->value
.function
.esym
= NULL
;
3748 /* Make up a pre-resolved function call symtree if we need to. */
3749 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3752 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3753 sym
= e
->symtree
->n
.sym
;
3755 sym
->attr
.flavor
= FL_PROCEDURE
;
3756 sym
->attr
.function
= 1;
3757 sym
->attr
.elemental
= 1;
3759 sym
->attr
.referenced
= 1;
3760 gfc_intrinsic_symbol (sym
);
3761 gfc_commit_symbol (sym
);
3764 args
->name
= e
->value
.function
.isym
->formal
->name
;
3765 if (e
->value
.function
.isym
->formal
->next
)
3766 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3771 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3772 candidates in CANDIDATES_LEN. */
3774 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3776 size_t &candidates_len
)
3783 /* Not sure how to properly filter here. Use all for a start.
3784 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3785 these as i suppose they don't make terribly sense. */
3787 if (uop
->n
.uop
->op
!= NULL
)
3788 vec_push (candidates
, candidates_len
, uop
->name
);
3792 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3796 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3799 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3802 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3804 char **candidates
= NULL
;
3805 size_t candidates_len
= 0;
3806 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3807 return gfc_closest_fuzzy_match (op
, candidates
);
3811 /* Resolve an operator expression node. This can involve replacing the
3812 operation with a user defined function call. */
3815 resolve_operator (gfc_expr
*e
)
3817 gfc_expr
*op1
, *op2
;
3819 bool dual_locus_error
;
3822 /* Resolve all subnodes-- give them types. */
3824 switch (e
->value
.op
.op
)
3827 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3833 case INTRINSIC_UPLUS
:
3834 case INTRINSIC_UMINUS
:
3835 case INTRINSIC_PARENTHESES
:
3836 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3841 /* Typecheck the new node. */
3843 op1
= e
->value
.op
.op1
;
3844 op2
= e
->value
.op
.op2
;
3845 dual_locus_error
= false;
3847 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3848 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3850 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3854 switch (e
->value
.op
.op
)
3856 case INTRINSIC_UPLUS
:
3857 case INTRINSIC_UMINUS
:
3858 if (op1
->ts
.type
== BT_INTEGER
3859 || op1
->ts
.type
== BT_REAL
3860 || op1
->ts
.type
== BT_COMPLEX
)
3866 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3867 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3870 case INTRINSIC_PLUS
:
3871 case INTRINSIC_MINUS
:
3872 case INTRINSIC_TIMES
:
3873 case INTRINSIC_DIVIDE
:
3874 case INTRINSIC_POWER
:
3875 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3877 gfc_type_convert_binary (e
, 1);
3881 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3883 _("Unexpected derived-type entities in binary intrinsic "
3884 "numeric operator %%<%s%%> at %%L"),
3885 gfc_op2string (e
->value
.op
.op
));
3888 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3889 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3890 gfc_typename (&op2
->ts
));
3893 case INTRINSIC_CONCAT
:
3894 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3895 && op1
->ts
.kind
== op2
->ts
.kind
)
3897 e
->ts
.type
= BT_CHARACTER
;
3898 e
->ts
.kind
= op1
->ts
.kind
;
3903 _("Operands of string concatenation operator at %%L are %s/%s"),
3904 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3910 case INTRINSIC_NEQV
:
3911 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3913 e
->ts
.type
= BT_LOGICAL
;
3914 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3915 if (op1
->ts
.kind
< e
->ts
.kind
)
3916 gfc_convert_type (op1
, &e
->ts
, 2);
3917 else if (op2
->ts
.kind
< e
->ts
.kind
)
3918 gfc_convert_type (op2
, &e
->ts
, 2);
3922 /* Logical ops on integers become bitwise ops with -fdec. */
3924 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
3926 e
->ts
.type
= BT_INTEGER
;
3927 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3928 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
3929 gfc_convert_type (op1
, &e
->ts
, 1);
3930 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
3931 gfc_convert_type (op2
, &e
->ts
, 1);
3932 e
= logical_to_bitwise (e
);
3933 return resolve_function (e
);
3936 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3937 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3938 gfc_typename (&op2
->ts
));
3943 /* Logical ops on integers become bitwise ops with -fdec. */
3944 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
3946 e
->ts
.type
= BT_INTEGER
;
3947 e
->ts
.kind
= op1
->ts
.kind
;
3948 e
= logical_to_bitwise (e
);
3949 return resolve_function (e
);
3952 if (op1
->ts
.type
== BT_LOGICAL
)
3954 e
->ts
.type
= BT_LOGICAL
;
3955 e
->ts
.kind
= op1
->ts
.kind
;
3959 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3960 gfc_typename (&op1
->ts
));
3964 case INTRINSIC_GT_OS
:
3966 case INTRINSIC_GE_OS
:
3968 case INTRINSIC_LT_OS
:
3970 case INTRINSIC_LE_OS
:
3971 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3973 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3980 case INTRINSIC_EQ_OS
:
3982 case INTRINSIC_NE_OS
:
3983 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3984 && op1
->ts
.kind
== op2
->ts
.kind
)
3986 e
->ts
.type
= BT_LOGICAL
;
3987 e
->ts
.kind
= gfc_default_logical_kind
;
3991 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3993 gfc_type_convert_binary (e
, 1);
3995 e
->ts
.type
= BT_LOGICAL
;
3996 e
->ts
.kind
= gfc_default_logical_kind
;
3998 if (warn_compare_reals
)
4000 gfc_intrinsic_op op
= e
->value
.op
.op
;
4002 /* Type conversion has made sure that the types of op1 and op2
4003 agree, so it is only necessary to check the first one. */
4004 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4005 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4006 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4010 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4011 msg
= "Equality comparison for %s at %L";
4013 msg
= "Inequality comparison for %s at %L";
4015 gfc_warning (OPT_Wcompare_reals
, msg
,
4016 gfc_typename (&op1
->ts
), &op1
->where
);
4023 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4025 _("Logicals at %%L must be compared with %s instead of %s"),
4026 (e
->value
.op
.op
== INTRINSIC_EQ
4027 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4028 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4031 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4032 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4033 gfc_typename (&op2
->ts
));
4037 case INTRINSIC_USER
:
4038 if (e
->value
.op
.uop
->op
== NULL
)
4040 const char *name
= e
->value
.op
.uop
->name
;
4041 const char *guessed
;
4042 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4044 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4047 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4049 else if (op2
== NULL
)
4050 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4051 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4054 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4055 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4056 gfc_typename (&op2
->ts
));
4057 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4062 case INTRINSIC_PARENTHESES
:
4064 if (e
->ts
.type
== BT_CHARACTER
)
4065 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4069 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4072 /* Deal with arrayness of an operand through an operator. */
4076 switch (e
->value
.op
.op
)
4078 case INTRINSIC_PLUS
:
4079 case INTRINSIC_MINUS
:
4080 case INTRINSIC_TIMES
:
4081 case INTRINSIC_DIVIDE
:
4082 case INTRINSIC_POWER
:
4083 case INTRINSIC_CONCAT
:
4087 case INTRINSIC_NEQV
:
4089 case INTRINSIC_EQ_OS
:
4091 case INTRINSIC_NE_OS
:
4093 case INTRINSIC_GT_OS
:
4095 case INTRINSIC_GE_OS
:
4097 case INTRINSIC_LT_OS
:
4099 case INTRINSIC_LE_OS
:
4101 if (op1
->rank
== 0 && op2
->rank
== 0)
4104 if (op1
->rank
== 0 && op2
->rank
!= 0)
4106 e
->rank
= op2
->rank
;
4108 if (e
->shape
== NULL
)
4109 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4112 if (op1
->rank
!= 0 && op2
->rank
== 0)
4114 e
->rank
= op1
->rank
;
4116 if (e
->shape
== NULL
)
4117 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4120 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4122 if (op1
->rank
== op2
->rank
)
4124 e
->rank
= op1
->rank
;
4125 if (e
->shape
== NULL
)
4127 t
= compare_shapes (op1
, op2
);
4131 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4136 /* Allow higher level expressions to work. */
4139 /* Try user-defined operators, and otherwise throw an error. */
4140 dual_locus_error
= true;
4142 _("Inconsistent ranks for operator at %%L and %%L"));
4149 case INTRINSIC_PARENTHESES
:
4151 case INTRINSIC_UPLUS
:
4152 case INTRINSIC_UMINUS
:
4153 /* Simply copy arrayness attribute */
4154 e
->rank
= op1
->rank
;
4156 if (e
->shape
== NULL
)
4157 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4165 /* Attempt to simplify the expression. */
4168 t
= gfc_simplify_expr (e
, 0);
4169 /* Some calls do not succeed in simplification and return false
4170 even though there is no error; e.g. variable references to
4171 PARAMETER arrays. */
4172 if (!gfc_is_constant_expr (e
))
4180 match m
= gfc_extend_expr (e
);
4183 if (m
== MATCH_ERROR
)
4187 if (dual_locus_error
)
4188 gfc_error (msg
, &op1
->where
, &op2
->where
);
4190 gfc_error (msg
, &e
->where
);
4196 /************** Array resolution subroutines **************/
4199 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4201 /* Compare two integer expressions. */
4203 static compare_result
4204 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4208 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4209 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4212 /* If either of the types isn't INTEGER, we must have
4213 raised an error earlier. */
4215 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4218 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4228 /* Compare an integer expression with an integer. */
4230 static compare_result
4231 compare_bound_int (gfc_expr
*a
, int b
)
4235 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4238 if (a
->ts
.type
!= BT_INTEGER
)
4239 gfc_internal_error ("compare_bound_int(): Bad expression");
4241 i
= mpz_cmp_si (a
->value
.integer
, b
);
4251 /* Compare an integer expression with a mpz_t. */
4253 static compare_result
4254 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4258 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4261 if (a
->ts
.type
!= BT_INTEGER
)
4262 gfc_internal_error ("compare_bound_int(): Bad expression");
4264 i
= mpz_cmp (a
->value
.integer
, b
);
4274 /* Compute the last value of a sequence given by a triplet.
4275 Return 0 if it wasn't able to compute the last value, or if the
4276 sequence if empty, and 1 otherwise. */
4279 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4280 gfc_expr
*stride
, mpz_t last
)
4284 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4285 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4286 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4289 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4290 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4293 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4295 if (compare_bound (start
, end
) == CMP_GT
)
4297 mpz_set (last
, end
->value
.integer
);
4301 if (compare_bound_int (stride
, 0) == CMP_GT
)
4303 /* Stride is positive */
4304 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4309 /* Stride is negative */
4310 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4315 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4316 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4317 mpz_sub (last
, end
->value
.integer
, rem
);
4324 /* Compare a single dimension of an array reference to the array
4328 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4332 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4334 gcc_assert (ar
->stride
[i
] == NULL
);
4335 /* This implies [*] as [*:] and [*:3] are not possible. */
4336 if (ar
->start
[i
] == NULL
)
4338 gcc_assert (ar
->end
[i
] == NULL
);
4343 /* Given start, end and stride values, calculate the minimum and
4344 maximum referenced indexes. */
4346 switch (ar
->dimen_type
[i
])
4349 case DIMEN_THIS_IMAGE
:
4354 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4357 gfc_warning (0, "Array reference at %L is out of bounds "
4358 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4359 mpz_get_si (ar
->start
[i
]->value
.integer
),
4360 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4362 gfc_warning (0, "Array reference at %L is out of bounds "
4363 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4364 mpz_get_si (ar
->start
[i
]->value
.integer
),
4365 mpz_get_si (as
->lower
[i
]->value
.integer
),
4369 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4372 gfc_warning (0, "Array reference at %L is out of bounds "
4373 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4374 mpz_get_si (ar
->start
[i
]->value
.integer
),
4375 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4377 gfc_warning (0, "Array reference at %L is out of bounds "
4378 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4379 mpz_get_si (ar
->start
[i
]->value
.integer
),
4380 mpz_get_si (as
->upper
[i
]->value
.integer
),
4389 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4390 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4392 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4394 /* Check for zero stride, which is not allowed. */
4395 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4397 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4401 /* if start == len || (stride > 0 && start < len)
4402 || (stride < 0 && start > len),
4403 then the array section contains at least one element. In this
4404 case, there is an out-of-bounds access if
4405 (start < lower || start > upper). */
4406 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4407 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4408 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4409 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4410 && comp_start_end
== CMP_GT
))
4412 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4414 gfc_warning (0, "Lower array reference at %L is out of bounds "
4415 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4416 mpz_get_si (AR_START
->value
.integer
),
4417 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4420 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4422 gfc_warning (0, "Lower array reference at %L is out of bounds "
4423 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4424 mpz_get_si (AR_START
->value
.integer
),
4425 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4430 /* If we can compute the highest index of the array section,
4431 then it also has to be between lower and upper. */
4432 mpz_init (last_value
);
4433 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4436 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4438 gfc_warning (0, "Upper array reference at %L is out of bounds "
4439 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4440 mpz_get_si (last_value
),
4441 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4442 mpz_clear (last_value
);
4445 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4447 gfc_warning (0, "Upper array reference at %L is out of bounds "
4448 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4449 mpz_get_si (last_value
),
4450 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4451 mpz_clear (last_value
);
4455 mpz_clear (last_value
);
4463 gfc_internal_error ("check_dimension(): Bad array reference");
4470 /* Compare an array reference with an array specification. */
4473 compare_spec_to_ref (gfc_array_ref
*ar
)
4480 /* TODO: Full array sections are only allowed as actual parameters. */
4481 if (as
->type
== AS_ASSUMED_SIZE
4482 && (/*ar->type == AR_FULL
4483 ||*/ (ar
->type
== AR_SECTION
4484 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4486 gfc_error ("Rightmost upper bound of assumed size array section "
4487 "not specified at %L", &ar
->where
);
4491 if (ar
->type
== AR_FULL
)
4494 if (as
->rank
!= ar
->dimen
)
4496 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4497 &ar
->where
, ar
->dimen
, as
->rank
);
4501 /* ar->codimen == 0 is a local array. */
4502 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4504 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4505 &ar
->where
, ar
->codimen
, as
->corank
);
4509 for (i
= 0; i
< as
->rank
; i
++)
4510 if (!check_dimension (i
, ar
, as
))
4513 /* Local access has no coarray spec. */
4514 if (ar
->codimen
!= 0)
4515 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4517 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4518 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4520 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4521 i
+ 1 - as
->rank
, &ar
->where
);
4524 if (!check_dimension (i
, ar
, as
))
4532 /* Resolve one part of an array index. */
4535 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4536 int force_index_integer_kind
)
4543 if (!gfc_resolve_expr (index
))
4546 if (check_scalar
&& index
->rank
!= 0)
4548 gfc_error ("Array index at %L must be scalar", &index
->where
);
4552 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4554 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4555 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4559 if (index
->ts
.type
== BT_REAL
)
4560 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4564 if ((index
->ts
.kind
!= gfc_index_integer_kind
4565 && force_index_integer_kind
)
4566 || index
->ts
.type
!= BT_INTEGER
)
4569 ts
.type
= BT_INTEGER
;
4570 ts
.kind
= gfc_index_integer_kind
;
4572 gfc_convert_type_warn (index
, &ts
, 2, 0);
4578 /* Resolve one part of an array index. */
4581 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4583 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4586 /* Resolve a dim argument to an intrinsic function. */
4589 gfc_resolve_dim_arg (gfc_expr
*dim
)
4594 if (!gfc_resolve_expr (dim
))
4599 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4604 if (dim
->ts
.type
!= BT_INTEGER
)
4606 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4610 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4615 ts
.type
= BT_INTEGER
;
4616 ts
.kind
= gfc_index_integer_kind
;
4618 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4624 /* Given an expression that contains array references, update those array
4625 references to point to the right array specifications. While this is
4626 filled in during matching, this information is difficult to save and load
4627 in a module, so we take care of it here.
4629 The idea here is that the original array reference comes from the
4630 base symbol. We traverse the list of reference structures, setting
4631 the stored reference to references. Component references can
4632 provide an additional array specification. */
4635 find_array_spec (gfc_expr
*e
)
4641 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4642 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4644 as
= e
->symtree
->n
.sym
->as
;
4646 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4651 gfc_internal_error ("find_array_spec(): Missing spec");
4658 c
= ref
->u
.c
.component
;
4659 if (c
->attr
.dimension
)
4662 gfc_internal_error ("find_array_spec(): unused as(1)");
4673 gfc_internal_error ("find_array_spec(): unused as(2)");
4677 /* Resolve an array reference. */
4680 resolve_array_ref (gfc_array_ref
*ar
)
4682 int i
, check_scalar
;
4685 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4687 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4689 /* Do not force gfc_index_integer_kind for the start. We can
4690 do fine with any integer kind. This avoids temporary arrays
4691 created for indexing with a vector. */
4692 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4694 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4696 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4701 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4705 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4709 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4710 if (e
->expr_type
== EXPR_VARIABLE
4711 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4712 ar
->start
[i
] = gfc_get_parentheses (e
);
4716 gfc_error ("Array index at %L is an array of rank %d",
4717 &ar
->c_where
[i
], e
->rank
);
4721 /* Fill in the upper bound, which may be lower than the
4722 specified one for something like a(2:10:5), which is
4723 identical to a(2:7:5). Only relevant for strides not equal
4724 to one. Don't try a division by zero. */
4725 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4726 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4727 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4728 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4732 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4734 if (ar
->end
[i
] == NULL
)
4737 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4739 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4741 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4742 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4744 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4755 if (ar
->type
== AR_FULL
)
4757 if (ar
->as
->rank
== 0)
4758 ar
->type
= AR_ELEMENT
;
4760 /* Make sure array is the same as array(:,:), this way
4761 we don't need to special case all the time. */
4762 ar
->dimen
= ar
->as
->rank
;
4763 for (i
= 0; i
< ar
->dimen
; i
++)
4765 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4767 gcc_assert (ar
->start
[i
] == NULL
);
4768 gcc_assert (ar
->end
[i
] == NULL
);
4769 gcc_assert (ar
->stride
[i
] == NULL
);
4773 /* If the reference type is unknown, figure out what kind it is. */
4775 if (ar
->type
== AR_UNKNOWN
)
4777 ar
->type
= AR_ELEMENT
;
4778 for (i
= 0; i
< ar
->dimen
; i
++)
4779 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4780 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4782 ar
->type
= AR_SECTION
;
4787 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4790 if (ar
->as
->corank
&& ar
->codimen
== 0)
4793 ar
->codimen
= ar
->as
->corank
;
4794 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4795 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4803 resolve_substring (gfc_ref
*ref
)
4805 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4807 if (ref
->u
.ss
.start
!= NULL
)
4809 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4812 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4814 gfc_error ("Substring start index at %L must be of type INTEGER",
4815 &ref
->u
.ss
.start
->where
);
4819 if (ref
->u
.ss
.start
->rank
!= 0)
4821 gfc_error ("Substring start index at %L must be scalar",
4822 &ref
->u
.ss
.start
->where
);
4826 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4827 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4828 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4830 gfc_error ("Substring start index at %L is less than one",
4831 &ref
->u
.ss
.start
->where
);
4836 if (ref
->u
.ss
.end
!= NULL
)
4838 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4841 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4843 gfc_error ("Substring end index at %L must be of type INTEGER",
4844 &ref
->u
.ss
.end
->where
);
4848 if (ref
->u
.ss
.end
->rank
!= 0)
4850 gfc_error ("Substring end index at %L must be scalar",
4851 &ref
->u
.ss
.end
->where
);
4855 if (ref
->u
.ss
.length
!= NULL
4856 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4857 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4858 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4860 gfc_error ("Substring end index at %L exceeds the string length",
4861 &ref
->u
.ss
.start
->where
);
4865 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4866 gfc_integer_kinds
[k
].huge
) == CMP_GT
4867 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4868 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4870 gfc_error ("Substring end index at %L is too large",
4871 &ref
->u
.ss
.end
->where
);
4880 /* This function supplies missing substring charlens. */
4883 gfc_resolve_substring_charlen (gfc_expr
*e
)
4886 gfc_expr
*start
, *end
;
4887 gfc_typespec
*ts
= NULL
;
4889 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4891 if (char_ref
->type
== REF_SUBSTRING
)
4893 if (char_ref
->type
== REF_COMPONENT
)
4894 ts
= &char_ref
->u
.c
.component
->ts
;
4900 gcc_assert (char_ref
->next
== NULL
);
4904 if (e
->ts
.u
.cl
->length
)
4905 gfc_free_expr (e
->ts
.u
.cl
->length
);
4906 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4910 e
->ts
.type
= BT_CHARACTER
;
4911 e
->ts
.kind
= gfc_default_character_kind
;
4914 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4916 if (char_ref
->u
.ss
.start
)
4917 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4919 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
4921 if (char_ref
->u
.ss
.end
)
4922 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4923 else if (e
->expr_type
== EXPR_VARIABLE
)
4926 ts
= &e
->symtree
->n
.sym
->ts
;
4927 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4934 gfc_free_expr (start
);
4935 gfc_free_expr (end
);
4939 /* Length = (end - start + 1). */
4940 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4941 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4942 gfc_get_int_expr (gfc_charlen_int_kind
,
4945 /* F2008, 6.4.1: Both the starting point and the ending point shall
4946 be within the range 1, 2, ..., n unless the starting point exceeds
4947 the ending point, in which case the substring has length zero. */
4949 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4950 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4952 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4953 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4955 /* Make sure that the length is simplified. */
4956 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4957 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4961 /* Resolve subtype references. */
4964 resolve_ref (gfc_expr
*expr
)
4966 int current_part_dimension
, n_components
, seen_part_dimension
;
4969 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4970 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4972 find_array_spec (expr
);
4976 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4980 if (!resolve_array_ref (&ref
->u
.ar
))
4988 if (!resolve_substring (ref
))
4993 /* Check constraints on part references. */
4995 current_part_dimension
= 0;
4996 seen_part_dimension
= 0;
4999 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5004 switch (ref
->u
.ar
.type
)
5007 /* Coarray scalar. */
5008 if (ref
->u
.ar
.as
->rank
== 0)
5010 current_part_dimension
= 0;
5015 current_part_dimension
= 1;
5019 current_part_dimension
= 0;
5023 gfc_internal_error ("resolve_ref(): Bad array reference");
5029 if (current_part_dimension
|| seen_part_dimension
)
5032 if (ref
->u
.c
.component
->attr
.pointer
5033 || ref
->u
.c
.component
->attr
.proc_pointer
5034 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5035 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5037 gfc_error ("Component to the right of a part reference "
5038 "with nonzero rank must not have the POINTER "
5039 "attribute at %L", &expr
->where
);
5042 else if (ref
->u
.c
.component
->attr
.allocatable
5043 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5044 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5047 gfc_error ("Component to the right of a part reference "
5048 "with nonzero rank must not have the ALLOCATABLE "
5049 "attribute at %L", &expr
->where
);
5061 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5062 || ref
->next
== NULL
)
5063 && current_part_dimension
5064 && seen_part_dimension
)
5066 gfc_error ("Two or more part references with nonzero rank must "
5067 "not be specified at %L", &expr
->where
);
5071 if (ref
->type
== REF_COMPONENT
)
5073 if (current_part_dimension
)
5074 seen_part_dimension
= 1;
5076 /* reset to make sure */
5077 current_part_dimension
= 0;
5085 /* Given an expression, determine its shape. This is easier than it sounds.
5086 Leaves the shape array NULL if it is not possible to determine the shape. */
5089 expression_shape (gfc_expr
*e
)
5091 mpz_t array
[GFC_MAX_DIMENSIONS
];
5094 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5097 for (i
= 0; i
< e
->rank
; i
++)
5098 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5101 e
->shape
= gfc_get_shape (e
->rank
);
5103 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5108 for (i
--; i
>= 0; i
--)
5109 mpz_clear (array
[i
]);
5113 /* Given a variable expression node, compute the rank of the expression by
5114 examining the base symbol and any reference structures it may have. */
5117 expression_rank (gfc_expr
*e
)
5122 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5123 could lead to serious confusion... */
5124 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5128 if (e
->expr_type
== EXPR_ARRAY
)
5130 /* Constructors can have a rank different from one via RESHAPE(). */
5132 if (e
->symtree
== NULL
)
5138 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5139 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5145 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5147 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5148 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5149 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5151 if (ref
->type
!= REF_ARRAY
)
5154 if (ref
->u
.ar
.type
== AR_FULL
)
5156 rank
= ref
->u
.ar
.as
->rank
;
5160 if (ref
->u
.ar
.type
== AR_SECTION
)
5162 /* Figure out the rank of the section. */
5164 gfc_internal_error ("expression_rank(): Two array specs");
5166 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5167 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5168 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5178 expression_shape (e
);
5183 add_caf_get_intrinsic (gfc_expr
*e
)
5185 gfc_expr
*wrapper
, *tmp_expr
;
5189 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5190 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5195 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5196 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5199 tmp_expr
= XCNEW (gfc_expr
);
5201 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5202 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5203 wrapper
->ts
= e
->ts
;
5204 wrapper
->rank
= e
->rank
;
5206 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5213 remove_caf_get_intrinsic (gfc_expr
*e
)
5215 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5216 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5217 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5218 e
->value
.function
.actual
->expr
= NULL
;
5219 gfc_free_actual_arglist (e
->value
.function
.actual
);
5220 gfc_free_shape (&e
->shape
, e
->rank
);
5226 /* Resolve a variable expression. */
5229 resolve_variable (gfc_expr
*e
)
5236 if (e
->symtree
== NULL
)
5238 sym
= e
->symtree
->n
.sym
;
5240 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5241 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5242 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5244 if (!actual_arg
|| inquiry_argument
)
5246 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5247 "be used as actual argument", sym
->name
, &e
->where
);
5251 /* TS 29113, 407b. */
5252 else if (e
->ts
.type
== BT_ASSUMED
)
5256 gfc_error ("Assumed-type variable %s at %L may only be used "
5257 "as actual argument", sym
->name
, &e
->where
);
5260 else if (inquiry_argument
&& !first_actual_arg
)
5262 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5263 for all inquiry functions in resolve_function; the reason is
5264 that the function-name resolution happens too late in that
5266 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5267 "an inquiry function shall be the first argument",
5268 sym
->name
, &e
->where
);
5272 /* TS 29113, C535b. */
5273 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5274 && CLASS_DATA (sym
)->as
5275 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5276 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5277 && sym
->as
->type
== AS_ASSUMED_RANK
))
5281 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5282 "actual argument", sym
->name
, &e
->where
);
5285 else if (inquiry_argument
&& !first_actual_arg
)
5287 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5288 for all inquiry functions in resolve_function; the reason is
5289 that the function-name resolution happens too late in that
5291 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5292 "to an inquiry function shall be the first argument",
5293 sym
->name
, &e
->where
);
5298 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5299 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5300 && e
->ref
->next
== NULL
))
5302 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5303 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5306 /* TS 29113, 407b. */
5307 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5308 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5309 && e
->ref
->next
== NULL
))
5311 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5312 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5316 /* TS 29113, C535b. */
5317 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5318 && CLASS_DATA (sym
)->as
5319 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5320 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5321 && sym
->as
->type
== AS_ASSUMED_RANK
))
5323 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5324 && e
->ref
->next
== NULL
))
5326 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5327 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5331 /* For variables that are used in an associate (target => object) where
5332 the object's basetype is array valued while the target is scalar,
5333 the ts' type of the component refs is still array valued, which
5334 can't be translated that way. */
5335 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5336 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5337 && CLASS_DATA (sym
->assoc
->target
)->as
)
5339 gfc_ref
*ref
= e
->ref
;
5345 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5346 /* Stop the loop. */
5356 /* If this is an associate-name, it may be parsed with an array reference
5357 in error even though the target is scalar. Fail directly in this case.
5358 TODO Understand why class scalar expressions must be excluded. */
5359 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5361 if (sym
->ts
.type
== BT_CLASS
)
5362 gfc_fix_class_refs (e
);
5363 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5367 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5368 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5370 /* On the other hand, the parser may not have known this is an array;
5371 in this case, we have to add a FULL reference. */
5372 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5374 e
->ref
= gfc_get_ref ();
5375 e
->ref
->type
= REF_ARRAY
;
5376 e
->ref
->u
.ar
.type
= AR_FULL
;
5377 e
->ref
->u
.ar
.dimen
= 0;
5380 /* Like above, but for class types, where the checking whether an array
5381 ref is present is more complicated. Furthermore make sure not to add
5382 the full array ref to _vptr or _len refs. */
5383 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5384 && CLASS_DATA (sym
)->attr
.dimension
5385 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5387 gfc_ref
*ref
, *newref
;
5389 newref
= gfc_get_ref ();
5390 newref
->type
= REF_ARRAY
;
5391 newref
->u
.ar
.type
= AR_FULL
;
5392 newref
->u
.ar
.dimen
= 0;
5393 /* Because this is an associate var and the first ref either is a ref to
5394 the _data component or not, no traversal of the ref chain is
5395 needed. The array ref needs to be inserted after the _data ref,
5396 or when that is not present, which may happend for polymorphic
5397 types, then at the first position. */
5401 else if (ref
->type
== REF_COMPONENT
5402 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5404 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5406 newref
->next
= ref
->next
;
5410 /* Array ref present already. */
5411 gfc_free_ref_list (newref
);
5413 else if (ref
->type
== REF_ARRAY
)
5414 /* Array ref present already. */
5415 gfc_free_ref_list (newref
);
5423 if (e
->ref
&& !resolve_ref (e
))
5426 if (sym
->attr
.flavor
== FL_PROCEDURE
5427 && (!sym
->attr
.function
5428 || (sym
->attr
.function
&& sym
->result
5429 && sym
->result
->attr
.proc_pointer
5430 && !sym
->result
->attr
.function
)))
5432 e
->ts
.type
= BT_PROCEDURE
;
5433 goto resolve_procedure
;
5436 if (sym
->ts
.type
!= BT_UNKNOWN
)
5437 gfc_variable_attr (e
, &e
->ts
);
5438 else if (sym
->attr
.flavor
== FL_PROCEDURE
5439 && sym
->attr
.function
&& sym
->result
5440 && sym
->result
->ts
.type
!= BT_UNKNOWN
5441 && sym
->result
->attr
.proc_pointer
)
5442 e
->ts
= sym
->result
->ts
;
5445 /* Must be a simple variable reference. */
5446 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5451 if (check_assumed_size_reference (sym
, e
))
5454 /* Deal with forward references to entries during gfc_resolve_code, to
5455 satisfy, at least partially, 12.5.2.5. */
5456 if (gfc_current_ns
->entries
5457 && current_entry_id
== sym
->entry_id
5460 && cs_base
->current
->op
!= EXEC_ENTRY
)
5462 gfc_entry_list
*entry
;
5463 gfc_formal_arglist
*formal
;
5465 bool seen
, saved_specification_expr
;
5467 /* If the symbol is a dummy... */
5468 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5470 entry
= gfc_current_ns
->entries
;
5473 /* ...test if the symbol is a parameter of previous entries. */
5474 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5475 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5477 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5484 /* If it has not been seen as a dummy, this is an error. */
5487 if (specification_expr
)
5488 gfc_error ("Variable %qs, used in a specification expression"
5489 ", is referenced at %L before the ENTRY statement "
5490 "in which it is a parameter",
5491 sym
->name
, &cs_base
->current
->loc
);
5493 gfc_error ("Variable %qs is used at %L before the ENTRY "
5494 "statement in which it is a parameter",
5495 sym
->name
, &cs_base
->current
->loc
);
5500 /* Now do the same check on the specification expressions. */
5501 saved_specification_expr
= specification_expr
;
5502 specification_expr
= true;
5503 if (sym
->ts
.type
== BT_CHARACTER
5504 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5508 for (n
= 0; n
< sym
->as
->rank
; n
++)
5510 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5512 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5515 specification_expr
= saved_specification_expr
;
5518 /* Update the symbol's entry level. */
5519 sym
->entry_id
= current_entry_id
+ 1;
5522 /* If a symbol has been host_associated mark it. This is used latter,
5523 to identify if aliasing is possible via host association. */
5524 if (sym
->attr
.flavor
== FL_VARIABLE
5525 && gfc_current_ns
->parent
5526 && (gfc_current_ns
->parent
== sym
->ns
5527 || (gfc_current_ns
->parent
->parent
5528 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5529 sym
->attr
.host_assoc
= 1;
5531 if (gfc_current_ns
->proc_name
5532 && sym
->attr
.dimension
5533 && (sym
->ns
!= gfc_current_ns
5534 || sym
->attr
.use_assoc
5535 || sym
->attr
.in_common
))
5536 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5539 if (t
&& !resolve_procedure_expression (e
))
5542 /* F2008, C617 and C1229. */
5543 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5544 && gfc_is_coindexed (e
))
5546 gfc_ref
*ref
, *ref2
= NULL
;
5548 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5550 if (ref
->type
== REF_COMPONENT
)
5552 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5556 for ( ; ref
; ref
= ref
->next
)
5557 if (ref
->type
== REF_COMPONENT
)
5560 /* Expression itself is not coindexed object. */
5561 if (ref
&& e
->ts
.type
== BT_CLASS
)
5563 gfc_error ("Polymorphic subobject of coindexed object at %L",
5568 /* Expression itself is coindexed object. */
5572 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5573 for ( ; c
; c
= c
->next
)
5574 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5576 gfc_error ("Coindexed object with polymorphic allocatable "
5577 "subcomponent at %L", &e
->where
);
5585 expression_rank (e
);
5587 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5588 add_caf_get_intrinsic (e
);
5590 /* Simplify cases where access to a parameter array results in a
5591 single constant. Suppress errors since those will have been
5592 issued before, as warnings. */
5593 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5595 gfc_push_suppress_errors ();
5596 gfc_simplify_expr (e
, 1);
5597 gfc_pop_suppress_errors ();
5604 /* Checks to see that the correct symbol has been host associated.
5605 The only situation where this arises is that in which a twice
5606 contained function is parsed after the host association is made.
5607 Therefore, on detecting this, change the symbol in the expression
5608 and convert the array reference into an actual arglist if the old
5609 symbol is a variable. */
5611 check_host_association (gfc_expr
*e
)
5613 gfc_symbol
*sym
, *old_sym
;
5617 gfc_actual_arglist
*arg
, *tail
= NULL
;
5618 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5620 /* If the expression is the result of substitution in
5621 interface.c(gfc_extend_expr) because there is no way in
5622 which the host association can be wrong. */
5623 if (e
->symtree
== NULL
5624 || e
->symtree
->n
.sym
== NULL
5625 || e
->user_operator
)
5628 old_sym
= e
->symtree
->n
.sym
;
5630 if (gfc_current_ns
->parent
5631 && old_sym
->ns
!= gfc_current_ns
)
5633 /* Use the 'USE' name so that renamed module symbols are
5634 correctly handled. */
5635 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5637 if (sym
&& old_sym
!= sym
5638 && sym
->ts
.type
== old_sym
->ts
.type
5639 && sym
->attr
.flavor
== FL_PROCEDURE
5640 && sym
->attr
.contained
)
5642 /* Clear the shape, since it might not be valid. */
5643 gfc_free_shape (&e
->shape
, e
->rank
);
5645 /* Give the expression the right symtree! */
5646 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5647 gcc_assert (st
!= NULL
);
5649 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5650 || e
->expr_type
== EXPR_FUNCTION
)
5652 /* Original was function so point to the new symbol, since
5653 the actual argument list is already attached to the
5655 e
->value
.function
.esym
= NULL
;
5660 /* Original was variable so convert array references into
5661 an actual arglist. This does not need any checking now
5662 since resolve_function will take care of it. */
5663 e
->value
.function
.actual
= NULL
;
5664 e
->expr_type
= EXPR_FUNCTION
;
5667 /* Ambiguity will not arise if the array reference is not
5668 the last reference. */
5669 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5670 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5673 gcc_assert (ref
->type
== REF_ARRAY
);
5675 /* Grab the start expressions from the array ref and
5676 copy them into actual arguments. */
5677 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5679 arg
= gfc_get_actual_arglist ();
5680 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5681 if (e
->value
.function
.actual
== NULL
)
5682 tail
= e
->value
.function
.actual
= arg
;
5690 /* Dump the reference list and set the rank. */
5691 gfc_free_ref_list (e
->ref
);
5693 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5696 gfc_resolve_expr (e
);
5700 /* This might have changed! */
5701 return e
->expr_type
== EXPR_FUNCTION
;
5706 gfc_resolve_character_operator (gfc_expr
*e
)
5708 gfc_expr
*op1
= e
->value
.op
.op1
;
5709 gfc_expr
*op2
= e
->value
.op
.op2
;
5710 gfc_expr
*e1
= NULL
;
5711 gfc_expr
*e2
= NULL
;
5713 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5715 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5716 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5717 else if (op1
->expr_type
== EXPR_CONSTANT
)
5718 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5719 op1
->value
.character
.length
);
5721 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5722 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5723 else if (op2
->expr_type
== EXPR_CONSTANT
)
5724 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5725 op2
->value
.character
.length
);
5727 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5737 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5738 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5739 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5740 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5741 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5747 /* Ensure that an character expression has a charlen and, if possible, a
5748 length expression. */
5751 fixup_charlen (gfc_expr
*e
)
5753 /* The cases fall through so that changes in expression type and the need
5754 for multiple fixes are picked up. In all circumstances, a charlen should
5755 be available for the middle end to hang a backend_decl on. */
5756 switch (e
->expr_type
)
5759 gfc_resolve_character_operator (e
);
5763 if (e
->expr_type
== EXPR_ARRAY
)
5764 gfc_resolve_character_array_constructor (e
);
5767 case EXPR_SUBSTRING
:
5768 if (!e
->ts
.u
.cl
&& e
->ref
)
5769 gfc_resolve_substring_charlen (e
);
5774 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5781 /* Update an actual argument to include the passed-object for type-bound
5782 procedures at the right position. */
5784 static gfc_actual_arglist
*
5785 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5788 gcc_assert (argpos
> 0);
5792 gfc_actual_arglist
* result
;
5794 result
= gfc_get_actual_arglist ();
5798 result
->name
= name
;
5804 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5806 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5811 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5814 extract_compcall_passed_object (gfc_expr
* e
)
5818 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5820 if (e
->value
.compcall
.base_object
)
5821 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5824 po
= gfc_get_expr ();
5825 po
->expr_type
= EXPR_VARIABLE
;
5826 po
->symtree
= e
->symtree
;
5827 po
->ref
= gfc_copy_ref (e
->ref
);
5828 po
->where
= e
->where
;
5831 if (!gfc_resolve_expr (po
))
5838 /* Update the arglist of an EXPR_COMPCALL expression to include the
5842 update_compcall_arglist (gfc_expr
* e
)
5845 gfc_typebound_proc
* tbp
;
5847 tbp
= e
->value
.compcall
.tbp
;
5852 po
= extract_compcall_passed_object (e
);
5856 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5862 if (tbp
->pass_arg_num
<= 0)
5865 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5873 /* Extract the passed object from a PPC call (a copy of it). */
5876 extract_ppc_passed_object (gfc_expr
*e
)
5881 po
= gfc_get_expr ();
5882 po
->expr_type
= EXPR_VARIABLE
;
5883 po
->symtree
= e
->symtree
;
5884 po
->ref
= gfc_copy_ref (e
->ref
);
5885 po
->where
= e
->where
;
5887 /* Remove PPC reference. */
5889 while ((*ref
)->next
)
5890 ref
= &(*ref
)->next
;
5891 gfc_free_ref_list (*ref
);
5894 if (!gfc_resolve_expr (po
))
5901 /* Update the actual arglist of a procedure pointer component to include the
5905 update_ppc_arglist (gfc_expr
* e
)
5909 gfc_typebound_proc
* tb
;
5911 ppc
= gfc_get_proc_ptr_comp (e
);
5919 else if (tb
->nopass
)
5922 po
= extract_ppc_passed_object (e
);
5929 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5934 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5936 gfc_error ("Base object for procedure-pointer component call at %L is of"
5937 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5941 gcc_assert (tb
->pass_arg_num
> 0);
5942 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5950 /* Check that the object a TBP is called on is valid, i.e. it must not be
5951 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5954 check_typebound_baseobject (gfc_expr
* e
)
5957 bool return_value
= false;
5959 base
= extract_compcall_passed_object (e
);
5963 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5965 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5969 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5971 gfc_error ("Base object for type-bound procedure call at %L is of"
5972 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5976 /* F08:C1230. If the procedure called is NOPASS,
5977 the base object must be scalar. */
5978 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5980 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5981 " be scalar", &e
->where
);
5985 return_value
= true;
5988 gfc_free_expr (base
);
5989 return return_value
;
5993 /* Resolve a call to a type-bound procedure, either function or subroutine,
5994 statically from the data in an EXPR_COMPCALL expression. The adapted
5995 arglist and the target-procedure symtree are returned. */
5998 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5999 gfc_actual_arglist
** actual
)
6001 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6002 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6004 /* Update the actual arglist for PASS. */
6005 if (!update_compcall_arglist (e
))
6008 *actual
= e
->value
.compcall
.actual
;
6009 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6011 gfc_free_ref_list (e
->ref
);
6013 e
->value
.compcall
.actual
= NULL
;
6015 /* If we find a deferred typebound procedure, check for derived types
6016 that an overriding typebound procedure has not been missed. */
6017 if (e
->value
.compcall
.name
6018 && !e
->value
.compcall
.tbp
->non_overridable
6019 && e
->value
.compcall
.base_object
6020 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6023 gfc_symbol
*derived
;
6025 /* Use the derived type of the base_object. */
6026 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6029 /* If necessary, go through the inheritance chain. */
6030 while (!st
&& derived
)
6032 /* Look for the typebound procedure 'name'. */
6033 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6034 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6035 e
->value
.compcall
.name
);
6037 derived
= gfc_get_derived_super_type (derived
);
6040 /* Now find the specific name in the derived type namespace. */
6041 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6042 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6043 derived
->ns
, 1, &st
);
6051 /* Get the ultimate declared type from an expression. In addition,
6052 return the last class/derived type reference and the copy of the
6053 reference list. If check_types is set true, derived types are
6054 identified as well as class references. */
6056 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6057 gfc_expr
*e
, bool check_types
)
6059 gfc_symbol
*declared
;
6066 *new_ref
= gfc_copy_ref (e
->ref
);
6068 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6070 if (ref
->type
!= REF_COMPONENT
)
6073 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6074 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6075 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6077 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6083 if (declared
== NULL
)
6084 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6090 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6091 which of the specific bindings (if any) matches the arglist and transform
6092 the expression into a call of that binding. */
6095 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6097 gfc_typebound_proc
* genproc
;
6098 const char* genname
;
6100 gfc_symbol
*derived
;
6102 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6103 genname
= e
->value
.compcall
.name
;
6104 genproc
= e
->value
.compcall
.tbp
;
6106 if (!genproc
->is_generic
)
6109 /* Try the bindings on this type and in the inheritance hierarchy. */
6110 for (; genproc
; genproc
= genproc
->overridden
)
6114 gcc_assert (genproc
->is_generic
);
6115 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6118 gfc_actual_arglist
* args
;
6121 gcc_assert (g
->specific
);
6123 if (g
->specific
->error
)
6126 target
= g
->specific
->u
.specific
->n
.sym
;
6128 /* Get the right arglist by handling PASS/NOPASS. */
6129 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6130 if (!g
->specific
->nopass
)
6133 po
= extract_compcall_passed_object (e
);
6136 gfc_free_actual_arglist (args
);
6140 gcc_assert (g
->specific
->pass_arg_num
> 0);
6141 gcc_assert (!g
->specific
->error
);
6142 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6143 g
->specific
->pass_arg
);
6145 resolve_actual_arglist (args
, target
->attr
.proc
,
6146 is_external_proc (target
)
6147 && gfc_sym_get_dummy_args (target
) == NULL
);
6149 /* Check if this arglist matches the formal. */
6150 matches
= gfc_arglist_matches_symbol (&args
, target
);
6152 /* Clean up and break out of the loop if we've found it. */
6153 gfc_free_actual_arglist (args
);
6156 e
->value
.compcall
.tbp
= g
->specific
;
6157 genname
= g
->specific_st
->name
;
6158 /* Pass along the name for CLASS methods, where the vtab
6159 procedure pointer component has to be referenced. */
6167 /* Nothing matching found! */
6168 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6169 " %qs at %L", genname
, &e
->where
);
6173 /* Make sure that we have the right specific instance for the name. */
6174 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6176 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6178 e
->value
.compcall
.tbp
= st
->n
.tb
;
6184 /* Resolve a call to a type-bound subroutine. */
6187 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6189 gfc_actual_arglist
* newactual
;
6190 gfc_symtree
* target
;
6192 /* Check that's really a SUBROUTINE. */
6193 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6195 gfc_error ("%qs at %L should be a SUBROUTINE",
6196 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6200 if (!check_typebound_baseobject (c
->expr1
))
6203 /* Pass along the name for CLASS methods, where the vtab
6204 procedure pointer component has to be referenced. */
6206 *name
= c
->expr1
->value
.compcall
.name
;
6208 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6211 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6213 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6215 /* Transform into an ordinary EXEC_CALL for now. */
6217 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6220 c
->ext
.actual
= newactual
;
6221 c
->symtree
= target
;
6222 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6224 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6226 gfc_free_expr (c
->expr1
);
6227 c
->expr1
= gfc_get_expr ();
6228 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6229 c
->expr1
->symtree
= target
;
6230 c
->expr1
->where
= c
->loc
;
6232 return resolve_call (c
);
6236 /* Resolve a component-call expression. */
6238 resolve_compcall (gfc_expr
* e
, const char **name
)
6240 gfc_actual_arglist
* newactual
;
6241 gfc_symtree
* target
;
6243 /* Check that's really a FUNCTION. */
6244 if (!e
->value
.compcall
.tbp
->function
)
6246 gfc_error ("%qs at %L should be a FUNCTION",
6247 e
->value
.compcall
.name
, &e
->where
);
6251 /* These must not be assign-calls! */
6252 gcc_assert (!e
->value
.compcall
.assign
);
6254 if (!check_typebound_baseobject (e
))
6257 /* Pass along the name for CLASS methods, where the vtab
6258 procedure pointer component has to be referenced. */
6260 *name
= e
->value
.compcall
.name
;
6262 if (!resolve_typebound_generic_call (e
, name
))
6264 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6266 /* Take the rank from the function's symbol. */
6267 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6268 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6270 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6271 arglist to the TBP's binding target. */
6273 if (!resolve_typebound_static (e
, &target
, &newactual
))
6276 e
->value
.function
.actual
= newactual
;
6277 e
->value
.function
.name
= NULL
;
6278 e
->value
.function
.esym
= target
->n
.sym
;
6279 e
->value
.function
.isym
= NULL
;
6280 e
->symtree
= target
;
6281 e
->ts
= target
->n
.sym
->ts
;
6282 e
->expr_type
= EXPR_FUNCTION
;
6284 /* Resolution is not necessary if this is a class subroutine; this
6285 function only has to identify the specific proc. Resolution of
6286 the call will be done next in resolve_typebound_call. */
6287 return gfc_resolve_expr (e
);
6291 static bool resolve_fl_derived (gfc_symbol
*sym
);
6294 /* Resolve a typebound function, or 'method'. First separate all
6295 the non-CLASS references by calling resolve_compcall directly. */
6298 resolve_typebound_function (gfc_expr
* e
)
6300 gfc_symbol
*declared
;
6312 /* Deal with typebound operators for CLASS objects. */
6313 expr
= e
->value
.compcall
.base_object
;
6314 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6315 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6317 /* If the base_object is not a variable, the corresponding actual
6318 argument expression must be stored in e->base_expression so
6319 that the corresponding tree temporary can be used as the base
6320 object in gfc_conv_procedure_call. */
6321 if (expr
->expr_type
!= EXPR_VARIABLE
)
6323 gfc_actual_arglist
*args
;
6325 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6327 if (expr
== args
->expr
)
6332 /* Since the typebound operators are generic, we have to ensure
6333 that any delays in resolution are corrected and that the vtab
6336 declared
= ts
.u
.derived
;
6337 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6338 if (c
->ts
.u
.derived
== NULL
)
6339 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6341 if (!resolve_compcall (e
, &name
))
6344 /* Use the generic name if it is there. */
6345 name
= name
? name
: e
->value
.function
.esym
->name
;
6346 e
->symtree
= expr
->symtree
;
6347 e
->ref
= gfc_copy_ref (expr
->ref
);
6348 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6350 /* Trim away the extraneous references that emerge from nested
6351 use of interface.c (extend_expr). */
6352 if (class_ref
&& class_ref
->next
)
6354 gfc_free_ref_list (class_ref
->next
);
6355 class_ref
->next
= NULL
;
6357 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6359 gfc_free_ref_list (e
->ref
);
6363 gfc_add_vptr_component (e
);
6364 gfc_add_component_ref (e
, name
);
6365 e
->value
.function
.esym
= NULL
;
6366 if (expr
->expr_type
!= EXPR_VARIABLE
)
6367 e
->base_expr
= expr
;
6372 return resolve_compcall (e
, NULL
);
6374 if (!resolve_ref (e
))
6377 /* Get the CLASS declared type. */
6378 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6380 if (!resolve_fl_derived (declared
))
6383 /* Weed out cases of the ultimate component being a derived type. */
6384 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6385 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6387 gfc_free_ref_list (new_ref
);
6388 return resolve_compcall (e
, NULL
);
6391 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6392 declared
= c
->ts
.u
.derived
;
6394 /* Treat the call as if it is a typebound procedure, in order to roll
6395 out the correct name for the specific function. */
6396 if (!resolve_compcall (e
, &name
))
6398 gfc_free_ref_list (new_ref
);
6405 /* Convert the expression to a procedure pointer component call. */
6406 e
->value
.function
.esym
= NULL
;
6412 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6413 gfc_add_vptr_component (e
);
6414 gfc_add_component_ref (e
, name
);
6416 /* Recover the typespec for the expression. This is really only
6417 necessary for generic procedures, where the additional call
6418 to gfc_add_component_ref seems to throw the collection of the
6419 correct typespec. */
6423 gfc_free_ref_list (new_ref
);
6428 /* Resolve a typebound subroutine, or 'method'. First separate all
6429 the non-CLASS references by calling resolve_typebound_call
6433 resolve_typebound_subroutine (gfc_code
*code
)
6435 gfc_symbol
*declared
;
6445 st
= code
->expr1
->symtree
;
6447 /* Deal with typebound operators for CLASS objects. */
6448 expr
= code
->expr1
->value
.compcall
.base_object
;
6449 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6450 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6452 /* If the base_object is not a variable, the corresponding actual
6453 argument expression must be stored in e->base_expression so
6454 that the corresponding tree temporary can be used as the base
6455 object in gfc_conv_procedure_call. */
6456 if (expr
->expr_type
!= EXPR_VARIABLE
)
6458 gfc_actual_arglist
*args
;
6460 args
= code
->expr1
->value
.function
.actual
;
6461 for (; args
; args
= args
->next
)
6462 if (expr
== args
->expr
)
6466 /* Since the typebound operators are generic, we have to ensure
6467 that any delays in resolution are corrected and that the vtab
6469 declared
= expr
->ts
.u
.derived
;
6470 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6471 if (c
->ts
.u
.derived
== NULL
)
6472 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6474 if (!resolve_typebound_call (code
, &name
, NULL
))
6477 /* Use the generic name if it is there. */
6478 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6479 code
->expr1
->symtree
= expr
->symtree
;
6480 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6482 /* Trim away the extraneous references that emerge from nested
6483 use of interface.c (extend_expr). */
6484 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6485 if (class_ref
&& class_ref
->next
)
6487 gfc_free_ref_list (class_ref
->next
);
6488 class_ref
->next
= NULL
;
6490 else if (code
->expr1
->ref
&& !class_ref
)
6492 gfc_free_ref_list (code
->expr1
->ref
);
6493 code
->expr1
->ref
= NULL
;
6496 /* Now use the procedure in the vtable. */
6497 gfc_add_vptr_component (code
->expr1
);
6498 gfc_add_component_ref (code
->expr1
, name
);
6499 code
->expr1
->value
.function
.esym
= NULL
;
6500 if (expr
->expr_type
!= EXPR_VARIABLE
)
6501 code
->expr1
->base_expr
= expr
;
6506 return resolve_typebound_call (code
, NULL
, NULL
);
6508 if (!resolve_ref (code
->expr1
))
6511 /* Get the CLASS declared type. */
6512 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6514 /* Weed out cases of the ultimate component being a derived type. */
6515 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6516 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6518 gfc_free_ref_list (new_ref
);
6519 return resolve_typebound_call (code
, NULL
, NULL
);
6522 if (!resolve_typebound_call (code
, &name
, &overridable
))
6524 gfc_free_ref_list (new_ref
);
6527 ts
= code
->expr1
->ts
;
6531 /* Convert the expression to a procedure pointer component call. */
6532 code
->expr1
->value
.function
.esym
= NULL
;
6533 code
->expr1
->symtree
= st
;
6536 code
->expr1
->ref
= new_ref
;
6538 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6539 gfc_add_vptr_component (code
->expr1
);
6540 gfc_add_component_ref (code
->expr1
, name
);
6542 /* Recover the typespec for the expression. This is really only
6543 necessary for generic procedures, where the additional call
6544 to gfc_add_component_ref seems to throw the collection of the
6545 correct typespec. */
6546 code
->expr1
->ts
= ts
;
6549 gfc_free_ref_list (new_ref
);
6555 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6558 resolve_ppc_call (gfc_code
* c
)
6560 gfc_component
*comp
;
6562 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6563 gcc_assert (comp
!= NULL
);
6565 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6566 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6568 if (!comp
->attr
.subroutine
)
6569 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6571 if (!resolve_ref (c
->expr1
))
6574 if (!update_ppc_arglist (c
->expr1
))
6577 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6579 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6580 !(comp
->ts
.interface
6581 && comp
->ts
.interface
->formal
)))
6584 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6587 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6593 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6596 resolve_expr_ppc (gfc_expr
* e
)
6598 gfc_component
*comp
;
6600 comp
= gfc_get_proc_ptr_comp (e
);
6601 gcc_assert (comp
!= NULL
);
6603 /* Convert to EXPR_FUNCTION. */
6604 e
->expr_type
= EXPR_FUNCTION
;
6605 e
->value
.function
.isym
= NULL
;
6606 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6608 if (comp
->as
!= NULL
)
6609 e
->rank
= comp
->as
->rank
;
6611 if (!comp
->attr
.function
)
6612 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6614 if (!resolve_ref (e
))
6617 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6618 !(comp
->ts
.interface
6619 && comp
->ts
.interface
->formal
)))
6622 if (!update_ppc_arglist (e
))
6625 if (!check_pure_function(e
))
6628 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6635 gfc_is_expandable_expr (gfc_expr
*e
)
6637 gfc_constructor
*con
;
6639 if (e
->expr_type
== EXPR_ARRAY
)
6641 /* Traverse the constructor looking for variables that are flavor
6642 parameter. Parameters must be expanded since they are fully used at
6644 con
= gfc_constructor_first (e
->value
.constructor
);
6645 for (; con
; con
= gfc_constructor_next (con
))
6647 if (con
->expr
->expr_type
== EXPR_VARIABLE
6648 && con
->expr
->symtree
6649 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6650 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6652 if (con
->expr
->expr_type
== EXPR_ARRAY
6653 && gfc_is_expandable_expr (con
->expr
))
6662 /* Sometimes variables in specification expressions of the result
6663 of module procedures in submodules wind up not being the 'real'
6664 dummy. Find this, if possible, in the namespace of the first
6668 fixup_unique_dummy (gfc_expr
*e
)
6670 gfc_symtree
*st
= NULL
;
6671 gfc_symbol
*s
= NULL
;
6673 if (e
->symtree
->n
.sym
->ns
->proc_name
6674 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6675 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6678 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6681 && st
->n
.sym
!= NULL
6682 && st
->n
.sym
->attr
.dummy
)
6686 /* Resolve an expression. That is, make sure that types of operands agree
6687 with their operators, intrinsic operators are converted to function calls
6688 for overloaded types and unresolved function references are resolved. */
6691 gfc_resolve_expr (gfc_expr
*e
)
6694 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6699 /* inquiry_argument only applies to variables. */
6700 inquiry_save
= inquiry_argument
;
6701 actual_arg_save
= actual_arg
;
6702 first_actual_arg_save
= first_actual_arg
;
6704 if (e
->expr_type
!= EXPR_VARIABLE
)
6706 inquiry_argument
= false;
6708 first_actual_arg
= false;
6710 else if (e
->symtree
!= NULL
6711 && *e
->symtree
->name
== '@'
6712 && e
->symtree
->n
.sym
->attr
.dummy
)
6714 /* Deal with submodule specification expressions that are not
6715 found to be referenced in module.c(read_cleanup). */
6716 fixup_unique_dummy (e
);
6719 switch (e
->expr_type
)
6722 t
= resolve_operator (e
);
6728 if (check_host_association (e
))
6729 t
= resolve_function (e
);
6731 t
= resolve_variable (e
);
6733 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6734 && e
->ref
->type
!= REF_SUBSTRING
)
6735 gfc_resolve_substring_charlen (e
);
6740 t
= resolve_typebound_function (e
);
6743 case EXPR_SUBSTRING
:
6744 t
= resolve_ref (e
);
6753 t
= resolve_expr_ppc (e
);
6758 if (!resolve_ref (e
))
6761 t
= gfc_resolve_array_constructor (e
);
6762 /* Also try to expand a constructor. */
6765 expression_rank (e
);
6766 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6767 gfc_expand_constructor (e
, false);
6770 /* This provides the opportunity for the length of constructors with
6771 character valued function elements to propagate the string length
6772 to the expression. */
6773 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6775 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6776 here rather then add a duplicate test for it above. */
6777 gfc_expand_constructor (e
, false);
6778 t
= gfc_resolve_character_array_constructor (e
);
6783 case EXPR_STRUCTURE
:
6784 t
= resolve_ref (e
);
6788 t
= resolve_structure_cons (e
, 0);
6792 t
= gfc_simplify_expr (e
, 0);
6796 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6799 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6802 inquiry_argument
= inquiry_save
;
6803 actual_arg
= actual_arg_save
;
6804 first_actual_arg
= first_actual_arg_save
;
6810 /* Resolve an expression from an iterator. They must be scalar and have
6811 INTEGER or (optionally) REAL type. */
6814 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6815 const char *name_msgid
)
6817 if (!gfc_resolve_expr (expr
))
6820 if (expr
->rank
!= 0)
6822 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6826 if (expr
->ts
.type
!= BT_INTEGER
)
6828 if (expr
->ts
.type
== BT_REAL
)
6831 return gfc_notify_std (GFC_STD_F95_DEL
,
6832 "%s at %L must be integer",
6833 _(name_msgid
), &expr
->where
);
6836 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6843 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6851 /* Resolve the expressions in an iterator structure. If REAL_OK is
6852 false allow only INTEGER type iterators, otherwise allow REAL types.
6853 Set own_scope to true for ac-implied-do and data-implied-do as those
6854 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6857 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6859 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6862 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6863 _("iterator variable")))
6866 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6867 "Start expression in DO loop"))
6870 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6871 "End expression in DO loop"))
6874 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6875 "Step expression in DO loop"))
6878 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6880 if ((iter
->step
->ts
.type
== BT_INTEGER
6881 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6882 || (iter
->step
->ts
.type
== BT_REAL
6883 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6885 gfc_error ("Step expression in DO loop at %L cannot be zero",
6886 &iter
->step
->where
);
6891 /* Convert start, end, and step to the same type as var. */
6892 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6893 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6894 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6896 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6897 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6898 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6900 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6901 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6902 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
6904 if (iter
->start
->expr_type
== EXPR_CONSTANT
6905 && iter
->end
->expr_type
== EXPR_CONSTANT
6906 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6909 if (iter
->start
->ts
.type
== BT_INTEGER
)
6911 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6912 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6916 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6917 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6919 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6920 gfc_warning (OPT_Wzerotrip
,
6921 "DO loop at %L will be executed zero times",
6922 &iter
->step
->where
);
6925 if (iter
->end
->expr_type
== EXPR_CONSTANT
6926 && iter
->end
->ts
.type
== BT_INTEGER
6927 && iter
->step
->expr_type
== EXPR_CONSTANT
6928 && iter
->step
->ts
.type
== BT_INTEGER
6929 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
6930 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
6932 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
6933 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
6935 if (is_step_positive
6936 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
6937 gfc_warning (OPT_Wundefined_do_loop
,
6938 "DO loop at %L is undefined as it overflows",
6939 &iter
->step
->where
);
6940 else if (!is_step_positive
6941 && mpz_cmp (iter
->end
->value
.integer
,
6942 gfc_integer_kinds
[k
].min_int
) == 0)
6943 gfc_warning (OPT_Wundefined_do_loop
,
6944 "DO loop at %L is undefined as it underflows",
6945 &iter
->step
->where
);
6952 /* Traversal function for find_forall_index. f == 2 signals that
6953 that variable itself is not to be checked - only the references. */
6956 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6958 if (expr
->expr_type
!= EXPR_VARIABLE
)
6961 /* A scalar assignment */
6962 if (!expr
->ref
|| *f
== 1)
6964 if (expr
->symtree
->n
.sym
== sym
)
6976 /* Check whether the FORALL index appears in the expression or not.
6977 Returns true if SYM is found in EXPR. */
6980 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6982 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6989 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6990 to be a scalar INTEGER variable. The subscripts and stride are scalar
6991 INTEGERs, and if stride is a constant it must be nonzero.
6992 Furthermore "A subscript or stride in a forall-triplet-spec shall
6993 not contain a reference to any index-name in the
6994 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6997 resolve_forall_iterators (gfc_forall_iterator
*it
)
6999 gfc_forall_iterator
*iter
, *iter2
;
7001 for (iter
= it
; iter
; iter
= iter
->next
)
7003 if (gfc_resolve_expr (iter
->var
)
7004 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7005 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7008 if (gfc_resolve_expr (iter
->start
)
7009 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7010 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7011 &iter
->start
->where
);
7012 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7013 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7015 if (gfc_resolve_expr (iter
->end
)
7016 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7017 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7019 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7020 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7022 if (gfc_resolve_expr (iter
->stride
))
7024 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7025 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7026 &iter
->stride
->where
, "INTEGER");
7028 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7029 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7030 gfc_error ("FORALL stride expression at %L cannot be zero",
7031 &iter
->stride
->where
);
7033 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7034 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7037 for (iter
= it
; iter
; iter
= iter
->next
)
7038 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7040 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7041 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7042 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7043 gfc_error ("FORALL index %qs may not appear in triplet "
7044 "specification at %L", iter
->var
->symtree
->name
,
7045 &iter2
->start
->where
);
7050 /* Given a pointer to a symbol that is a derived type, see if it's
7051 inaccessible, i.e. if it's defined in another module and the components are
7052 PRIVATE. The search is recursive if necessary. Returns zero if no
7053 inaccessible components are found, nonzero otherwise. */
7056 derived_inaccessible (gfc_symbol
*sym
)
7060 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7063 for (c
= sym
->components
; c
; c
= c
->next
)
7065 /* Prevent an infinite loop through this function. */
7066 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7067 && sym
== c
->ts
.u
.derived
)
7070 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7078 /* Resolve the argument of a deallocate expression. The expression must be
7079 a pointer or a full array. */
7082 resolve_deallocate_expr (gfc_expr
*e
)
7084 symbol_attribute attr
;
7085 int allocatable
, pointer
;
7091 if (!gfc_resolve_expr (e
))
7094 if (e
->expr_type
!= EXPR_VARIABLE
)
7097 sym
= e
->symtree
->n
.sym
;
7098 unlimited
= UNLIMITED_POLY(sym
);
7100 if (sym
->ts
.type
== BT_CLASS
)
7102 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7103 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7107 allocatable
= sym
->attr
.allocatable
;
7108 pointer
= sym
->attr
.pointer
;
7110 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7115 if (ref
->u
.ar
.type
!= AR_FULL
7116 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7117 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7122 c
= ref
->u
.c
.component
;
7123 if (c
->ts
.type
== BT_CLASS
)
7125 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7126 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7130 allocatable
= c
->attr
.allocatable
;
7131 pointer
= c
->attr
.pointer
;
7141 attr
= gfc_expr_attr (e
);
7143 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7146 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7152 if (gfc_is_coindexed (e
))
7154 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7159 && !gfc_check_vardef_context (e
, true, true, false,
7160 _("DEALLOCATE object")))
7162 if (!gfc_check_vardef_context (e
, false, true, false,
7163 _("DEALLOCATE object")))
7170 /* Returns true if the expression e contains a reference to the symbol sym. */
7172 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7174 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7181 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7183 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7187 /* Given the expression node e for an allocatable/pointer of derived type to be
7188 allocated, get the expression node to be initialized afterwards (needed for
7189 derived types with default initializers, and derived types with allocatable
7190 components that need nullification.) */
7193 gfc_expr_to_initialize (gfc_expr
*e
)
7199 result
= gfc_copy_expr (e
);
7201 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7202 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7203 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7205 ref
->u
.ar
.type
= AR_FULL
;
7207 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7208 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7213 gfc_free_shape (&result
->shape
, result
->rank
);
7215 /* Recalculate rank, shape, etc. */
7216 gfc_resolve_expr (result
);
7221 /* If the last ref of an expression is an array ref, return a copy of the
7222 expression with that one removed. Otherwise, a copy of the original
7223 expression. This is used for allocate-expressions and pointer assignment
7224 LHS, where there may be an array specification that needs to be stripped
7225 off when using gfc_check_vardef_context. */
7228 remove_last_array_ref (gfc_expr
* e
)
7233 e2
= gfc_copy_expr (e
);
7234 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7235 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7237 gfc_free_ref_list (*r
);
7246 /* Used in resolve_allocate_expr to check that a allocation-object and
7247 a source-expr are conformable. This does not catch all possible
7248 cases; in particular a runtime checking is needed. */
7251 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7254 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7256 /* First compare rank. */
7257 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7258 || (!tail
&& e1
->rank
!= e2
->rank
))
7260 gfc_error ("Source-expr at %L must be scalar or have the "
7261 "same rank as the allocate-object at %L",
7262 &e1
->where
, &e2
->where
);
7273 for (i
= 0; i
< e1
->rank
; i
++)
7275 if (tail
->u
.ar
.start
[i
] == NULL
)
7278 if (tail
->u
.ar
.end
[i
])
7280 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7281 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7282 mpz_add_ui (s
, s
, 1);
7286 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7289 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7291 gfc_error ("Source-expr at %L and allocate-object at %L must "
7292 "have the same shape", &e1
->where
, &e2
->where
);
7305 /* Resolve the expression in an ALLOCATE statement, doing the additional
7306 checks to see whether the expression is OK or not. The expression must
7307 have a trailing array reference that gives the size of the array. */
7310 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7312 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7316 symbol_attribute attr
;
7317 gfc_ref
*ref
, *ref2
;
7320 gfc_symbol
*sym
= NULL
;
7325 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7326 checking of coarrays. */
7327 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7328 if (ref
->next
== NULL
)
7331 if (ref
&& ref
->type
== REF_ARRAY
)
7332 ref
->u
.ar
.in_allocate
= true;
7334 if (!gfc_resolve_expr (e
))
7337 /* Make sure the expression is allocatable or a pointer. If it is
7338 pointer, the next-to-last reference must be a pointer. */
7342 sym
= e
->symtree
->n
.sym
;
7344 /* Check whether ultimate component is abstract and CLASS. */
7347 /* Is the allocate-object unlimited polymorphic? */
7348 unlimited
= UNLIMITED_POLY(e
);
7350 if (e
->expr_type
!= EXPR_VARIABLE
)
7353 attr
= gfc_expr_attr (e
);
7354 pointer
= attr
.pointer
;
7355 dimension
= attr
.dimension
;
7356 codimension
= attr
.codimension
;
7360 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7362 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7363 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7364 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7365 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7366 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7370 allocatable
= sym
->attr
.allocatable
;
7371 pointer
= sym
->attr
.pointer
;
7372 dimension
= sym
->attr
.dimension
;
7373 codimension
= sym
->attr
.codimension
;
7378 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7383 if (ref
->u
.ar
.codimen
> 0)
7386 for (n
= ref
->u
.ar
.dimen
;
7387 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7388 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7395 if (ref
->next
!= NULL
)
7403 gfc_error ("Coindexed allocatable object at %L",
7408 c
= ref
->u
.c
.component
;
7409 if (c
->ts
.type
== BT_CLASS
)
7411 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7412 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7413 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7414 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7415 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7419 allocatable
= c
->attr
.allocatable
;
7420 pointer
= c
->attr
.pointer
;
7421 dimension
= c
->attr
.dimension
;
7422 codimension
= c
->attr
.codimension
;
7423 is_abstract
= c
->attr
.abstract
;
7435 /* Check for F08:C628. */
7436 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7438 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7443 /* Some checks for the SOURCE tag. */
7446 /* Check F03:C631. */
7447 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7449 gfc_error ("Type of entity at %L is type incompatible with "
7450 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7454 /* Check F03:C632 and restriction following Note 6.18. */
7455 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7458 /* Check F03:C633. */
7459 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7461 gfc_error ("The allocate-object at %L and the source-expr at %L "
7462 "shall have the same kind type parameter",
7463 &e
->where
, &code
->expr3
->where
);
7467 /* Check F2008, C642. */
7468 if (code
->expr3
->ts
.type
== BT_DERIVED
7469 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7470 || (code
->expr3
->ts
.u
.derived
->from_intmod
7471 == INTMOD_ISO_FORTRAN_ENV
7472 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7473 == ISOFORTRAN_LOCK_TYPE
)))
7475 gfc_error ("The source-expr at %L shall neither be of type "
7476 "LOCK_TYPE nor have a LOCK_TYPE component if "
7477 "allocate-object at %L is a coarray",
7478 &code
->expr3
->where
, &e
->where
);
7482 /* Check TS18508, C702/C703. */
7483 if (code
->expr3
->ts
.type
== BT_DERIVED
7484 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7485 || (code
->expr3
->ts
.u
.derived
->from_intmod
7486 == INTMOD_ISO_FORTRAN_ENV
7487 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7488 == ISOFORTRAN_EVENT_TYPE
)))
7490 gfc_error ("The source-expr at %L shall neither be of type "
7491 "EVENT_TYPE nor have a EVENT_TYPE component if "
7492 "allocate-object at %L is a coarray",
7493 &code
->expr3
->where
, &e
->where
);
7498 /* Check F08:C629. */
7499 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7502 gcc_assert (e
->ts
.type
== BT_CLASS
);
7503 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7504 "type-spec or source-expr", sym
->name
, &e
->where
);
7508 /* Check F08:C632. */
7509 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7510 && !UNLIMITED_POLY (e
))
7514 if (!e
->ts
.u
.cl
->length
)
7517 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7518 code
->ext
.alloc
.ts
.u
.cl
->length
);
7519 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7521 gfc_error ("Allocating %s at %L with type-spec requires the same "
7522 "character-length parameter as in the declaration",
7523 sym
->name
, &e
->where
);
7528 /* In the variable definition context checks, gfc_expr_attr is used
7529 on the expression. This is fooled by the array specification
7530 present in e, thus we have to eliminate that one temporarily. */
7531 e2
= remove_last_array_ref (e
);
7534 t
= gfc_check_vardef_context (e2
, true, true, false,
7535 _("ALLOCATE object"));
7537 t
= gfc_check_vardef_context (e2
, false, true, false,
7538 _("ALLOCATE object"));
7543 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7544 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7546 /* For class arrays, the initialization with SOURCE is done
7547 using _copy and trans_call. It is convenient to exploit that
7548 when the allocated type is different from the declared type but
7549 no SOURCE exists by setting expr3. */
7550 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7552 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7553 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7554 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7556 /* We have to zero initialize the integer variable. */
7557 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7560 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7562 /* Make sure the vtab symbol is present when
7563 the module variables are generated. */
7564 gfc_typespec ts
= e
->ts
;
7566 ts
= code
->expr3
->ts
;
7567 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7568 ts
= code
->ext
.alloc
.ts
;
7570 /* Finding the vtab also publishes the type's symbol. Therefore this
7571 statement is necessary. */
7572 gfc_find_derived_vtab (ts
.u
.derived
);
7574 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7576 /* Again, make sure the vtab symbol is present when
7577 the module variables are generated. */
7578 gfc_typespec
*ts
= NULL
;
7580 ts
= &code
->expr3
->ts
;
7582 ts
= &code
->ext
.alloc
.ts
;
7586 /* Finding the vtab also publishes the type's symbol. Therefore this
7587 statement is necessary. */
7591 if (dimension
== 0 && codimension
== 0)
7594 /* Make sure the last reference node is an array specification. */
7596 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7597 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7602 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7603 "in ALLOCATE statement at %L", &e
->where
))
7605 if (code
->expr3
->rank
!= 0)
7606 *array_alloc_wo_spec
= true;
7609 gfc_error ("Array specification or array-valued SOURCE= "
7610 "expression required in ALLOCATE statement at %L",
7617 gfc_error ("Array specification required in ALLOCATE statement "
7618 "at %L", &e
->where
);
7623 /* Make sure that the array section reference makes sense in the
7624 context of an ALLOCATE specification. */
7629 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7630 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7632 gfc_error ("Coarray specification required in ALLOCATE statement "
7633 "at %L", &e
->where
);
7637 for (i
= 0; i
< ar
->dimen
; i
++)
7639 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7642 switch (ar
->dimen_type
[i
])
7648 if (ar
->start
[i
] != NULL
7649 && ar
->end
[i
] != NULL
7650 && ar
->stride
[i
] == NULL
)
7658 case DIMEN_THIS_IMAGE
:
7659 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7665 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7667 sym
= a
->expr
->symtree
->n
.sym
;
7669 /* TODO - check derived type components. */
7670 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7673 if ((ar
->start
[i
] != NULL
7674 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7675 || (ar
->end
[i
] != NULL
7676 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7678 gfc_error ("%qs must not appear in the array specification at "
7679 "%L in the same ALLOCATE statement where it is "
7680 "itself allocated", sym
->name
, &ar
->where
);
7686 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7688 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7689 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7691 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7693 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7694 "statement at %L", &e
->where
);
7700 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7701 && ar
->stride
[i
] == NULL
)
7704 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7718 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7720 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7721 gfc_alloc
*a
, *p
, *q
;
7724 errmsg
= code
->expr2
;
7726 /* Check the stat variable. */
7729 gfc_check_vardef_context (stat
, false, false, false,
7730 _("STAT variable"));
7732 if ((stat
->ts
.type
!= BT_INTEGER
7733 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7734 || stat
->ref
->type
== REF_COMPONENT
)))
7736 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7737 "variable", &stat
->where
);
7739 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7740 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7742 gfc_ref
*ref1
, *ref2
;
7745 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7746 ref1
= ref1
->next
, ref2
= ref2
->next
)
7748 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7750 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7759 gfc_error ("Stat-variable at %L shall not be %sd within "
7760 "the same %s statement", &stat
->where
, fcn
, fcn
);
7766 /* Check the errmsg variable. */
7770 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7773 gfc_check_vardef_context (errmsg
, false, false, false,
7774 _("ERRMSG variable"));
7776 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
7777 F18:R930 errmsg-variable is scalar-default-char-variable
7778 F18:R906 default-char-variable is variable
7779 F18:C906 default-char-variable shall be default character. */
7780 if ((errmsg
->ts
.type
!= BT_CHARACTER
7782 && (errmsg
->ref
->type
== REF_ARRAY
7783 || errmsg
->ref
->type
== REF_COMPONENT
)))
7785 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
7786 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
7787 "variable", &errmsg
->where
);
7789 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7790 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7792 gfc_ref
*ref1
, *ref2
;
7795 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7796 ref1
= ref1
->next
, ref2
= ref2
->next
)
7798 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7800 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7809 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7810 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7816 /* Check that an allocate-object appears only once in the statement. */
7818 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7821 for (q
= p
->next
; q
; q
= q
->next
)
7824 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7826 /* This is a potential collision. */
7827 gfc_ref
*pr
= pe
->ref
;
7828 gfc_ref
*qr
= qe
->ref
;
7830 /* Follow the references until
7831 a) They start to differ, in which case there is no error;
7832 you can deallocate a%b and a%c in a single statement
7833 b) Both of them stop, which is an error
7834 c) One of them stops, which is also an error. */
7837 if (pr
== NULL
&& qr
== NULL
)
7839 gfc_error ("Allocate-object at %L also appears at %L",
7840 &pe
->where
, &qe
->where
);
7843 else if (pr
!= NULL
&& qr
== NULL
)
7845 gfc_error ("Allocate-object at %L is subobject of"
7846 " object at %L", &pe
->where
, &qe
->where
);
7849 else if (pr
== NULL
&& qr
!= NULL
)
7851 gfc_error ("Allocate-object at %L is subobject of"
7852 " object at %L", &qe
->where
, &pe
->where
);
7855 /* Here, pr != NULL && qr != NULL */
7856 gcc_assert(pr
->type
== qr
->type
);
7857 if (pr
->type
== REF_ARRAY
)
7859 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7861 gcc_assert (qr
->type
== REF_ARRAY
);
7863 if (pr
->next
&& qr
->next
)
7866 gfc_array_ref
*par
= &(pr
->u
.ar
);
7867 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7869 for (i
=0; i
<par
->dimen
; i
++)
7871 if ((par
->start
[i
] != NULL
7872 || qar
->start
[i
] != NULL
)
7873 && gfc_dep_compare_expr (par
->start
[i
],
7874 qar
->start
[i
]) != 0)
7881 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7894 if (strcmp (fcn
, "ALLOCATE") == 0)
7896 bool arr_alloc_wo_spec
= false;
7898 /* Resolving the expr3 in the loop over all objects to allocate would
7899 execute loop invariant code for each loop item. Therefore do it just
7901 if (code
->expr3
&& code
->expr3
->mold
7902 && code
->expr3
->ts
.type
== BT_DERIVED
)
7904 /* Default initialization via MOLD (non-polymorphic). */
7905 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7908 gfc_resolve_expr (rhs
);
7909 gfc_free_expr (code
->expr3
);
7913 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7914 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7916 if (arr_alloc_wo_spec
&& code
->expr3
)
7918 /* Mark the allocate to have to take the array specification
7920 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7925 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7926 resolve_deallocate_expr (a
->expr
);
7931 /************ SELECT CASE resolution subroutines ************/
7933 /* Callback function for our mergesort variant. Determines interval
7934 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7935 op1 > op2. Assumes we're not dealing with the default case.
7936 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7937 There are nine situations to check. */
7940 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7944 if (op1
->low
== NULL
) /* op1 = (:L) */
7946 /* op2 = (:N), so overlap. */
7948 /* op2 = (M:) or (M:N), L < M */
7949 if (op2
->low
!= NULL
7950 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7953 else if (op1
->high
== NULL
) /* op1 = (K:) */
7955 /* op2 = (M:), so overlap. */
7957 /* op2 = (:N) or (M:N), K > N */
7958 if (op2
->high
!= NULL
7959 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7962 else /* op1 = (K:L) */
7964 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7965 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7967 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7968 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7970 else /* op2 = (M:N) */
7974 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7977 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7986 /* Merge-sort a double linked case list, detecting overlap in the
7987 process. LIST is the head of the double linked case list before it
7988 is sorted. Returns the head of the sorted list if we don't see any
7989 overlap, or NULL otherwise. */
7992 check_case_overlap (gfc_case
*list
)
7994 gfc_case
*p
, *q
, *e
, *tail
;
7995 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7997 /* If the passed list was empty, return immediately. */
8004 /* Loop unconditionally. The only exit from this loop is a return
8005 statement, when we've finished sorting the case list. */
8012 /* Count the number of merges we do in this pass. */
8015 /* Loop while there exists a merge to be done. */
8020 /* Count this merge. */
8023 /* Cut the list in two pieces by stepping INSIZE places
8024 forward in the list, starting from P. */
8027 for (i
= 0; i
< insize
; i
++)
8036 /* Now we have two lists. Merge them! */
8037 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8039 /* See from which the next case to merge comes from. */
8042 /* P is empty so the next case must come from Q. */
8047 else if (qsize
== 0 || q
== NULL
)
8056 cmp
= compare_cases (p
, q
);
8059 /* The whole case range for P is less than the
8067 /* The whole case range for Q is greater than
8068 the case range for P. */
8075 /* The cases overlap, or they are the same
8076 element in the list. Either way, we must
8077 issue an error and get the next case from P. */
8078 /* FIXME: Sort P and Q by line number. */
8079 gfc_error ("CASE label at %L overlaps with CASE "
8080 "label at %L", &p
->where
, &q
->where
);
8088 /* Add the next element to the merged list. */
8097 /* P has now stepped INSIZE places along, and so has Q. So
8098 they're the same. */
8103 /* If we have done only one merge or none at all, we've
8104 finished sorting the cases. */
8113 /* Otherwise repeat, merging lists twice the size. */
8119 /* Check to see if an expression is suitable for use in a CASE statement.
8120 Makes sure that all case expressions are scalar constants of the same
8121 type. Return false if anything is wrong. */
8124 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8126 if (e
== NULL
) return true;
8128 if (e
->ts
.type
!= case_expr
->ts
.type
)
8130 gfc_error ("Expression in CASE statement at %L must be of type %s",
8131 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8135 /* C805 (R808) For a given case-construct, each case-value shall be of
8136 the same type as case-expr. For character type, length differences
8137 are allowed, but the kind type parameters shall be the same. */
8139 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8141 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8142 &e
->where
, case_expr
->ts
.kind
);
8146 /* Convert the case value kind to that of case expression kind,
8149 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8150 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8154 gfc_error ("Expression in CASE statement at %L must be scalar",
8163 /* Given a completely parsed select statement, we:
8165 - Validate all expressions and code within the SELECT.
8166 - Make sure that the selection expression is not of the wrong type.
8167 - Make sure that no case ranges overlap.
8168 - Eliminate unreachable cases and unreachable code resulting from
8169 removing case labels.
8171 The standard does allow unreachable cases, e.g. CASE (5:3). But
8172 they are a hassle for code generation, and to prevent that, we just
8173 cut them out here. This is not necessary for overlapping cases
8174 because they are illegal and we never even try to generate code.
8176 We have the additional caveat that a SELECT construct could have
8177 been a computed GOTO in the source code. Fortunately we can fairly
8178 easily work around that here: The case_expr for a "real" SELECT CASE
8179 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8180 we have to do is make sure that the case_expr is a scalar integer
8184 resolve_select (gfc_code
*code
, bool select_type
)
8187 gfc_expr
*case_expr
;
8188 gfc_case
*cp
, *default_case
, *tail
, *head
;
8189 int seen_unreachable
;
8195 if (code
->expr1
== NULL
)
8197 /* This was actually a computed GOTO statement. */
8198 case_expr
= code
->expr2
;
8199 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8200 gfc_error ("Selection expression in computed GOTO statement "
8201 "at %L must be a scalar integer expression",
8204 /* Further checking is not necessary because this SELECT was built
8205 by the compiler, so it should always be OK. Just move the
8206 case_expr from expr2 to expr so that we can handle computed
8207 GOTOs as normal SELECTs from here on. */
8208 code
->expr1
= code
->expr2
;
8213 case_expr
= code
->expr1
;
8214 type
= case_expr
->ts
.type
;
8217 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8219 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8220 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8222 /* Punt. Going on here just produce more garbage error messages. */
8227 if (!select_type
&& case_expr
->rank
!= 0)
8229 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8230 "expression", &case_expr
->where
);
8236 /* Raise a warning if an INTEGER case value exceeds the range of
8237 the case-expr. Later, all expressions will be promoted to the
8238 largest kind of all case-labels. */
8240 if (type
== BT_INTEGER
)
8241 for (body
= code
->block
; body
; body
= body
->block
)
8242 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8245 && gfc_check_integer_range (cp
->low
->value
.integer
,
8246 case_expr
->ts
.kind
) != ARITH_OK
)
8247 gfc_warning (0, "Expression in CASE statement at %L is "
8248 "not in the range of %s", &cp
->low
->where
,
8249 gfc_typename (&case_expr
->ts
));
8252 && cp
->low
!= cp
->high
8253 && gfc_check_integer_range (cp
->high
->value
.integer
,
8254 case_expr
->ts
.kind
) != ARITH_OK
)
8255 gfc_warning (0, "Expression in CASE statement at %L is "
8256 "not in the range of %s", &cp
->high
->where
,
8257 gfc_typename (&case_expr
->ts
));
8260 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8261 of the SELECT CASE expression and its CASE values. Walk the lists
8262 of case values, and if we find a mismatch, promote case_expr to
8263 the appropriate kind. */
8265 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8267 for (body
= code
->block
; body
; body
= body
->block
)
8269 /* Walk the case label list. */
8270 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8272 /* Intercept the DEFAULT case. It does not have a kind. */
8273 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8276 /* Unreachable case ranges are discarded, so ignore. */
8277 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8278 && cp
->low
!= cp
->high
8279 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8283 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8284 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8286 if (cp
->high
!= NULL
8287 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8288 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8293 /* Assume there is no DEFAULT case. */
8294 default_case
= NULL
;
8299 for (body
= code
->block
; body
; body
= body
->block
)
8301 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8303 seen_unreachable
= 0;
8305 /* Walk the case label list, making sure that all case labels
8307 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8309 /* Count the number of cases in the whole construct. */
8312 /* Intercept the DEFAULT case. */
8313 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8315 if (default_case
!= NULL
)
8317 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8318 "by a second DEFAULT CASE at %L",
8319 &default_case
->where
, &cp
->where
);
8330 /* Deal with single value cases and case ranges. Errors are
8331 issued from the validation function. */
8332 if (!validate_case_label_expr (cp
->low
, case_expr
)
8333 || !validate_case_label_expr (cp
->high
, case_expr
))
8339 if (type
== BT_LOGICAL
8340 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8341 || cp
->low
!= cp
->high
))
8343 gfc_error ("Logical range in CASE statement at %L is not "
8344 "allowed", &cp
->low
->where
);
8349 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8352 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8353 if (value
& seen_logical
)
8355 gfc_error ("Constant logical value in CASE statement "
8356 "is repeated at %L",
8361 seen_logical
|= value
;
8364 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8365 && cp
->low
!= cp
->high
8366 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8368 if (warn_surprising
)
8369 gfc_warning (OPT_Wsurprising
,
8370 "Range specification at %L can never be matched",
8373 cp
->unreachable
= 1;
8374 seen_unreachable
= 1;
8378 /* If the case range can be matched, it can also overlap with
8379 other cases. To make sure it does not, we put it in a
8380 double linked list here. We sort that with a merge sort
8381 later on to detect any overlapping cases. */
8385 head
->right
= head
->left
= NULL
;
8390 tail
->right
->left
= tail
;
8397 /* It there was a failure in the previous case label, give up
8398 for this case label list. Continue with the next block. */
8402 /* See if any case labels that are unreachable have been seen.
8403 If so, we eliminate them. This is a bit of a kludge because
8404 the case lists for a single case statement (label) is a
8405 single forward linked lists. */
8406 if (seen_unreachable
)
8408 /* Advance until the first case in the list is reachable. */
8409 while (body
->ext
.block
.case_list
!= NULL
8410 && body
->ext
.block
.case_list
->unreachable
)
8412 gfc_case
*n
= body
->ext
.block
.case_list
;
8413 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8415 gfc_free_case_list (n
);
8418 /* Strip all other unreachable cases. */
8419 if (body
->ext
.block
.case_list
)
8421 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8423 if (cp
->next
->unreachable
)
8425 gfc_case
*n
= cp
->next
;
8426 cp
->next
= cp
->next
->next
;
8428 gfc_free_case_list (n
);
8435 /* See if there were overlapping cases. If the check returns NULL,
8436 there was overlap. In that case we don't do anything. If head
8437 is non-NULL, we prepend the DEFAULT case. The sorted list can
8438 then used during code generation for SELECT CASE constructs with
8439 a case expression of a CHARACTER type. */
8442 head
= check_case_overlap (head
);
8444 /* Prepend the default_case if it is there. */
8445 if (head
!= NULL
&& default_case
)
8447 default_case
->left
= NULL
;
8448 default_case
->right
= head
;
8449 head
->left
= default_case
;
8453 /* Eliminate dead blocks that may be the result if we've seen
8454 unreachable case labels for a block. */
8455 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8457 if (body
->block
->ext
.block
.case_list
== NULL
)
8459 /* Cut the unreachable block from the code chain. */
8460 gfc_code
*c
= body
->block
;
8461 body
->block
= c
->block
;
8463 /* Kill the dead block, but not the blocks below it. */
8465 gfc_free_statements (c
);
8469 /* More than two cases is legal but insane for logical selects.
8470 Issue a warning for it. */
8471 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8472 gfc_warning (OPT_Wsurprising
,
8473 "Logical SELECT CASE block at %L has more that two cases",
8478 /* Check if a derived type is extensible. */
8481 gfc_type_is_extensible (gfc_symbol
*sym
)
8483 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8484 || (sym
->attr
.is_class
8485 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8490 resolve_types (gfc_namespace
*ns
);
8492 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8493 correct as well as possibly the array-spec. */
8496 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8500 gcc_assert (sym
->assoc
);
8501 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8503 /* If this is for SELECT TYPE, the target may not yet be set. In that
8504 case, return. Resolution will be called later manually again when
8506 target
= sym
->assoc
->target
;
8509 gcc_assert (!sym
->assoc
->dangling
);
8511 if (resolve_target
&& !gfc_resolve_expr (target
))
8514 /* For variable targets, we get some attributes from the target. */
8515 if (target
->expr_type
== EXPR_VARIABLE
)
8519 gcc_assert (target
->symtree
);
8520 tsym
= target
->symtree
->n
.sym
;
8522 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8523 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8525 sym
->attr
.target
= tsym
->attr
.target
8526 || gfc_expr_attr (target
).pointer
;
8527 if (is_subref_array (target
))
8528 sym
->attr
.subref_array_pointer
= 1;
8531 if (target
->expr_type
== EXPR_NULL
)
8533 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8536 else if (target
->ts
.type
== BT_UNKNOWN
)
8538 gfc_error ("Selector at %L has no type", &target
->where
);
8542 /* Get type if this was not already set. Note that it can be
8543 some other type than the target in case this is a SELECT TYPE
8544 selector! So we must not update when the type is already there. */
8545 if (sym
->ts
.type
== BT_UNKNOWN
)
8546 sym
->ts
= target
->ts
;
8548 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8550 /* See if this is a valid association-to-variable. */
8551 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8552 && !gfc_has_vector_subscript (target
));
8554 /* Finally resolve if this is an array or not. */
8555 if (sym
->attr
.dimension
&& target
->rank
== 0)
8557 /* primary.c makes the assumption that a reference to an associate
8558 name followed by a left parenthesis is an array reference. */
8559 if (sym
->ts
.type
!= BT_CHARACTER
)
8560 gfc_error ("Associate-name %qs at %L is used as array",
8561 sym
->name
, &sym
->declared_at
);
8562 sym
->attr
.dimension
= 0;
8567 /* We cannot deal with class selectors that need temporaries. */
8568 if (target
->ts
.type
== BT_CLASS
8569 && gfc_ref_needs_temporary_p (target
->ref
))
8571 gfc_error ("CLASS selector at %L needs a temporary which is not "
8572 "yet implemented", &target
->where
);
8576 if (target
->ts
.type
== BT_CLASS
)
8577 gfc_fix_class_refs (target
);
8579 if (target
->rank
!= 0)
8582 /* The rank may be incorrectly guessed at parsing, therefore make sure
8583 it is corrected now. */
8584 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8587 sym
->as
= gfc_get_array_spec ();
8589 as
->rank
= target
->rank
;
8590 as
->type
= AS_DEFERRED
;
8591 as
->corank
= gfc_get_corank (target
);
8592 sym
->attr
.dimension
= 1;
8593 if (as
->corank
!= 0)
8594 sym
->attr
.codimension
= 1;
8599 /* target's rank is 0, but the type of the sym is still array valued,
8600 which has to be corrected. */
8601 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8604 symbol_attribute attr
;
8605 /* The associated variable's type is still the array type
8606 correct this now. */
8607 gfc_typespec
*ts
= &target
->ts
;
8610 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8615 ts
= &ref
->u
.c
.component
->ts
;
8618 if (ts
->type
== BT_CLASS
)
8619 ts
= &ts
->u
.derived
->components
->ts
;
8625 /* Create a scalar instance of the current class type. Because the
8626 rank of a class array goes into its name, the type has to be
8627 rebuild. The alternative of (re-)setting just the attributes
8628 and as in the current type, destroys the type also in other
8632 sym
->ts
.type
= BT_CLASS
;
8633 attr
= CLASS_DATA (sym
)->attr
;
8635 attr
.associate_var
= 1;
8636 attr
.dimension
= attr
.codimension
= 0;
8637 attr
.class_pointer
= 1;
8638 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8640 /* Make sure the _vptr is set. */
8641 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8642 if (c
->ts
.u
.derived
== NULL
)
8643 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8644 CLASS_DATA (sym
)->attr
.pointer
= 1;
8645 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8646 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8647 gfc_commit_symbol (sym
->ts
.u
.derived
);
8648 /* _vptr now has the _vtab in it, change it to the _vtype. */
8649 if (c
->ts
.u
.derived
->attr
.vtab
)
8650 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8651 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8652 resolve_types (c
->ts
.u
.derived
->ns
);
8656 /* Mark this as an associate variable. */
8657 sym
->attr
.associate_var
= 1;
8659 /* Fix up the type-spec for CHARACTER types. */
8660 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8663 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8665 if (!sym
->ts
.u
.cl
->length
8666 && !sym
->ts
.deferred
8667 && target
->expr_type
== EXPR_CONSTANT
)
8669 sym
->ts
.u
.cl
->length
=
8670 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8671 target
->value
.character
.length
);
8673 else if ((!sym
->ts
.u
.cl
->length
8674 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8675 && target
->expr_type
!= EXPR_VARIABLE
)
8677 sym
->ts
.u
.cl
= gfc_get_charlen();
8678 sym
->ts
.deferred
= 1;
8680 /* This is reset in trans-stmt.c after the assignment
8681 of the target expression to the associate name. */
8682 sym
->attr
.allocatable
= 1;
8686 /* If the target is a good class object, so is the associate variable. */
8687 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8688 sym
->attr
.class_ok
= 1;
8692 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8693 array reference, where necessary. The symbols are artificial and so
8694 the dimension attribute and arrayspec can also be set. In addition,
8695 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8696 This is corrected here as well.*/
8699 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8700 int rank
, gfc_ref
*ref
)
8702 gfc_ref
*nref
= (*expr1
)->ref
;
8703 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8704 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8705 (*expr1
)->rank
= rank
;
8706 if (sym1
->ts
.type
== BT_CLASS
)
8708 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8709 (*expr1
)->ts
= sym1
->ts
;
8711 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8712 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8713 CLASS_DATA (sym1
)->as
8714 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8718 sym1
->attr
.dimension
= 1;
8719 if (sym1
->as
== NULL
&& sym2
)
8720 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8723 for (; nref
; nref
= nref
->next
)
8724 if (nref
->next
== NULL
)
8727 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8728 nref
->next
= gfc_copy_ref (ref
);
8729 else if (ref
&& !nref
)
8730 (*expr1
)->ref
= gfc_copy_ref (ref
);
8735 build_loc_call (gfc_expr
*sym_expr
)
8738 loc_call
= gfc_get_expr ();
8739 loc_call
->expr_type
= EXPR_FUNCTION
;
8740 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
8741 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8742 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8743 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8744 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8745 loc_call
->ts
.type
= BT_INTEGER
;
8746 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8747 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8748 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8749 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8750 loc_call
->where
= sym_expr
->where
;
8754 /* Resolve a SELECT TYPE statement. */
8757 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8759 gfc_symbol
*selector_type
;
8760 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8761 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8764 char name
[GFC_MAX_SYMBOL_LEN
];
8768 gfc_ref
* ref
= NULL
;
8769 gfc_expr
*selector_expr
= NULL
;
8771 ns
= code
->ext
.block
.ns
;
8774 /* Check for F03:C813. */
8775 if (code
->expr1
->ts
.type
!= BT_CLASS
8776 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8778 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8779 "at %L", &code
->loc
);
8783 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8788 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8789 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8790 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8792 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
8793 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
8795 /* F2008: C803 The selector expression must not be coindexed. */
8796 if (gfc_is_coindexed (code
->expr2
))
8798 gfc_error ("Selector at %L must not be coindexed",
8799 &code
->expr2
->where
);
8806 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8808 if (gfc_is_coindexed (code
->expr1
))
8810 gfc_error ("Selector at %L must not be coindexed",
8811 &code
->expr1
->where
);
8816 /* Loop over TYPE IS / CLASS IS cases. */
8817 for (body
= code
->block
; body
; body
= body
->block
)
8819 c
= body
->ext
.block
.case_list
;
8823 /* Check for repeated cases. */
8824 for (tail
= code
->block
; tail
; tail
= tail
->block
)
8826 gfc_case
*d
= tail
->ext
.block
.case_list
;
8830 if (c
->ts
.type
== d
->ts
.type
8831 && ((c
->ts
.type
== BT_DERIVED
8832 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
8833 && !strcmp (c
->ts
.u
.derived
->name
,
8834 d
->ts
.u
.derived
->name
))
8835 || c
->ts
.type
== BT_UNKNOWN
8836 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8837 && c
->ts
.kind
== d
->ts
.kind
)))
8839 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8840 &c
->where
, &d
->where
);
8846 /* Check F03:C815. */
8847 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8848 && !selector_type
->attr
.unlimited_polymorphic
8849 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8851 gfc_error ("Derived type %qs at %L must be extensible",
8852 c
->ts
.u
.derived
->name
, &c
->where
);
8857 /* Check F03:C816. */
8858 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8859 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8860 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8862 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8863 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8864 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8866 gfc_error ("Unexpected intrinsic type %qs at %L",
8867 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8872 /* Check F03:C814. */
8873 if (c
->ts
.type
== BT_CHARACTER
8874 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
8876 gfc_error ("The type-spec at %L shall specify that each length "
8877 "type parameter is assumed", &c
->where
);
8882 /* Intercept the DEFAULT case. */
8883 if (c
->ts
.type
== BT_UNKNOWN
)
8885 /* Check F03:C818. */
8888 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8889 "by a second DEFAULT CASE at %L",
8890 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8895 default_case
= body
;
8902 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8903 target if present. If there are any EXIT statements referring to the
8904 SELECT TYPE construct, this is no problem because the gfc_code
8905 reference stays the same and EXIT is equally possible from the BLOCK
8906 it is changed to. */
8907 code
->op
= EXEC_BLOCK
;
8910 gfc_association_list
* assoc
;
8912 assoc
= gfc_get_association_list ();
8913 assoc
->st
= code
->expr1
->symtree
;
8914 assoc
->target
= gfc_copy_expr (code
->expr2
);
8915 assoc
->target
->where
= code
->expr2
->where
;
8916 /* assoc->variable will be set by resolve_assoc_var. */
8918 code
->ext
.block
.assoc
= assoc
;
8919 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8921 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8924 code
->ext
.block
.assoc
= NULL
;
8926 /* Ensure that the selector rank and arrayspec are available to
8927 correct expressions in which they might be missing. */
8928 if (code
->expr2
&& code
->expr2
->rank
)
8930 rank
= code
->expr2
->rank
;
8931 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
8932 if (ref
->next
== NULL
)
8934 if (ref
&& ref
->type
== REF_ARRAY
)
8935 ref
= gfc_copy_ref (ref
);
8937 /* Fixup expr1 if necessary. */
8939 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
8941 else if (code
->expr1
->rank
)
8943 rank
= code
->expr1
->rank
;
8944 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
8945 if (ref
->next
== NULL
)
8947 if (ref
&& ref
->type
== REF_ARRAY
)
8948 ref
= gfc_copy_ref (ref
);
8951 /* Add EXEC_SELECT to switch on type. */
8952 new_st
= gfc_get_code (code
->op
);
8953 new_st
->expr1
= code
->expr1
;
8954 new_st
->expr2
= code
->expr2
;
8955 new_st
->block
= code
->block
;
8956 code
->expr1
= code
->expr2
= NULL
;
8961 ns
->code
->next
= new_st
;
8963 code
->op
= EXEC_SELECT_TYPE
;
8965 /* Use the intrinsic LOC function to generate an integer expression
8966 for the vtable of the selector. Note that the rank of the selector
8967 expression has to be set to zero. */
8968 gfc_add_vptr_component (code
->expr1
);
8969 code
->expr1
->rank
= 0;
8970 code
->expr1
= build_loc_call (code
->expr1
);
8971 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
8973 /* Loop over TYPE IS / CLASS IS cases. */
8974 for (body
= code
->block
; body
; body
= body
->block
)
8978 c
= body
->ext
.block
.case_list
;
8980 /* Generate an index integer expression for address of the
8981 TYPE/CLASS vtable and store it in c->low. The hash expression
8982 is stored in c->high and is used to resolve intrinsic cases. */
8983 if (c
->ts
.type
!= BT_UNKNOWN
)
8985 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8987 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8989 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
8990 c
->ts
.u
.derived
->hash_value
);
8994 vtab
= gfc_find_vtab (&c
->ts
);
8995 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
8996 e
= CLASS_DATA (vtab
)->initializer
;
8997 c
->high
= gfc_copy_expr (e
);
8998 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9001 ts
.kind
= gfc_integer_4_kind
;
9002 ts
.type
= BT_INTEGER
;
9003 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9007 e
= gfc_lval_expr_from_sym (vtab
);
9008 c
->low
= build_loc_call (e
);
9013 /* Associate temporary to selector. This should only be done
9014 when this case is actually true, so build a new ASSOCIATE
9015 that does precisely this here (instead of using the
9018 if (c
->ts
.type
== BT_CLASS
)
9019 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9020 else if (c
->ts
.type
== BT_DERIVED
)
9021 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9022 else if (c
->ts
.type
== BT_CHARACTER
)
9024 HOST_WIDE_INT charlen
= 0;
9025 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9026 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9027 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9028 snprintf (name
, sizeof (name
),
9029 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9030 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9033 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9036 st
= gfc_find_symtree (ns
->sym_root
, name
);
9037 gcc_assert (st
->n
.sym
->assoc
);
9038 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9039 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9040 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9042 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9043 /* Fixup the target expression if necessary. */
9045 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9048 new_st
= gfc_get_code (EXEC_BLOCK
);
9049 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9050 new_st
->ext
.block
.ns
->code
= body
->next
;
9051 body
->next
= new_st
;
9053 /* Chain in the new list only if it is marked as dangling. Otherwise
9054 there is a CASE label overlap and this is already used. Just ignore,
9055 the error is diagnosed elsewhere. */
9056 if (st
->n
.sym
->assoc
->dangling
)
9058 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9059 st
->n
.sym
->assoc
->dangling
= 0;
9062 resolve_assoc_var (st
->n
.sym
, false);
9065 /* Take out CLASS IS cases for separate treatment. */
9067 while (body
&& body
->block
)
9069 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9071 /* Add to class_is list. */
9072 if (class_is
== NULL
)
9074 class_is
= body
->block
;
9079 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9080 tail
->block
= body
->block
;
9083 /* Remove from EXEC_SELECT list. */
9084 body
->block
= body
->block
->block
;
9097 /* Add a default case to hold the CLASS IS cases. */
9098 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9099 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9101 tail
->ext
.block
.case_list
= gfc_get_case ();
9102 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9104 default_case
= tail
;
9107 /* More than one CLASS IS block? */
9108 if (class_is
->block
)
9112 /* Sort CLASS IS blocks by extension level. */
9116 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9119 /* F03:C817 (check for doubles). */
9120 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9121 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9123 gfc_error ("Double CLASS IS block in SELECT TYPE "
9125 &c2
->ext
.block
.case_list
->where
);
9128 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9129 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9132 (*c1
)->block
= c2
->block
;
9142 /* Generate IF chain. */
9143 if_st
= gfc_get_code (EXEC_IF
);
9145 for (body
= class_is
; body
; body
= body
->block
)
9147 new_st
->block
= gfc_get_code (EXEC_IF
);
9148 new_st
= new_st
->block
;
9149 /* Set up IF condition: Call _gfortran_is_extension_of. */
9150 new_st
->expr1
= gfc_get_expr ();
9151 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9152 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9153 new_st
->expr1
->ts
.kind
= 4;
9154 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9155 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9156 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9157 /* Set up arguments. */
9158 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9159 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9160 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9161 new_st
->expr1
->where
= code
->loc
;
9162 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9163 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9164 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9165 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9166 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9167 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9168 new_st
->next
= body
->next
;
9170 if (default_case
->next
)
9172 new_st
->block
= gfc_get_code (EXEC_IF
);
9173 new_st
= new_st
->block
;
9174 new_st
->next
= default_case
->next
;
9177 /* Replace CLASS DEFAULT code by the IF chain. */
9178 default_case
->next
= if_st
;
9181 /* Resolve the internal code. This can not be done earlier because
9182 it requires that the sym->assoc of selectors is set already. */
9183 gfc_current_ns
= ns
;
9184 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9185 gfc_current_ns
= old_ns
;
9192 /* Resolve a transfer statement. This is making sure that:
9193 -- a derived type being transferred has only non-pointer components
9194 -- a derived type being transferred doesn't have private components, unless
9195 it's being transferred from the module where the type was defined
9196 -- we're not trying to transfer a whole assumed size array. */
9199 resolve_transfer (gfc_code
*code
)
9202 gfc_symbol
*sym
, *derived
;
9206 bool formatted
= false;
9207 gfc_dt
*dt
= code
->ext
.dt
;
9208 gfc_symbol
*dtio_sub
= NULL
;
9212 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9213 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9214 exp
= exp
->value
.op
.op1
;
9216 if (exp
&& exp
->expr_type
== EXPR_NULL
9219 gfc_error ("Invalid context for NULL () intrinsic at %L",
9224 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9225 && exp
->expr_type
!= EXPR_FUNCTION
9226 && exp
->expr_type
!= EXPR_STRUCTURE
))
9229 /* If we are reading, the variable will be changed. Note that
9230 code->ext.dt may be NULL if the TRANSFER is related to
9231 an INQUIRE statement -- but in this case, we are not reading, either. */
9232 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9233 && !gfc_check_vardef_context (exp
, false, false, false,
9237 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9239 /* Go to actual component transferred. */
9240 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9241 if (ref
->type
== REF_COMPONENT
)
9242 ts
= &ref
->u
.c
.component
->ts
;
9244 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9245 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9247 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
9248 derived
= ts
->u
.derived
;
9250 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
9252 /* Determine when to use the formatted DTIO procedure. */
9253 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9256 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9257 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9258 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9260 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9263 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9264 /* Check to see if this is a nested DTIO call, with the
9265 dummy as the io-list object. */
9266 if (sym
&& sym
== dtio_sub
&& sym
->formal
9267 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9268 && exp
->ref
== NULL
)
9270 if (!sym
->attr
.recursive
)
9272 gfc_error ("DTIO %s procedure at %L must be recursive",
9273 sym
->name
, &sym
->declared_at
);
9280 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9282 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9283 "it is processed by a defined input/output procedure",
9288 if (ts
->type
== BT_DERIVED
)
9290 /* Check that transferred derived type doesn't contain POINTER
9291 components unless it is processed by a defined input/output
9293 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9295 gfc_error ("Data transfer element at %L cannot have POINTER "
9296 "components unless it is processed by a defined "
9297 "input/output procedure", &code
->loc
);
9302 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9304 gfc_error ("Data transfer element at %L cannot have "
9305 "procedure pointer components", &code
->loc
);
9309 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9311 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9312 "components unless it is processed by a defined "
9313 "input/output procedure", &code
->loc
);
9317 /* C_PTR and C_FUNPTR have private components which means they can not
9318 be printed. However, if -std=gnu and not -pedantic, allow
9319 the component to be printed to help debugging. */
9320 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9322 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9323 "cannot have PRIVATE components", &code
->loc
))
9326 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9328 gfc_error ("Data transfer element at %L cannot have "
9329 "PRIVATE components unless it is processed by "
9330 "a defined input/output procedure", &code
->loc
);
9335 if (exp
->expr_type
== EXPR_STRUCTURE
)
9338 sym
= exp
->symtree
->n
.sym
;
9340 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9341 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9343 gfc_error ("Data transfer element at %L cannot be a full reference to "
9344 "an assumed-size array", &code
->loc
);
9348 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9349 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9353 /*********** Toplevel code resolution subroutines ***********/
9355 /* Find the set of labels that are reachable from this block. We also
9356 record the last statement in each block. */
9359 find_reachable_labels (gfc_code
*block
)
9366 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9368 /* Collect labels in this block. We don't keep those corresponding
9369 to END {IF|SELECT}, these are checked in resolve_branch by going
9370 up through the code_stack. */
9371 for (c
= block
; c
; c
= c
->next
)
9373 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9374 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9377 /* Merge with labels from parent block. */
9380 gcc_assert (cs_base
->prev
->reachable_labels
);
9381 bitmap_ior_into (cs_base
->reachable_labels
,
9382 cs_base
->prev
->reachable_labels
);
9388 resolve_lock_unlock_event (gfc_code
*code
)
9390 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9391 && code
->expr1
->value
.function
.isym
9392 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9393 remove_caf_get_intrinsic (code
->expr1
);
9395 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9396 && (code
->expr1
->ts
.type
!= BT_DERIVED
9397 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9398 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9399 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9400 || code
->expr1
->rank
!= 0
9401 || (!gfc_is_coarray (code
->expr1
) &&
9402 !gfc_is_coindexed (code
->expr1
))))
9403 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9404 &code
->expr1
->where
);
9405 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9406 && (code
->expr1
->ts
.type
!= BT_DERIVED
9407 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9408 || code
->expr1
->ts
.u
.derived
->from_intmod
9409 != INTMOD_ISO_FORTRAN_ENV
9410 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9411 != ISOFORTRAN_EVENT_TYPE
9412 || code
->expr1
->rank
!= 0))
9413 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9414 &code
->expr1
->where
);
9415 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9416 && !gfc_is_coindexed (code
->expr1
))
9417 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9418 &code
->expr1
->where
);
9419 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9420 gfc_error ("Event variable argument at %L must be a coarray but not "
9421 "coindexed", &code
->expr1
->where
);
9425 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9426 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9427 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9428 &code
->expr2
->where
);
9431 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9432 _("STAT variable")))
9437 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9438 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9439 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9440 &code
->expr3
->where
);
9443 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9444 _("ERRMSG variable")))
9447 /* Check for LOCK the ACQUIRED_LOCK. */
9448 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9449 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9450 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9451 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9452 "variable", &code
->expr4
->where
);
9454 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9455 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9456 _("ACQUIRED_LOCK variable")))
9459 /* Check for EVENT WAIT the UNTIL_COUNT. */
9460 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9462 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9463 || code
->expr4
->rank
!= 0)
9464 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9465 "expression", &code
->expr4
->where
);
9471 resolve_critical (gfc_code
*code
)
9473 gfc_symtree
*symtree
;
9474 gfc_symbol
*lock_type
;
9475 char name
[GFC_MAX_SYMBOL_LEN
];
9476 static int serial
= 0;
9478 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9481 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9482 GFC_PREFIX ("lock_type"));
9484 lock_type
= symtree
->n
.sym
;
9487 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9490 lock_type
= symtree
->n
.sym
;
9491 lock_type
->attr
.flavor
= FL_DERIVED
;
9492 lock_type
->attr
.zero_comp
= 1;
9493 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9494 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9497 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9498 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9501 code
->resolved_sym
= symtree
->n
.sym
;
9502 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9503 symtree
->n
.sym
->attr
.referenced
= 1;
9504 symtree
->n
.sym
->attr
.artificial
= 1;
9505 symtree
->n
.sym
->attr
.codimension
= 1;
9506 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9507 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9508 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9509 symtree
->n
.sym
->as
->corank
= 1;
9510 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9511 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9512 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9514 gfc_commit_symbols();
9519 resolve_sync (gfc_code
*code
)
9521 /* Check imageset. The * case matches expr1 == NULL. */
9524 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9525 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9526 "INTEGER expression", &code
->expr1
->where
);
9527 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9528 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9529 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9530 &code
->expr1
->where
);
9531 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9532 && gfc_simplify_expr (code
->expr1
, 0))
9534 gfc_constructor
*cons
;
9535 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9536 for (; cons
; cons
= gfc_constructor_next (cons
))
9537 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9538 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9539 gfc_error ("Imageset argument at %L must between 1 and "
9540 "num_images()", &cons
->expr
->where
);
9545 gfc_resolve_expr (code
->expr2
);
9547 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9548 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9549 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9550 &code
->expr2
->where
);
9553 gfc_resolve_expr (code
->expr3
);
9555 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9556 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9557 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9558 &code
->expr3
->where
);
9562 /* Given a branch to a label, see if the branch is conforming.
9563 The code node describes where the branch is located. */
9566 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9573 /* Step one: is this a valid branching target? */
9575 if (label
->defined
== ST_LABEL_UNKNOWN
)
9577 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9582 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9584 gfc_error ("Statement at %L is not a valid branch target statement "
9585 "for the branch statement at %L", &label
->where
, &code
->loc
);
9589 /* Step two: make sure this branch is not a branch to itself ;-) */
9591 if (code
->here
== label
)
9594 "Branch at %L may result in an infinite loop", &code
->loc
);
9598 /* Step three: See if the label is in the same block as the
9599 branching statement. The hard work has been done by setting up
9600 the bitmap reachable_labels. */
9602 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9604 /* Check now whether there is a CRITICAL construct; if so, check
9605 whether the label is still visible outside of the CRITICAL block,
9606 which is invalid. */
9607 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9609 if (stack
->current
->op
== EXEC_CRITICAL
9610 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9611 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9612 "label at %L", &code
->loc
, &label
->where
);
9613 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9614 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9615 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9616 "for label at %L", &code
->loc
, &label
->where
);
9622 /* Step four: If we haven't found the label in the bitmap, it may
9623 still be the label of the END of the enclosing block, in which
9624 case we find it by going up the code_stack. */
9626 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9628 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9630 if (stack
->current
->op
== EXEC_CRITICAL
)
9632 /* Note: A label at END CRITICAL does not leave the CRITICAL
9633 construct as END CRITICAL is still part of it. */
9634 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9635 " at %L", &code
->loc
, &label
->where
);
9638 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9640 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9641 "label at %L", &code
->loc
, &label
->where
);
9648 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9652 /* The label is not in an enclosing block, so illegal. This was
9653 allowed in Fortran 66, so we allow it as extension. No
9654 further checks are necessary in this case. */
9655 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9656 "as the GOTO statement at %L", &label
->where
,
9662 /* Check whether EXPR1 has the same shape as EXPR2. */
9665 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9667 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9668 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9669 bool result
= false;
9672 /* Compare the rank. */
9673 if (expr1
->rank
!= expr2
->rank
)
9676 /* Compare the size of each dimension. */
9677 for (i
=0; i
<expr1
->rank
; i
++)
9679 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9682 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9685 if (mpz_cmp (shape
[i
], shape2
[i
]))
9689 /* When either of the two expression is an assumed size array, we
9690 ignore the comparison of dimension sizes. */
9695 gfc_clear_shape (shape
, i
);
9696 gfc_clear_shape (shape2
, i
);
9701 /* Check whether a WHERE assignment target or a WHERE mask expression
9702 has the same shape as the outmost WHERE mask expression. */
9705 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9711 cblock
= code
->block
;
9713 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9714 In case of nested WHERE, only the outmost one is stored. */
9715 if (mask
== NULL
) /* outmost WHERE */
9717 else /* inner WHERE */
9724 /* Check if the mask-expr has a consistent shape with the
9725 outmost WHERE mask-expr. */
9726 if (!resolve_where_shape (cblock
->expr1
, e
))
9727 gfc_error ("WHERE mask at %L has inconsistent shape",
9728 &cblock
->expr1
->where
);
9731 /* the assignment statement of a WHERE statement, or the first
9732 statement in where-body-construct of a WHERE construct */
9733 cnext
= cblock
->next
;
9738 /* WHERE assignment statement */
9741 /* Check shape consistent for WHERE assignment target. */
9742 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9743 gfc_error ("WHERE assignment target at %L has "
9744 "inconsistent shape", &cnext
->expr1
->where
);
9748 case EXEC_ASSIGN_CALL
:
9749 resolve_call (cnext
);
9750 if (!cnext
->resolved_sym
->attr
.elemental
)
9751 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9752 &cnext
->ext
.actual
->expr
->where
);
9755 /* WHERE or WHERE construct is part of a where-body-construct */
9757 resolve_where (cnext
, e
);
9761 gfc_error ("Unsupported statement inside WHERE at %L",
9764 /* the next statement within the same where-body-construct */
9765 cnext
= cnext
->next
;
9767 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9768 cblock
= cblock
->block
;
9773 /* Resolve assignment in FORALL construct.
9774 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9775 FORALL index variables. */
9778 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9782 for (n
= 0; n
< nvar
; n
++)
9784 gfc_symbol
*forall_index
;
9786 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9788 /* Check whether the assignment target is one of the FORALL index
9790 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9791 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9792 gfc_error ("Assignment to a FORALL index variable at %L",
9793 &code
->expr1
->where
);
9796 /* If one of the FORALL index variables doesn't appear in the
9797 assignment variable, then there could be a many-to-one
9798 assignment. Emit a warning rather than an error because the
9799 mask could be resolving this problem. */
9800 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9801 gfc_warning (0, "The FORALL with index %qs is not used on the "
9802 "left side of the assignment at %L and so might "
9803 "cause multiple assignment to this object",
9804 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9810 /* Resolve WHERE statement in FORALL construct. */
9813 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9814 gfc_expr
**var_expr
)
9819 cblock
= code
->block
;
9822 /* the assignment statement of a WHERE statement, or the first
9823 statement in where-body-construct of a WHERE construct */
9824 cnext
= cblock
->next
;
9829 /* WHERE assignment statement */
9831 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9834 /* WHERE operator assignment statement */
9835 case EXEC_ASSIGN_CALL
:
9836 resolve_call (cnext
);
9837 if (!cnext
->resolved_sym
->attr
.elemental
)
9838 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9839 &cnext
->ext
.actual
->expr
->where
);
9842 /* WHERE or WHERE construct is part of a where-body-construct */
9844 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9848 gfc_error ("Unsupported statement inside WHERE at %L",
9851 /* the next statement within the same where-body-construct */
9852 cnext
= cnext
->next
;
9854 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9855 cblock
= cblock
->block
;
9860 /* Traverse the FORALL body to check whether the following errors exist:
9861 1. For assignment, check if a many-to-one assignment happens.
9862 2. For WHERE statement, check the WHERE body to see if there is any
9863 many-to-one assignment. */
9866 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9870 c
= code
->block
->next
;
9876 case EXEC_POINTER_ASSIGN
:
9877 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9880 case EXEC_ASSIGN_CALL
:
9884 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9885 there is no need to handle it here. */
9889 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9894 /* The next statement in the FORALL body. */
9900 /* Counts the number of iterators needed inside a forall construct, including
9901 nested forall constructs. This is used to allocate the needed memory
9902 in gfc_resolve_forall. */
9905 gfc_count_forall_iterators (gfc_code
*code
)
9907 int max_iters
, sub_iters
, current_iters
;
9908 gfc_forall_iterator
*fa
;
9910 gcc_assert(code
->op
== EXEC_FORALL
);
9914 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9917 code
= code
->block
->next
;
9921 if (code
->op
== EXEC_FORALL
)
9923 sub_iters
= gfc_count_forall_iterators (code
);
9924 if (sub_iters
> max_iters
)
9925 max_iters
= sub_iters
;
9930 return current_iters
+ max_iters
;
9934 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9935 gfc_resolve_forall_body to resolve the FORALL body. */
9938 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9940 static gfc_expr
**var_expr
;
9941 static int total_var
= 0;
9942 static int nvar
= 0;
9943 int i
, old_nvar
, tmp
;
9944 gfc_forall_iterator
*fa
;
9948 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
9951 /* Start to resolve a FORALL construct */
9952 if (forall_save
== 0)
9954 /* Count the total number of FORALL indices in the nested FORALL
9955 construct in order to allocate the VAR_EXPR with proper size. */
9956 total_var
= gfc_count_forall_iterators (code
);
9958 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9959 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9962 /* The information about FORALL iterator, including FORALL indices start, end
9963 and stride. An outer FORALL indice cannot appear in start, end or stride. */
9964 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9966 /* Fortran 20008: C738 (R753). */
9967 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
9969 gfc_error ("FORALL index-name at %L must be a scalar variable "
9970 "of type integer", &fa
->var
->where
);
9974 /* Check if any outer FORALL index name is the same as the current
9976 for (i
= 0; i
< nvar
; i
++)
9978 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9979 gfc_error ("An outer FORALL construct already has an index "
9980 "with this name %L", &fa
->var
->where
);
9983 /* Record the current FORALL index. */
9984 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9988 /* No memory leak. */
9989 gcc_assert (nvar
<= total_var
);
9992 /* Resolve the FORALL body. */
9993 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9995 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9996 gfc_resolve_blocks (code
->block
, ns
);
10000 /* Free only the VAR_EXPRs allocated in this frame. */
10001 for (i
= nvar
; i
< tmp
; i
++)
10002 gfc_free_expr (var_expr
[i
]);
10006 /* We are in the outermost FORALL construct. */
10007 gcc_assert (forall_save
== 0);
10009 /* VAR_EXPR is not needed any more. */
10016 /* Resolve a BLOCK construct statement. */
10019 resolve_block_construct (gfc_code
* code
)
10021 /* Resolve the BLOCK's namespace. */
10022 gfc_resolve (code
->ext
.block
.ns
);
10024 /* For an ASSOCIATE block, the associations (and their targets) are already
10025 resolved during resolve_symbol. */
10029 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10033 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10037 for (; b
; b
= b
->block
)
10039 t
= gfc_resolve_expr (b
->expr1
);
10040 if (!gfc_resolve_expr (b
->expr2
))
10046 if (t
&& b
->expr1
!= NULL
10047 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10048 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10054 && b
->expr1
!= NULL
10055 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10056 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10061 resolve_branch (b
->label1
, b
);
10065 resolve_block_construct (b
);
10069 case EXEC_SELECT_TYPE
:
10072 case EXEC_DO_WHILE
:
10073 case EXEC_DO_CONCURRENT
:
10074 case EXEC_CRITICAL
:
10077 case EXEC_IOLENGTH
:
10081 case EXEC_OMP_ATOMIC
:
10082 case EXEC_OACC_ATOMIC
:
10084 gfc_omp_atomic_op aop
10085 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10087 /* Verify this before calling gfc_resolve_code, which might
10089 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10090 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10091 && b
->next
->next
== NULL
)
10092 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10093 && b
->next
->next
!= NULL
10094 && b
->next
->next
->op
== EXEC_ASSIGN
10095 && b
->next
->next
->next
== NULL
));
10099 case EXEC_OACC_PARALLEL_LOOP
:
10100 case EXEC_OACC_PARALLEL
:
10101 case EXEC_OACC_KERNELS_LOOP
:
10102 case EXEC_OACC_KERNELS
:
10103 case EXEC_OACC_DATA
:
10104 case EXEC_OACC_HOST_DATA
:
10105 case EXEC_OACC_LOOP
:
10106 case EXEC_OACC_UPDATE
:
10107 case EXEC_OACC_WAIT
:
10108 case EXEC_OACC_CACHE
:
10109 case EXEC_OACC_ENTER_DATA
:
10110 case EXEC_OACC_EXIT_DATA
:
10111 case EXEC_OACC_ROUTINE
:
10112 case EXEC_OMP_CRITICAL
:
10113 case EXEC_OMP_DISTRIBUTE
:
10114 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10115 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10116 case EXEC_OMP_DISTRIBUTE_SIMD
:
10118 case EXEC_OMP_DO_SIMD
:
10119 case EXEC_OMP_MASTER
:
10120 case EXEC_OMP_ORDERED
:
10121 case EXEC_OMP_PARALLEL
:
10122 case EXEC_OMP_PARALLEL_DO
:
10123 case EXEC_OMP_PARALLEL_DO_SIMD
:
10124 case EXEC_OMP_PARALLEL_SECTIONS
:
10125 case EXEC_OMP_PARALLEL_WORKSHARE
:
10126 case EXEC_OMP_SECTIONS
:
10127 case EXEC_OMP_SIMD
:
10128 case EXEC_OMP_SINGLE
:
10129 case EXEC_OMP_TARGET
:
10130 case EXEC_OMP_TARGET_DATA
:
10131 case EXEC_OMP_TARGET_ENTER_DATA
:
10132 case EXEC_OMP_TARGET_EXIT_DATA
:
10133 case EXEC_OMP_TARGET_PARALLEL
:
10134 case EXEC_OMP_TARGET_PARALLEL_DO
:
10135 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10136 case EXEC_OMP_TARGET_SIMD
:
10137 case EXEC_OMP_TARGET_TEAMS
:
10138 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10139 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10140 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10141 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10142 case EXEC_OMP_TARGET_UPDATE
:
10143 case EXEC_OMP_TASK
:
10144 case EXEC_OMP_TASKGROUP
:
10145 case EXEC_OMP_TASKLOOP
:
10146 case EXEC_OMP_TASKLOOP_SIMD
:
10147 case EXEC_OMP_TASKWAIT
:
10148 case EXEC_OMP_TASKYIELD
:
10149 case EXEC_OMP_TEAMS
:
10150 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10151 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10152 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10153 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10154 case EXEC_OMP_WORKSHARE
:
10158 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10161 gfc_resolve_code (b
->next
, ns
);
10166 /* Does everything to resolve an ordinary assignment. Returns true
10167 if this is an interface assignment. */
10169 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10176 symbol_attribute attr
;
10178 if (gfc_extend_assign (code
, ns
))
10182 if (code
->op
== EXEC_ASSIGN_CALL
)
10184 lhs
= code
->ext
.actual
->expr
;
10185 rhsptr
= &code
->ext
.actual
->next
->expr
;
10189 gfc_actual_arglist
* args
;
10190 gfc_typebound_proc
* tbp
;
10192 gcc_assert (code
->op
== EXEC_COMPCALL
);
10194 args
= code
->expr1
->value
.compcall
.actual
;
10196 rhsptr
= &args
->next
->expr
;
10198 tbp
= code
->expr1
->value
.compcall
.tbp
;
10199 gcc_assert (!tbp
->is_generic
);
10202 /* Make a temporary rhs when there is a default initializer
10203 and rhs is the same symbol as the lhs. */
10204 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10205 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10206 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10207 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10208 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10217 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10218 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10222 /* Handle the case of a BOZ literal on the RHS. */
10223 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10226 if (warn_surprising
)
10227 gfc_warning (OPT_Wsurprising
,
10228 "BOZ literal at %L is bitwise transferred "
10229 "non-integer symbol %qs", &code
->loc
,
10230 lhs
->symtree
->n
.sym
->name
);
10232 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10234 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10236 if (rc
== ARITH_UNDERFLOW
)
10237 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10238 ". This check can be disabled with the option "
10239 "%<-fno-range-check%>", &rhs
->where
);
10240 else if (rc
== ARITH_OVERFLOW
)
10241 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10242 ". This check can be disabled with the option "
10243 "%<-fno-range-check%>", &rhs
->where
);
10244 else if (rc
== ARITH_NAN
)
10245 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10246 ". This check can be disabled with the option "
10247 "%<-fno-range-check%>", &rhs
->where
);
10252 if (lhs
->ts
.type
== BT_CHARACTER
10253 && warn_character_truncation
)
10255 HOST_WIDE_INT llen
= 0, rlen
= 0;
10256 if (lhs
->ts
.u
.cl
!= NULL
10257 && lhs
->ts
.u
.cl
->length
!= NULL
10258 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10259 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10261 if (rhs
->expr_type
== EXPR_CONSTANT
)
10262 rlen
= rhs
->value
.character
.length
;
10264 else if (rhs
->ts
.u
.cl
!= NULL
10265 && rhs
->ts
.u
.cl
->length
!= NULL
10266 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10267 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10269 if (rlen
&& llen
&& rlen
> llen
)
10270 gfc_warning_now (OPT_Wcharacter_truncation
,
10271 "CHARACTER expression will be truncated "
10272 "in assignment (%ld/%ld) at %L",
10273 (long) llen
, (long) rlen
, &code
->loc
);
10276 /* Ensure that a vector index expression for the lvalue is evaluated
10277 to a temporary if the lvalue symbol is referenced in it. */
10280 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10281 if (ref
->type
== REF_ARRAY
)
10283 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10284 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10285 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10286 ref
->u
.ar
.start
[n
]))
10288 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10292 if (gfc_pure (NULL
))
10294 if (lhs
->ts
.type
== BT_DERIVED
10295 && lhs
->expr_type
== EXPR_VARIABLE
10296 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10297 && rhs
->expr_type
== EXPR_VARIABLE
10298 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10299 || gfc_is_coindexed (rhs
)))
10301 /* F2008, C1283. */
10302 if (gfc_is_coindexed (rhs
))
10303 gfc_error ("Coindexed expression at %L is assigned to "
10304 "a derived type variable with a POINTER "
10305 "component in a PURE procedure",
10308 gfc_error ("The impure variable at %L is assigned to "
10309 "a derived type variable with a POINTER "
10310 "component in a PURE procedure (12.6)",
10315 /* Fortran 2008, C1283. */
10316 if (gfc_is_coindexed (lhs
))
10318 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10319 "procedure", &rhs
->where
);
10324 if (gfc_implicit_pure (NULL
))
10326 if (lhs
->expr_type
== EXPR_VARIABLE
10327 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10328 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10329 gfc_unset_implicit_pure (NULL
);
10331 if (lhs
->ts
.type
== BT_DERIVED
10332 && lhs
->expr_type
== EXPR_VARIABLE
10333 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10334 && rhs
->expr_type
== EXPR_VARIABLE
10335 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10336 || gfc_is_coindexed (rhs
)))
10337 gfc_unset_implicit_pure (NULL
);
10339 /* Fortran 2008, C1283. */
10340 if (gfc_is_coindexed (lhs
))
10341 gfc_unset_implicit_pure (NULL
);
10344 /* F2008, 7.2.1.2. */
10345 attr
= gfc_expr_attr (lhs
);
10346 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10348 if (attr
.codimension
)
10350 gfc_error ("Assignment to polymorphic coarray at %L is not "
10351 "permitted", &lhs
->where
);
10354 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10355 "polymorphic variable at %L", &lhs
->where
))
10357 if (!flag_realloc_lhs
)
10359 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10360 "requires %<-frealloc-lhs%>", &lhs
->where
);
10364 else if (lhs
->ts
.type
== BT_CLASS
)
10366 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10367 "assignment at %L - check that there is a matching specific "
10368 "subroutine for '=' operator", &lhs
->where
);
10372 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10374 /* F2008, Section 7.2.1.2. */
10375 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10377 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10378 "component in assignment at %L", &lhs
->where
);
10382 /* Assign the 'data' of a class object to a derived type. */
10383 if (lhs
->ts
.type
== BT_DERIVED
10384 && rhs
->ts
.type
== BT_CLASS
10385 && rhs
->expr_type
!= EXPR_ARRAY
)
10386 gfc_add_data_component (rhs
);
10388 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10390 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10391 && code
->expr2
->value
.function
.isym
10392 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10393 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10394 && !gfc_expr_attr (rhs
).allocatable
10395 && !gfc_has_vector_subscript (rhs
)));
10397 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10399 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10400 Additionally, insert this code when the RHS is a CAF as we then use the
10401 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10402 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10403 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10405 if (caf_convert_to_send
)
10407 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10408 && code
->expr2
->value
.function
.isym
10409 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10410 remove_caf_get_intrinsic (code
->expr2
);
10411 code
->op
= EXEC_CALL
;
10412 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10413 code
->resolved_sym
= code
->symtree
->n
.sym
;
10414 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10415 code
->resolved_sym
->attr
.intrinsic
= 1;
10416 code
->resolved_sym
->attr
.subroutine
= 1;
10417 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10418 gfc_commit_symbol (code
->resolved_sym
);
10419 code
->ext
.actual
= gfc_get_actual_arglist ();
10420 code
->ext
.actual
->expr
= lhs
;
10421 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10422 code
->ext
.actual
->next
->expr
= rhs
;
10423 code
->expr1
= NULL
;
10424 code
->expr2
= NULL
;
10431 /* Add a component reference onto an expression. */
10434 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10439 ref
= &((*ref
)->next
);
10440 *ref
= gfc_get_ref ();
10441 (*ref
)->type
= REF_COMPONENT
;
10442 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10443 (*ref
)->u
.c
.component
= c
;
10446 /* Add a full array ref, as necessary. */
10449 gfc_add_full_array_ref (e
, c
->as
);
10450 e
->rank
= c
->as
->rank
;
10455 /* Build an assignment. Keep the argument 'op' for future use, so that
10456 pointer assignments can be made. */
10459 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10460 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10462 gfc_code
*this_code
;
10464 this_code
= gfc_get_code (op
);
10465 this_code
->next
= NULL
;
10466 this_code
->expr1
= gfc_copy_expr (expr1
);
10467 this_code
->expr2
= gfc_copy_expr (expr2
);
10468 this_code
->loc
= loc
;
10469 if (comp1
&& comp2
)
10471 add_comp_ref (this_code
->expr1
, comp1
);
10472 add_comp_ref (this_code
->expr2
, comp2
);
10479 /* Makes a temporary variable expression based on the characteristics of
10480 a given variable expression. */
10483 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10485 static int serial
= 0;
10486 char name
[GFC_MAX_SYMBOL_LEN
];
10488 gfc_array_spec
*as
;
10489 gfc_array_ref
*aref
;
10492 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10493 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10494 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10500 /* Obtain the arrayspec for the temporary. */
10501 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10502 && e
->expr_type
!= EXPR_FUNCTION
10503 && e
->expr_type
!= EXPR_OP
)
10505 aref
= gfc_find_array_ref (e
);
10506 if (e
->expr_type
== EXPR_VARIABLE
10507 && e
->symtree
->n
.sym
->as
== aref
->as
)
10511 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10512 if (ref
->type
== REF_COMPONENT
10513 && ref
->u
.c
.component
->as
== aref
->as
)
10521 /* Add the attributes and the arrayspec to the temporary. */
10522 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10523 tmp
->n
.sym
->attr
.function
= 0;
10524 tmp
->n
.sym
->attr
.result
= 0;
10525 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10526 tmp
->n
.sym
->attr
.dummy
= 0;
10527 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10531 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10534 if (as
->type
== AS_DEFERRED
)
10535 tmp
->n
.sym
->attr
.allocatable
= 1;
10537 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10538 || e
->expr_type
== EXPR_FUNCTION
10539 || e
->expr_type
== EXPR_OP
))
10541 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10542 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10543 tmp
->n
.sym
->as
->rank
= e
->rank
;
10544 tmp
->n
.sym
->attr
.allocatable
= 1;
10545 tmp
->n
.sym
->attr
.dimension
= 1;
10548 tmp
->n
.sym
->attr
.dimension
= 0;
10550 gfc_set_sym_referenced (tmp
->n
.sym
);
10551 gfc_commit_symbol (tmp
->n
.sym
);
10552 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10554 /* Should the lhs be a section, use its array ref for the
10555 temporary expression. */
10556 if (aref
&& aref
->type
!= AR_FULL
)
10558 gfc_free_ref_list (e
->ref
);
10559 e
->ref
= gfc_copy_ref (ref
);
10565 /* Add one line of code to the code chain, making sure that 'head' and
10566 'tail' are appropriately updated. */
10569 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10571 gcc_assert (this_code
);
10573 *head
= *tail
= *this_code
;
10575 *tail
= gfc_append_code (*tail
, *this_code
);
10580 /* Counts the potential number of part array references that would
10581 result from resolution of typebound defined assignments. */
10584 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10587 int c_depth
= 0, t_depth
;
10589 for (c
= derived
->components
; c
; c
= c
->next
)
10591 if ((!gfc_bt_struct (c
->ts
.type
)
10593 || c
->attr
.allocatable
10594 || c
->attr
.proc_pointer_comp
10595 || c
->attr
.class_pointer
10596 || c
->attr
.proc_pointer
)
10597 && !c
->attr
.defined_assign_comp
)
10600 if (c
->as
&& c_depth
== 0)
10603 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10604 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10609 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10611 return depth
+ c_depth
;
10615 /* Implement 7.2.1.3 of the F08 standard:
10616 "An intrinsic assignment where the variable is of derived type is
10617 performed as if each component of the variable were assigned from the
10618 corresponding component of expr using pointer assignment (7.2.2) for
10619 each pointer component, defined assignment for each nonpointer
10620 nonallocatable component of a type that has a type-bound defined
10621 assignment consistent with the component, intrinsic assignment for
10622 each other nonpointer nonallocatable component, ..."
10624 The pointer assignments are taken care of by the intrinsic
10625 assignment of the structure itself. This function recursively adds
10626 defined assignments where required. The recursion is accomplished
10627 by calling gfc_resolve_code.
10629 When the lhs in a defined assignment has intent INOUT, we need a
10630 temporary for the lhs. In pseudo-code:
10632 ! Only call function lhs once.
10633 if (lhs is not a constant or an variable)
10636 ! Do the intrinsic assignment
10638 ! Now do the defined assignments
10639 do over components with typebound defined assignment [%cmp]
10640 #if one component's assignment procedure is INOUT
10642 #if expr2 non-variable
10648 t1%cmp {defined=} expr2%cmp
10654 expr1%cmp {defined=} expr2%cmp
10658 /* The temporary assignments have to be put on top of the additional
10659 code to avoid the result being changed by the intrinsic assignment.
10661 static int component_assignment_level
= 0;
10662 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10665 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10667 gfc_component
*comp1
, *comp2
;
10668 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10670 int error_count
, depth
;
10672 gfc_get_errors (NULL
, &error_count
);
10674 /* Filter out continuing processing after an error. */
10676 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10677 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10680 /* TODO: Handle more than one part array reference in assignments. */
10681 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10682 (*code
)->expr1
->rank
? 1 : 0);
10685 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10686 "done because multiple part array references would "
10687 "occur in intermediate expressions.", &(*code
)->loc
);
10691 component_assignment_level
++;
10693 /* Create a temporary so that functions get called only once. */
10694 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10695 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10697 gfc_expr
*tmp_expr
;
10699 /* Assign the rhs to the temporary. */
10700 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10701 this_code
= build_assignment (EXEC_ASSIGN
,
10702 tmp_expr
, (*code
)->expr2
,
10703 NULL
, NULL
, (*code
)->loc
);
10704 /* Add the code and substitute the rhs expression. */
10705 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10706 gfc_free_expr ((*code
)->expr2
);
10707 (*code
)->expr2
= tmp_expr
;
10710 /* Do the intrinsic assignment. This is not needed if the lhs is one
10711 of the temporaries generated here, since the intrinsic assignment
10712 to the final result already does this. */
10713 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10715 this_code
= build_assignment (EXEC_ASSIGN
,
10716 (*code
)->expr1
, (*code
)->expr2
,
10717 NULL
, NULL
, (*code
)->loc
);
10718 add_code_to_chain (&this_code
, &head
, &tail
);
10721 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10722 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10725 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10727 bool inout
= false;
10729 /* The intrinsic assignment does the right thing for pointers
10730 of all kinds and allocatable components. */
10731 if (!gfc_bt_struct (comp1
->ts
.type
)
10732 || comp1
->attr
.pointer
10733 || comp1
->attr
.allocatable
10734 || comp1
->attr
.proc_pointer_comp
10735 || comp1
->attr
.class_pointer
10736 || comp1
->attr
.proc_pointer
)
10739 /* Make an assigment for this component. */
10740 this_code
= build_assignment (EXEC_ASSIGN
,
10741 (*code
)->expr1
, (*code
)->expr2
,
10742 comp1
, comp2
, (*code
)->loc
);
10744 /* Convert the assignment if there is a defined assignment for
10745 this type. Otherwise, using the call from gfc_resolve_code,
10746 recurse into its components. */
10747 gfc_resolve_code (this_code
, ns
);
10749 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10751 gfc_formal_arglist
*dummy_args
;
10753 /* Check that there is a typebound defined assignment. If not,
10754 then this must be a module defined assignment. We cannot
10755 use the defined_assign_comp attribute here because it must
10756 be this derived type that has the defined assignment and not
10758 if (!(comp1
->ts
.u
.derived
->f2k_derived
10759 && comp1
->ts
.u
.derived
->f2k_derived
10760 ->tb_op
[INTRINSIC_ASSIGN
]))
10762 gfc_free_statements (this_code
);
10767 /* If the first argument of the subroutine has intent INOUT
10768 a temporary must be generated and used instead. */
10769 rsym
= this_code
->resolved_sym
;
10770 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10772 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10774 gfc_code
*temp_code
;
10777 /* Build the temporary required for the assignment and put
10778 it at the head of the generated code. */
10781 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10782 temp_code
= build_assignment (EXEC_ASSIGN
,
10783 t1
, (*code
)->expr1
,
10784 NULL
, NULL
, (*code
)->loc
);
10786 /* For allocatable LHS, check whether it is allocated. Note
10787 that allocatable components with defined assignment are
10788 not yet support. See PR 57696. */
10789 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10793 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10794 block
= gfc_get_code (EXEC_IF
);
10795 block
->block
= gfc_get_code (EXEC_IF
);
10796 block
->block
->expr1
10797 = gfc_build_intrinsic_call (ns
,
10798 GFC_ISYM_ALLOCATED
, "allocated",
10799 (*code
)->loc
, 1, e
);
10800 block
->block
->next
= temp_code
;
10803 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10806 /* Replace the first actual arg with the component of the
10808 gfc_free_expr (this_code
->ext
.actual
->expr
);
10809 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10810 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10812 /* If the LHS variable is allocatable and wasn't allocated and
10813 the temporary is allocatable, pointer assign the address of
10814 the freshly allocated LHS to the temporary. */
10815 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10816 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10821 cond
= gfc_get_expr ();
10822 cond
->ts
.type
= BT_LOGICAL
;
10823 cond
->ts
.kind
= gfc_default_logical_kind
;
10824 cond
->expr_type
= EXPR_OP
;
10825 cond
->where
= (*code
)->loc
;
10826 cond
->value
.op
.op
= INTRINSIC_NOT
;
10827 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10828 GFC_ISYM_ALLOCATED
, "allocated",
10829 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10830 block
= gfc_get_code (EXEC_IF
);
10831 block
->block
= gfc_get_code (EXEC_IF
);
10832 block
->block
->expr1
= cond
;
10833 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10834 t1
, (*code
)->expr1
,
10835 NULL
, NULL
, (*code
)->loc
);
10836 add_code_to_chain (&block
, &head
, &tail
);
10840 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10842 /* Don't add intrinsic assignments since they are already
10843 effected by the intrinsic assignment of the structure. */
10844 gfc_free_statements (this_code
);
10849 add_code_to_chain (&this_code
, &head
, &tail
);
10853 /* Transfer the value to the final result. */
10854 this_code
= build_assignment (EXEC_ASSIGN
,
10855 (*code
)->expr1
, t1
,
10856 comp1
, comp2
, (*code
)->loc
);
10857 add_code_to_chain (&this_code
, &head
, &tail
);
10861 /* Put the temporary assignments at the top of the generated code. */
10862 if (tmp_head
&& component_assignment_level
== 1)
10864 gfc_append_code (tmp_head
, head
);
10866 tmp_head
= tmp_tail
= NULL
;
10869 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10870 // not accidentally deallocated. Hence, nullify t1.
10871 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10872 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10878 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10879 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10880 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10881 block
= gfc_get_code (EXEC_IF
);
10882 block
->block
= gfc_get_code (EXEC_IF
);
10883 block
->block
->expr1
= cond
;
10884 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10885 t1
, gfc_get_null_expr (&(*code
)->loc
),
10886 NULL
, NULL
, (*code
)->loc
);
10887 gfc_append_code (tail
, block
);
10891 /* Now attach the remaining code chain to the input code. Step on
10892 to the end of the new code since resolution is complete. */
10893 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10894 tail
->next
= (*code
)->next
;
10895 /* Overwrite 'code' because this would place the intrinsic assignment
10896 before the temporary for the lhs is created. */
10897 gfc_free_expr ((*code
)->expr1
);
10898 gfc_free_expr ((*code
)->expr2
);
10904 component_assignment_level
--;
10908 /* F2008: Pointer function assignments are of the form:
10909 ptr_fcn (args) = expr
10910 This function breaks these assignments into two statements:
10911 temporary_pointer => ptr_fcn(args)
10912 temporary_pointer = expr */
10915 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10917 gfc_expr
*tmp_ptr_expr
;
10918 gfc_code
*this_code
;
10919 gfc_component
*comp
;
10922 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10925 /* Even if standard does not support this feature, continue to build
10926 the two statements to avoid upsetting frontend_passes.c. */
10927 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10928 "%L", &(*code
)->loc
);
10930 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10933 s
= comp
->ts
.interface
;
10935 s
= (*code
)->expr1
->symtree
->n
.sym
;
10937 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10939 gfc_error ("The function result on the lhs of the assignment at "
10940 "%L must have the pointer attribute.",
10941 &(*code
)->expr1
->where
);
10942 (*code
)->op
= EXEC_NOP
;
10946 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10948 /* get_temp_from_expression is set up for ordinary assignments. To that
10949 end, where array bounds are not known, arrays are made allocatable.
10950 Change the temporary to a pointer here. */
10951 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10952 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10953 tmp_ptr_expr
->where
= (*code
)->loc
;
10955 this_code
= build_assignment (EXEC_ASSIGN
,
10956 tmp_ptr_expr
, (*code
)->expr2
,
10957 NULL
, NULL
, (*code
)->loc
);
10958 this_code
->next
= (*code
)->next
;
10959 (*code
)->next
= this_code
;
10960 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10961 (*code
)->expr2
= (*code
)->expr1
;
10962 (*code
)->expr1
= tmp_ptr_expr
;
10968 /* Deferred character length assignments from an operator expression
10969 require a temporary because the character length of the lhs can
10970 change in the course of the assignment. */
10973 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10975 gfc_expr
*tmp_expr
;
10976 gfc_code
*this_code
;
10978 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10979 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10980 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10983 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10986 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10987 tmp_expr
->where
= (*code
)->loc
;
10989 /* A new charlen is required to ensure that the variable string
10990 length is different to that of the original lhs. */
10991 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10992 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10993 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10994 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10996 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10998 this_code
= build_assignment (EXEC_ASSIGN
,
11000 gfc_copy_expr (tmp_expr
),
11001 NULL
, NULL
, (*code
)->loc
);
11003 (*code
)->expr1
= tmp_expr
;
11005 this_code
->next
= (*code
)->next
;
11006 (*code
)->next
= this_code
;
11012 /* Given a block of code, recursively resolve everything pointed to by this
11016 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11018 int omp_workshare_save
;
11019 int forall_save
, do_concurrent_save
;
11023 frame
.prev
= cs_base
;
11027 find_reachable_labels (code
);
11029 for (; code
; code
= code
->next
)
11031 frame
.current
= code
;
11032 forall_save
= forall_flag
;
11033 do_concurrent_save
= gfc_do_concurrent_flag
;
11035 if (code
->op
== EXEC_FORALL
)
11038 gfc_resolve_forall (code
, ns
, forall_save
);
11041 else if (code
->block
)
11043 omp_workshare_save
= -1;
11046 case EXEC_OACC_PARALLEL_LOOP
:
11047 case EXEC_OACC_PARALLEL
:
11048 case EXEC_OACC_KERNELS_LOOP
:
11049 case EXEC_OACC_KERNELS
:
11050 case EXEC_OACC_DATA
:
11051 case EXEC_OACC_HOST_DATA
:
11052 case EXEC_OACC_LOOP
:
11053 gfc_resolve_oacc_blocks (code
, ns
);
11055 case EXEC_OMP_PARALLEL_WORKSHARE
:
11056 omp_workshare_save
= omp_workshare_flag
;
11057 omp_workshare_flag
= 1;
11058 gfc_resolve_omp_parallel_blocks (code
, ns
);
11060 case EXEC_OMP_PARALLEL
:
11061 case EXEC_OMP_PARALLEL_DO
:
11062 case EXEC_OMP_PARALLEL_DO_SIMD
:
11063 case EXEC_OMP_PARALLEL_SECTIONS
:
11064 case EXEC_OMP_TARGET_PARALLEL
:
11065 case EXEC_OMP_TARGET_PARALLEL_DO
:
11066 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11067 case EXEC_OMP_TARGET_TEAMS
:
11068 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11069 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11070 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11071 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11072 case EXEC_OMP_TASK
:
11073 case EXEC_OMP_TASKLOOP
:
11074 case EXEC_OMP_TASKLOOP_SIMD
:
11075 case EXEC_OMP_TEAMS
:
11076 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11077 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11078 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11079 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11080 omp_workshare_save
= omp_workshare_flag
;
11081 omp_workshare_flag
= 0;
11082 gfc_resolve_omp_parallel_blocks (code
, ns
);
11084 case EXEC_OMP_DISTRIBUTE
:
11085 case EXEC_OMP_DISTRIBUTE_SIMD
:
11087 case EXEC_OMP_DO_SIMD
:
11088 case EXEC_OMP_SIMD
:
11089 case EXEC_OMP_TARGET_SIMD
:
11090 gfc_resolve_omp_do_blocks (code
, ns
);
11092 case EXEC_SELECT_TYPE
:
11093 /* Blocks are handled in resolve_select_type because we have
11094 to transform the SELECT TYPE into ASSOCIATE first. */
11096 case EXEC_DO_CONCURRENT
:
11097 gfc_do_concurrent_flag
= 1;
11098 gfc_resolve_blocks (code
->block
, ns
);
11099 gfc_do_concurrent_flag
= 2;
11101 case EXEC_OMP_WORKSHARE
:
11102 omp_workshare_save
= omp_workshare_flag
;
11103 omp_workshare_flag
= 1;
11106 gfc_resolve_blocks (code
->block
, ns
);
11110 if (omp_workshare_save
!= -1)
11111 omp_workshare_flag
= omp_workshare_save
;
11115 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11116 t
= gfc_resolve_expr (code
->expr1
);
11117 forall_flag
= forall_save
;
11118 gfc_do_concurrent_flag
= do_concurrent_save
;
11120 if (!gfc_resolve_expr (code
->expr2
))
11123 if (code
->op
== EXEC_ALLOCATE
11124 && !gfc_resolve_expr (code
->expr3
))
11130 case EXEC_END_BLOCK
:
11131 case EXEC_END_NESTED_BLOCK
:
11135 case EXEC_ERROR_STOP
:
11137 case EXEC_CONTINUE
:
11139 case EXEC_ASSIGN_CALL
:
11142 case EXEC_CRITICAL
:
11143 resolve_critical (code
);
11146 case EXEC_SYNC_ALL
:
11147 case EXEC_SYNC_IMAGES
:
11148 case EXEC_SYNC_MEMORY
:
11149 resolve_sync (code
);
11154 case EXEC_EVENT_POST
:
11155 case EXEC_EVENT_WAIT
:
11156 resolve_lock_unlock_event (code
);
11159 case EXEC_FAIL_IMAGE
:
11160 case EXEC_FORM_TEAM
:
11161 case EXEC_CHANGE_TEAM
:
11162 case EXEC_END_TEAM
:
11163 case EXEC_SYNC_TEAM
:
11167 /* Keep track of which entry we are up to. */
11168 current_entry_id
= code
->ext
.entry
->id
;
11172 resolve_where (code
, NULL
);
11176 if (code
->expr1
!= NULL
)
11178 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11179 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11180 "INTEGER variable", &code
->expr1
->where
);
11181 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11182 gfc_error ("Variable %qs has not been assigned a target "
11183 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11184 &code
->expr1
->where
);
11187 resolve_branch (code
->label1
, code
);
11191 if (code
->expr1
!= NULL
11192 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11193 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11194 "INTEGER return specifier", &code
->expr1
->where
);
11197 case EXEC_INIT_ASSIGN
:
11198 case EXEC_END_PROCEDURE
:
11205 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11207 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11208 && code
->expr1
->value
.function
.isym
11209 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11210 remove_caf_get_intrinsic (code
->expr1
);
11212 /* If this is a pointer function in an lvalue variable context,
11213 the new code will have to be resolved afresh. This is also the
11214 case with an error, where the code is transformed into NOP to
11215 prevent ICEs downstream. */
11216 if (resolve_ptr_fcn_assign (&code
, ns
)
11217 || code
->op
== EXEC_NOP
)
11220 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11224 if (resolve_ordinary_assign (code
, ns
))
11226 if (code
->op
== EXEC_COMPCALL
)
11232 /* Check for dependencies in deferred character length array
11233 assignments and generate a temporary, if necessary. */
11234 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11237 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11238 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11239 && code
->expr1
->ts
.u
.derived
11240 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11241 generate_component_assignments (&code
, ns
);
11245 case EXEC_LABEL_ASSIGN
:
11246 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11247 gfc_error ("Label %d referenced at %L is never defined",
11248 code
->label1
->value
, &code
->label1
->where
);
11250 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11251 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11252 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11253 != gfc_default_integer_kind
11254 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11255 gfc_error ("ASSIGN statement at %L requires a scalar "
11256 "default INTEGER variable", &code
->expr1
->where
);
11259 case EXEC_POINTER_ASSIGN
:
11266 /* This is both a variable definition and pointer assignment
11267 context, so check both of them. For rank remapping, a final
11268 array ref may be present on the LHS and fool gfc_expr_attr
11269 used in gfc_check_vardef_context. Remove it. */
11270 e
= remove_last_array_ref (code
->expr1
);
11271 t
= gfc_check_vardef_context (e
, true, false, false,
11272 _("pointer assignment"));
11274 t
= gfc_check_vardef_context (e
, false, false, false,
11275 _("pointer assignment"));
11280 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
11282 /* Assigning a class object always is a regular assign. */
11283 if (code
->expr2
->ts
.type
== BT_CLASS
11284 && code
->expr1
->ts
.type
== BT_CLASS
11285 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11286 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11287 && code
->expr2
->expr_type
== EXPR_VARIABLE
11288 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11290 code
->op
= EXEC_ASSIGN
;
11294 case EXEC_ARITHMETIC_IF
:
11296 gfc_expr
*e
= code
->expr1
;
11298 gfc_resolve_expr (e
);
11299 if (e
->expr_type
== EXPR_NULL
)
11300 gfc_error ("Invalid NULL at %L", &e
->where
);
11302 if (t
&& (e
->rank
> 0
11303 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11304 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11305 "REAL or INTEGER expression", &e
->where
);
11307 resolve_branch (code
->label1
, code
);
11308 resolve_branch (code
->label2
, code
);
11309 resolve_branch (code
->label3
, code
);
11314 if (t
&& code
->expr1
!= NULL
11315 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11316 || code
->expr1
->rank
!= 0))
11317 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11318 &code
->expr1
->where
);
11323 resolve_call (code
);
11326 case EXEC_COMPCALL
:
11328 resolve_typebound_subroutine (code
);
11331 case EXEC_CALL_PPC
:
11332 resolve_ppc_call (code
);
11336 /* Select is complicated. Also, a SELECT construct could be
11337 a transformed computed GOTO. */
11338 resolve_select (code
, false);
11341 case EXEC_SELECT_TYPE
:
11342 resolve_select_type (code
, ns
);
11346 resolve_block_construct (code
);
11350 if (code
->ext
.iterator
!= NULL
)
11352 gfc_iterator
*iter
= code
->ext
.iterator
;
11353 if (gfc_resolve_iterator (iter
, true, false))
11354 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11359 case EXEC_DO_WHILE
:
11360 if (code
->expr1
== NULL
)
11361 gfc_internal_error ("gfc_resolve_code(): No expression on "
11364 && (code
->expr1
->rank
!= 0
11365 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11366 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11367 "a scalar LOGICAL expression", &code
->expr1
->where
);
11370 case EXEC_ALLOCATE
:
11372 resolve_allocate_deallocate (code
, "ALLOCATE");
11376 case EXEC_DEALLOCATE
:
11378 resolve_allocate_deallocate (code
, "DEALLOCATE");
11383 if (!gfc_resolve_open (code
->ext
.open
))
11386 resolve_branch (code
->ext
.open
->err
, code
);
11390 if (!gfc_resolve_close (code
->ext
.close
))
11393 resolve_branch (code
->ext
.close
->err
, code
);
11396 case EXEC_BACKSPACE
:
11400 if (!gfc_resolve_filepos (code
->ext
.filepos
))
11403 resolve_branch (code
->ext
.filepos
->err
, code
);
11407 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11410 resolve_branch (code
->ext
.inquire
->err
, code
);
11413 case EXEC_IOLENGTH
:
11414 gcc_assert (code
->ext
.inquire
!= NULL
);
11415 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11418 resolve_branch (code
->ext
.inquire
->err
, code
);
11422 if (!gfc_resolve_wait (code
->ext
.wait
))
11425 resolve_branch (code
->ext
.wait
->err
, code
);
11426 resolve_branch (code
->ext
.wait
->end
, code
);
11427 resolve_branch (code
->ext
.wait
->eor
, code
);
11432 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11435 resolve_branch (code
->ext
.dt
->err
, code
);
11436 resolve_branch (code
->ext
.dt
->end
, code
);
11437 resolve_branch (code
->ext
.dt
->eor
, code
);
11440 case EXEC_TRANSFER
:
11441 resolve_transfer (code
);
11444 case EXEC_DO_CONCURRENT
:
11446 resolve_forall_iterators (code
->ext
.forall_iterator
);
11448 if (code
->expr1
!= NULL
11449 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11450 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11451 "expression", &code
->expr1
->where
);
11454 case EXEC_OACC_PARALLEL_LOOP
:
11455 case EXEC_OACC_PARALLEL
:
11456 case EXEC_OACC_KERNELS_LOOP
:
11457 case EXEC_OACC_KERNELS
:
11458 case EXEC_OACC_DATA
:
11459 case EXEC_OACC_HOST_DATA
:
11460 case EXEC_OACC_LOOP
:
11461 case EXEC_OACC_UPDATE
:
11462 case EXEC_OACC_WAIT
:
11463 case EXEC_OACC_CACHE
:
11464 case EXEC_OACC_ENTER_DATA
:
11465 case EXEC_OACC_EXIT_DATA
:
11466 case EXEC_OACC_ATOMIC
:
11467 case EXEC_OACC_DECLARE
:
11468 gfc_resolve_oacc_directive (code
, ns
);
11471 case EXEC_OMP_ATOMIC
:
11472 case EXEC_OMP_BARRIER
:
11473 case EXEC_OMP_CANCEL
:
11474 case EXEC_OMP_CANCELLATION_POINT
:
11475 case EXEC_OMP_CRITICAL
:
11476 case EXEC_OMP_FLUSH
:
11477 case EXEC_OMP_DISTRIBUTE
:
11478 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11479 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11480 case EXEC_OMP_DISTRIBUTE_SIMD
:
11482 case EXEC_OMP_DO_SIMD
:
11483 case EXEC_OMP_MASTER
:
11484 case EXEC_OMP_ORDERED
:
11485 case EXEC_OMP_SECTIONS
:
11486 case EXEC_OMP_SIMD
:
11487 case EXEC_OMP_SINGLE
:
11488 case EXEC_OMP_TARGET
:
11489 case EXEC_OMP_TARGET_DATA
:
11490 case EXEC_OMP_TARGET_ENTER_DATA
:
11491 case EXEC_OMP_TARGET_EXIT_DATA
:
11492 case EXEC_OMP_TARGET_PARALLEL
:
11493 case EXEC_OMP_TARGET_PARALLEL_DO
:
11494 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11495 case EXEC_OMP_TARGET_SIMD
:
11496 case EXEC_OMP_TARGET_TEAMS
:
11497 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11498 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11499 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11500 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11501 case EXEC_OMP_TARGET_UPDATE
:
11502 case EXEC_OMP_TASK
:
11503 case EXEC_OMP_TASKGROUP
:
11504 case EXEC_OMP_TASKLOOP
:
11505 case EXEC_OMP_TASKLOOP_SIMD
:
11506 case EXEC_OMP_TASKWAIT
:
11507 case EXEC_OMP_TASKYIELD
:
11508 case EXEC_OMP_TEAMS
:
11509 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11510 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11511 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11512 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11513 case EXEC_OMP_WORKSHARE
:
11514 gfc_resolve_omp_directive (code
, ns
);
11517 case EXEC_OMP_PARALLEL
:
11518 case EXEC_OMP_PARALLEL_DO
:
11519 case EXEC_OMP_PARALLEL_DO_SIMD
:
11520 case EXEC_OMP_PARALLEL_SECTIONS
:
11521 case EXEC_OMP_PARALLEL_WORKSHARE
:
11522 omp_workshare_save
= omp_workshare_flag
;
11523 omp_workshare_flag
= 0;
11524 gfc_resolve_omp_directive (code
, ns
);
11525 omp_workshare_flag
= omp_workshare_save
;
11529 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11533 cs_base
= frame
.prev
;
11537 /* Resolve initial values and make sure they are compatible with
11541 resolve_values (gfc_symbol
*sym
)
11545 if (sym
->value
== NULL
)
11548 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11549 t
= resolve_structure_cons (sym
->value
, 1);
11551 t
= gfc_resolve_expr (sym
->value
);
11556 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11560 /* Verify any BIND(C) derived types in the namespace so we can report errors
11561 for them once, rather than for each variable declared of that type. */
11564 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11566 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11567 && derived_sym
->attr
.is_bind_c
== 1)
11568 verify_bind_c_derived_type (derived_sym
);
11574 /* Check the interfaces of DTIO procedures associated with derived
11575 type 'sym'. These procedures can either have typebound bindings or
11576 can appear in DTIO generic interfaces. */
11579 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11581 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11584 gfc_check_dtio_interfaces (sym
);
11589 /* Verify that any binding labels used in a given namespace do not collide
11590 with the names or binding labels of any global symbols. Multiple INTERFACE
11591 for the same procedure are permitted. */
11594 gfc_verify_binding_labels (gfc_symbol
*sym
)
11597 const char *module
;
11599 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11600 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11603 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11606 module
= sym
->module
;
11607 else if (sym
->ns
&& sym
->ns
->proc_name
11608 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11609 module
= sym
->ns
->proc_name
->name
;
11610 else if (sym
->ns
&& sym
->ns
->parent
11611 && sym
->ns
&& sym
->ns
->parent
->proc_name
11612 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11613 module
= sym
->ns
->parent
->proc_name
->name
;
11619 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11622 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11623 gsym
->where
= sym
->declared_at
;
11624 gsym
->sym_name
= sym
->name
;
11625 gsym
->binding_label
= sym
->binding_label
;
11626 gsym
->ns
= sym
->ns
;
11627 gsym
->mod_name
= module
;
11628 if (sym
->attr
.function
)
11629 gsym
->type
= GSYM_FUNCTION
;
11630 else if (sym
->attr
.subroutine
)
11631 gsym
->type
= GSYM_SUBROUTINE
;
11632 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11633 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11637 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11639 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11640 "identifier as entity at %L", sym
->name
,
11641 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11642 /* Clear the binding label to prevent checking multiple times. */
11643 sym
->binding_label
= NULL
;
11646 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11647 && (strcmp (module
, gsym
->mod_name
) != 0
11648 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11650 /* This can only happen if the variable is defined in a module - if it
11651 isn't the same module, reject it. */
11652 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11653 "uses the same global identifier as entity at %L from module %qs",
11654 sym
->name
, module
, sym
->binding_label
,
11655 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11656 sym
->binding_label
= NULL
;
11658 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11659 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11660 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11661 && sym
!= gsym
->ns
->proc_name
11662 && (module
!= gsym
->mod_name
11663 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11664 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11666 /* Print an error if the procedure is defined multiple times; we have to
11667 exclude references to the same procedure via module association or
11668 multiple checks for the same procedure. */
11669 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11670 "global identifier as entity at %L", sym
->name
,
11671 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11672 sym
->binding_label
= NULL
;
11677 /* Resolve an index expression. */
11680 resolve_index_expr (gfc_expr
*e
)
11682 if (!gfc_resolve_expr (e
))
11685 if (!gfc_simplify_expr (e
, 0))
11688 if (!gfc_specification_expr (e
))
11695 /* Resolve a charlen structure. */
11698 resolve_charlen (gfc_charlen
*cl
)
11701 bool saved_specification_expr
;
11707 saved_specification_expr
= specification_expr
;
11708 specification_expr
= true;
11710 if (cl
->length_from_typespec
)
11712 if (!gfc_resolve_expr (cl
->length
))
11714 specification_expr
= saved_specification_expr
;
11718 if (!gfc_simplify_expr (cl
->length
, 0))
11720 specification_expr
= saved_specification_expr
;
11724 /* cl->length has been resolved. It should have an integer type. */
11725 if (cl
->length
->ts
.type
!= BT_INTEGER
)
11727 gfc_error ("Scalar INTEGER expression expected at %L",
11728 &cl
->length
->where
);
11734 if (!resolve_index_expr (cl
->length
))
11736 specification_expr
= saved_specification_expr
;
11741 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11742 a negative value, the length of character entities declared is zero. */
11743 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11744 && mpz_sgn (cl
->length
->value
.integer
) < 0)
11745 gfc_replace_expr (cl
->length
,
11746 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
11748 /* Check that the character length is not too large. */
11749 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11750 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11751 && cl
->length
->ts
.type
== BT_INTEGER
11752 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11754 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11755 specification_expr
= saved_specification_expr
;
11759 specification_expr
= saved_specification_expr
;
11764 /* Test for non-constant shape arrays. */
11767 is_non_constant_shape_array (gfc_symbol
*sym
)
11773 not_constant
= false;
11774 if (sym
->as
!= NULL
)
11776 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11777 has not been simplified; parameter array references. Do the
11778 simplification now. */
11779 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11781 e
= sym
->as
->lower
[i
];
11782 if (e
&& (!resolve_index_expr(e
)
11783 || !gfc_is_constant_expr (e
)))
11784 not_constant
= true;
11785 e
= sym
->as
->upper
[i
];
11786 if (e
&& (!resolve_index_expr(e
)
11787 || !gfc_is_constant_expr (e
)))
11788 not_constant
= true;
11791 return not_constant
;
11794 /* Given a symbol and an initialization expression, add code to initialize
11795 the symbol to the function entry. */
11797 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11801 gfc_namespace
*ns
= sym
->ns
;
11803 /* Search for the function namespace if this is a contained
11804 function without an explicit result. */
11805 if (sym
->attr
.function
&& sym
== sym
->result
11806 && sym
->name
!= sym
->ns
->proc_name
->name
)
11808 ns
= ns
->contained
;
11809 for (;ns
; ns
= ns
->sibling
)
11810 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11816 gfc_free_expr (init
);
11820 /* Build an l-value expression for the result. */
11821 lval
= gfc_lval_expr_from_sym (sym
);
11823 /* Add the code at scope entry. */
11824 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11825 init_st
->next
= ns
->code
;
11826 ns
->code
= init_st
;
11828 /* Assign the default initializer to the l-value. */
11829 init_st
->loc
= sym
->declared_at
;
11830 init_st
->expr1
= lval
;
11831 init_st
->expr2
= init
;
11835 /* Whether or not we can generate a default initializer for a symbol. */
11838 can_generate_init (gfc_symbol
*sym
)
11840 symbol_attribute
*a
;
11845 /* These symbols should never have a default initialization. */
11850 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11851 && (CLASS_DATA (sym
)->attr
.class_pointer
11852 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11853 || a
->in_equivalence
11860 || (!a
->referenced
&& !a
->result
)
11861 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
11862 || (a
->function
&& sym
!= sym
->result
)
11867 /* Assign the default initializer to a derived type variable or result. */
11870 apply_default_init (gfc_symbol
*sym
)
11872 gfc_expr
*init
= NULL
;
11874 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11877 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11878 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11880 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11883 build_init_assign (sym
, init
);
11884 sym
->attr
.referenced
= 1;
11888 /* Build an initializer for a local. Returns null if the symbol should not have
11889 a default initialization. */
11892 build_default_init_expr (gfc_symbol
*sym
)
11894 /* These symbols should never have a default initialization. */
11895 if (sym
->attr
.allocatable
11896 || sym
->attr
.external
11898 || sym
->attr
.pointer
11899 || sym
->attr
.in_equivalence
11900 || sym
->attr
.in_common
11903 || sym
->attr
.cray_pointee
11904 || sym
->attr
.cray_pointer
11908 /* Get the appropriate init expression. */
11909 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
11912 /* Add an initialization expression to a local variable. */
11914 apply_default_init_local (gfc_symbol
*sym
)
11916 gfc_expr
*init
= NULL
;
11918 /* The symbol should be a variable or a function return value. */
11919 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11920 || (sym
->attr
.function
&& sym
->result
!= sym
))
11923 /* Try to build the initializer expression. If we can't initialize
11924 this symbol, then init will be NULL. */
11925 init
= build_default_init_expr (sym
);
11929 /* For saved variables, we don't want to add an initializer at function
11930 entry, so we just add a static initializer. Note that automatic variables
11931 are stack allocated even with -fno-automatic; we have also to exclude
11932 result variable, which are also nonstatic. */
11933 if (!sym
->attr
.automatic
11934 && (sym
->attr
.save
|| sym
->ns
->save_all
11935 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11936 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11937 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
11939 /* Don't clobber an existing initializer! */
11940 gcc_assert (sym
->value
== NULL
);
11945 build_init_assign (sym
, init
);
11949 /* Resolution of common features of flavors variable and procedure. */
11952 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11954 gfc_array_spec
*as
;
11956 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11957 as
= CLASS_DATA (sym
)->as
;
11961 /* Constraints on deferred shape variable. */
11962 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11964 bool pointer
, allocatable
, dimension
;
11966 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11968 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11969 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11970 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11974 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11975 allocatable
= sym
->attr
.allocatable
;
11976 dimension
= sym
->attr
.dimension
;
11981 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11983 gfc_error ("Allocatable array %qs at %L must have a deferred "
11984 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11987 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11988 "%qs at %L may not be ALLOCATABLE",
11989 sym
->name
, &sym
->declared_at
))
11993 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11995 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11996 "assumed rank", sym
->name
, &sym
->declared_at
);
12002 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12003 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12005 gfc_error ("Array %qs at %L cannot have a deferred shape",
12006 sym
->name
, &sym
->declared_at
);
12011 /* Constraints on polymorphic variables. */
12012 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12015 if (sym
->attr
.class_ok
12016 && !sym
->attr
.select_type_temporary
12017 && !UNLIMITED_POLY (sym
)
12018 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12020 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12021 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12022 &sym
->declared_at
);
12027 /* Assume that use associated symbols were checked in the module ns.
12028 Class-variables that are associate-names are also something special
12029 and excepted from the test. */
12030 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12032 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12033 "or pointer", sym
->name
, &sym
->declared_at
);
12042 /* Additional checks for symbols with flavor variable and derived
12043 type. To be called from resolve_fl_variable. */
12046 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12048 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12050 /* Check to see if a derived type is blocked from being host
12051 associated by the presence of another class I symbol in the same
12052 namespace. 14.6.1.3 of the standard and the discussion on
12053 comp.lang.fortran. */
12054 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12055 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12058 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12059 if (s
&& s
->attr
.generic
)
12060 s
= gfc_find_dt_in_generic (s
);
12061 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12063 gfc_error ("The type %qs cannot be host associated at %L "
12064 "because it is blocked by an incompatible object "
12065 "of the same name declared at %L",
12066 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12072 /* 4th constraint in section 11.3: "If an object of a type for which
12073 component-initialization is specified (R429) appears in the
12074 specification-part of a module and does not have the ALLOCATABLE
12075 or POINTER attribute, the object shall have the SAVE attribute."
12077 The check for initializers is performed with
12078 gfc_has_default_initializer because gfc_default_initializer generates
12079 a hidden default for allocatable components. */
12080 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12081 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12082 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12083 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12084 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12085 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12086 "%qs at %L, needed due to the default "
12087 "initialization", sym
->name
, &sym
->declared_at
))
12090 /* Assign default initializer. */
12091 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12092 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12093 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12099 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12100 except in the declaration of an entity or component that has the POINTER
12101 or ALLOCATABLE attribute. */
12104 deferred_requirements (gfc_symbol
*sym
)
12106 if (sym
->ts
.deferred
12107 && !(sym
->attr
.pointer
12108 || sym
->attr
.allocatable
12109 || sym
->attr
.associate_var
12110 || sym
->attr
.omp_udr_artificial_var
))
12112 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12113 "requires either the POINTER or ALLOCATABLE attribute",
12114 sym
->name
, &sym
->declared_at
);
12121 /* Resolve symbols with flavor variable. */
12124 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12126 int no_init_flag
, automatic_flag
;
12128 const char *auto_save_msg
;
12129 bool saved_specification_expr
;
12131 auto_save_msg
= "Automatic object %qs at %L cannot have the "
12134 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12137 /* Set this flag to check that variables are parameters of all entries.
12138 This check is effected by the call to gfc_resolve_expr through
12139 is_non_constant_shape_array. */
12140 saved_specification_expr
= specification_expr
;
12141 specification_expr
= true;
12143 if (sym
->ns
->proc_name
12144 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12145 || sym
->ns
->proc_name
->attr
.is_main_program
)
12146 && !sym
->attr
.use_assoc
12147 && !sym
->attr
.allocatable
12148 && !sym
->attr
.pointer
12149 && is_non_constant_shape_array (sym
))
12151 /* F08:C541. The shape of an array defined in a main program or module
12152 * needs to be constant. */
12153 gfc_error ("The module or main program array %qs at %L must "
12154 "have constant shape", sym
->name
, &sym
->declared_at
);
12155 specification_expr
= saved_specification_expr
;
12159 /* Constraints on deferred type parameter. */
12160 if (!deferred_requirements (sym
))
12163 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12165 /* Make sure that character string variables with assumed length are
12166 dummy arguments. */
12167 e
= sym
->ts
.u
.cl
->length
;
12168 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12169 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12170 && !sym
->attr
.omp_udr_artificial_var
)
12172 gfc_error ("Entity with assumed character length at %L must be a "
12173 "dummy argument or a PARAMETER", &sym
->declared_at
);
12174 specification_expr
= saved_specification_expr
;
12178 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12180 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12181 specification_expr
= saved_specification_expr
;
12185 if (!gfc_is_constant_expr (e
)
12186 && !(e
->expr_type
== EXPR_VARIABLE
12187 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12189 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12190 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12191 || sym
->ns
->proc_name
->attr
.is_main_program
))
12193 gfc_error ("%qs at %L must have constant character length "
12194 "in this context", sym
->name
, &sym
->declared_at
);
12195 specification_expr
= saved_specification_expr
;
12198 if (sym
->attr
.in_common
)
12200 gfc_error ("COMMON variable %qs at %L must have constant "
12201 "character length", sym
->name
, &sym
->declared_at
);
12202 specification_expr
= saved_specification_expr
;
12208 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12209 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12211 /* Determine if the symbol may not have an initializer. */
12212 no_init_flag
= automatic_flag
= 0;
12213 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12214 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12216 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12217 && is_non_constant_shape_array (sym
))
12219 no_init_flag
= automatic_flag
= 1;
12221 /* Also, they must not have the SAVE attribute.
12222 SAVE_IMPLICIT is checked below. */
12223 if (sym
->as
&& sym
->attr
.codimension
)
12225 int corank
= sym
->as
->corank
;
12226 sym
->as
->corank
= 0;
12227 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12228 sym
->as
->corank
= corank
;
12230 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12232 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12233 specification_expr
= saved_specification_expr
;
12238 /* Ensure that any initializer is simplified. */
12240 gfc_simplify_expr (sym
->value
, 1);
12242 /* Reject illegal initializers. */
12243 if (!sym
->mark
&& sym
->value
)
12245 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12246 && CLASS_DATA (sym
)->attr
.allocatable
))
12247 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12248 sym
->name
, &sym
->declared_at
);
12249 else if (sym
->attr
.external
)
12250 gfc_error ("External %qs at %L cannot have an initializer",
12251 sym
->name
, &sym
->declared_at
);
12252 else if (sym
->attr
.dummy
12253 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12254 gfc_error ("Dummy %qs at %L cannot have an initializer",
12255 sym
->name
, &sym
->declared_at
);
12256 else if (sym
->attr
.intrinsic
)
12257 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12258 sym
->name
, &sym
->declared_at
);
12259 else if (sym
->attr
.result
)
12260 gfc_error ("Function result %qs at %L cannot have an initializer",
12261 sym
->name
, &sym
->declared_at
);
12262 else if (automatic_flag
)
12263 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12264 sym
->name
, &sym
->declared_at
);
12266 goto no_init_error
;
12267 specification_expr
= saved_specification_expr
;
12272 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12274 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12275 specification_expr
= saved_specification_expr
;
12279 specification_expr
= saved_specification_expr
;
12284 /* Compare the dummy characteristics of a module procedure interface
12285 declaration with the corresponding declaration in a submodule. */
12286 static gfc_formal_arglist
*new_formal
;
12287 static char errmsg
[200];
12290 compare_fsyms (gfc_symbol
*sym
)
12294 if (sym
== NULL
|| new_formal
== NULL
)
12297 fsym
= new_formal
->sym
;
12302 if (strcmp (sym
->name
, fsym
->name
) == 0)
12304 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12305 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12310 /* Resolve a procedure. */
12313 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12315 gfc_formal_arglist
*arg
;
12317 if (sym
->attr
.function
12318 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12321 if (sym
->ts
.type
== BT_CHARACTER
)
12323 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12325 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12326 && !resolve_charlen (cl
))
12329 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12330 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12332 gfc_error ("Character-valued statement function %qs at %L must "
12333 "have constant length", sym
->name
, &sym
->declared_at
);
12338 /* Ensure that derived type for are not of a private type. Internal
12339 module procedures are excluded by 2.2.3.3 - i.e., they are not
12340 externally accessible and can access all the objects accessible in
12342 if (!(sym
->ns
->parent
12343 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12344 && gfc_check_symbol_access (sym
))
12346 gfc_interface
*iface
;
12348 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12351 && arg
->sym
->ts
.type
== BT_DERIVED
12352 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12353 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12354 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12355 "and cannot be a dummy argument"
12356 " of %qs, which is PUBLIC at %L",
12357 arg
->sym
->name
, sym
->name
,
12358 &sym
->declared_at
))
12360 /* Stop this message from recurring. */
12361 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12366 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12367 PRIVATE to the containing module. */
12368 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12370 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12373 && arg
->sym
->ts
.type
== BT_DERIVED
12374 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12375 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12376 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12377 "PUBLIC interface %qs at %L "
12378 "takes dummy arguments of %qs which "
12379 "is PRIVATE", iface
->sym
->name
,
12380 sym
->name
, &iface
->sym
->declared_at
,
12381 gfc_typename(&arg
->sym
->ts
)))
12383 /* Stop this message from recurring. */
12384 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12391 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12392 && !sym
->attr
.proc_pointer
)
12394 gfc_error ("Function %qs at %L cannot have an initializer",
12395 sym
->name
, &sym
->declared_at
);
12399 /* An external symbol may not have an initializer because it is taken to be
12400 a procedure. Exception: Procedure Pointers. */
12401 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12403 gfc_error ("External object %qs at %L may not have an initializer",
12404 sym
->name
, &sym
->declared_at
);
12408 /* An elemental function is required to return a scalar 12.7.1 */
12409 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
12411 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12412 "result", sym
->name
, &sym
->declared_at
);
12413 /* Reset so that the error only occurs once. */
12414 sym
->attr
.elemental
= 0;
12418 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12419 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12421 gfc_error ("Statement function %qs at %L may not have pointer or "
12422 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12426 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12427 char-len-param shall not be array-valued, pointer-valued, recursive
12428 or pure. ....snip... A character value of * may only be used in the
12429 following ways: (i) Dummy arg of procedure - dummy associates with
12430 actual length; (ii) To declare a named constant; or (iii) External
12431 function - but length must be declared in calling scoping unit. */
12432 if (sym
->attr
.function
12433 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12434 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12436 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12437 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12439 if (sym
->as
&& sym
->as
->rank
)
12440 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12441 "array-valued", sym
->name
, &sym
->declared_at
);
12443 if (sym
->attr
.pointer
)
12444 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12445 "pointer-valued", sym
->name
, &sym
->declared_at
);
12447 if (sym
->attr
.pure
)
12448 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12449 "pure", sym
->name
, &sym
->declared_at
);
12451 if (sym
->attr
.recursive
)
12452 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12453 "recursive", sym
->name
, &sym
->declared_at
);
12458 /* Appendix B.2 of the standard. Contained functions give an
12459 error anyway. Deferred character length is an F2003 feature.
12460 Don't warn on intrinsic conversion functions, which start
12461 with two underscores. */
12462 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12463 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12464 gfc_notify_std (GFC_STD_F95_OBS
,
12465 "CHARACTER(*) function %qs at %L",
12466 sym
->name
, &sym
->declared_at
);
12469 /* F2008, C1218. */
12470 if (sym
->attr
.elemental
)
12472 if (sym
->attr
.proc_pointer
)
12474 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12475 sym
->name
, &sym
->declared_at
);
12478 if (sym
->attr
.dummy
)
12480 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12481 sym
->name
, &sym
->declared_at
);
12486 /* F2018, C15100: "The result of an elemental function shall be scalar,
12487 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12488 pointer is tested and caught elsewhere. */
12489 if (sym
->attr
.elemental
&& sym
->result
12490 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12492 gfc_error ("Function result variable %qs at %L of elemental "
12493 "function %qs shall not have an ALLOCATABLE or POINTER "
12494 "attribute", sym
->result
->name
,
12495 &sym
->result
->declared_at
, sym
->name
);
12499 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12501 gfc_formal_arglist
*curr_arg
;
12502 int has_non_interop_arg
= 0;
12504 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12505 sym
->common_block
))
12507 /* Clear these to prevent looking at them again if there was an
12509 sym
->attr
.is_bind_c
= 0;
12510 sym
->attr
.is_c_interop
= 0;
12511 sym
->ts
.is_c_interop
= 0;
12515 /* So far, no errors have been found. */
12516 sym
->attr
.is_c_interop
= 1;
12517 sym
->ts
.is_c_interop
= 1;
12520 curr_arg
= gfc_sym_get_dummy_args (sym
);
12521 while (curr_arg
!= NULL
)
12523 /* Skip implicitly typed dummy args here. */
12524 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12525 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12526 /* If something is found to fail, record the fact so we
12527 can mark the symbol for the procedure as not being
12528 BIND(C) to try and prevent multiple errors being
12530 has_non_interop_arg
= 1;
12532 curr_arg
= curr_arg
->next
;
12535 /* See if any of the arguments were not interoperable and if so, clear
12536 the procedure symbol to prevent duplicate error messages. */
12537 if (has_non_interop_arg
!= 0)
12539 sym
->attr
.is_c_interop
= 0;
12540 sym
->ts
.is_c_interop
= 0;
12541 sym
->attr
.is_bind_c
= 0;
12545 if (!sym
->attr
.proc_pointer
)
12547 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12549 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12550 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12553 if (sym
->attr
.intent
)
12555 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12556 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12559 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12561 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12562 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12565 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12566 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12567 || sym
->attr
.contained
))
12569 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12570 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12573 if (strcmp ("ppr@", sym
->name
) == 0)
12575 gfc_error ("Procedure pointer result %qs at %L "
12576 "is missing the pointer attribute",
12577 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12582 /* Assume that a procedure whose body is not known has references
12583 to external arrays. */
12584 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12585 sym
->attr
.array_outer_dependency
= 1;
12587 /* Compare the characteristics of a module procedure with the
12588 interface declaration. Ideally this would be done with
12589 gfc_compare_interfaces but, at present, the formal interface
12590 cannot be copied to the ts.interface. */
12591 if (sym
->attr
.module_procedure
12592 && sym
->attr
.if_source
== IFSRC_DECL
)
12595 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12597 char *submodule_name
;
12598 strcpy (name
, sym
->ns
->proc_name
->name
);
12599 module_name
= strtok (name
, ".");
12600 submodule_name
= strtok (NULL
, ".");
12602 iface
= sym
->tlink
;
12605 /* Make sure that the result uses the correct charlen for deferred
12607 if (iface
&& sym
->result
12608 && iface
->ts
.type
== BT_CHARACTER
12609 && iface
->ts
.deferred
)
12610 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12615 /* Check the procedure characteristics. */
12616 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12618 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12619 "PROCEDURE at %L and its interface in %s",
12620 &sym
->declared_at
, module_name
);
12624 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12626 gfc_error ("Mismatch in PURE attribute between MODULE "
12627 "PROCEDURE at %L and its interface in %s",
12628 &sym
->declared_at
, module_name
);
12632 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12634 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12635 "PROCEDURE at %L and its interface in %s",
12636 &sym
->declared_at
, module_name
);
12640 /* Check the result characteristics. */
12641 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12643 gfc_error ("%s between the MODULE PROCEDURE declaration "
12644 "in MODULE %qs and the declaration at %L in "
12646 errmsg
, module_name
, &sym
->declared_at
,
12647 submodule_name
? submodule_name
: module_name
);
12652 /* Check the characteristics of the formal arguments. */
12653 if (sym
->formal
&& sym
->formal_ns
)
12655 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12658 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12666 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12667 been defined and we now know their defined arguments, check that they fulfill
12668 the requirements of the standard for procedures used as finalizers. */
12671 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12673 gfc_finalizer
* list
;
12674 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12675 bool result
= true;
12676 bool seen_scalar
= false;
12679 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12682 gfc_resolve_finalizers (parent
, finalizable
);
12684 /* Ensure that derived-type components have a their finalizers resolved. */
12685 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12686 for (c
= derived
->components
; c
; c
= c
->next
)
12687 if (c
->ts
.type
== BT_DERIVED
12688 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12690 bool has_final2
= false;
12691 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12692 return false; /* Error. */
12693 has_final
= has_final
|| has_final2
;
12695 /* Return early if not finalizable. */
12699 *finalizable
= false;
12703 /* Walk over the list of finalizer-procedures, check them, and if any one
12704 does not fit in with the standard's definition, print an error and remove
12705 it from the list. */
12706 prev_link
= &derived
->f2k_derived
->finalizers
;
12707 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12709 gfc_formal_arglist
*dummy_args
;
12714 /* Skip this finalizer if we already resolved it. */
12715 if (list
->proc_tree
)
12717 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12718 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
12719 seen_scalar
= true;
12720 prev_link
= &(list
->next
);
12724 /* Check this exists and is a SUBROUTINE. */
12725 if (!list
->proc_sym
->attr
.subroutine
)
12727 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12728 list
->proc_sym
->name
, &list
->where
);
12732 /* We should have exactly one argument. */
12733 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12734 if (!dummy_args
|| dummy_args
->next
)
12736 gfc_error ("FINAL procedure at %L must have exactly one argument",
12740 arg
= dummy_args
->sym
;
12742 /* This argument must be of our type. */
12743 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12745 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12746 &arg
->declared_at
, derived
->name
);
12750 /* It must neither be a pointer nor allocatable nor optional. */
12751 if (arg
->attr
.pointer
)
12753 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12754 &arg
->declared_at
);
12757 if (arg
->attr
.allocatable
)
12759 gfc_error ("Argument of FINAL procedure at %L must not be"
12760 " ALLOCATABLE", &arg
->declared_at
);
12763 if (arg
->attr
.optional
)
12765 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12766 &arg
->declared_at
);
12770 /* It must not be INTENT(OUT). */
12771 if (arg
->attr
.intent
== INTENT_OUT
)
12773 gfc_error ("Argument of FINAL procedure at %L must not be"
12774 " INTENT(OUT)", &arg
->declared_at
);
12778 /* Warn if the procedure is non-scalar and not assumed shape. */
12779 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12780 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12781 gfc_warning (OPT_Wsurprising
,
12782 "Non-scalar FINAL procedure at %L should have assumed"
12783 " shape argument", &arg
->declared_at
);
12785 /* Check that it does not match in kind and rank with a FINAL procedure
12786 defined earlier. To really loop over the *earlier* declarations,
12787 we need to walk the tail of the list as new ones were pushed at the
12789 /* TODO: Handle kind parameters once they are implemented. */
12790 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12791 for (i
= list
->next
; i
; i
= i
->next
)
12793 gfc_formal_arglist
*dummy_args
;
12795 /* Argument list might be empty; that is an error signalled earlier,
12796 but we nevertheless continued resolving. */
12797 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12800 gfc_symbol
* i_arg
= dummy_args
->sym
;
12801 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12802 if (i_rank
== my_rank
)
12804 gfc_error ("FINAL procedure %qs declared at %L has the same"
12805 " rank (%d) as %qs",
12806 list
->proc_sym
->name
, &list
->where
, my_rank
,
12807 i
->proc_sym
->name
);
12813 /* Is this the/a scalar finalizer procedure? */
12815 seen_scalar
= true;
12817 /* Find the symtree for this procedure. */
12818 gcc_assert (!list
->proc_tree
);
12819 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12821 prev_link
= &list
->next
;
12824 /* Remove wrong nodes immediately from the list so we don't risk any
12825 troubles in the future when they might fail later expectations. */
12828 *prev_link
= list
->next
;
12829 gfc_free_finalizer (i
);
12833 if (result
== false)
12836 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12837 were nodes in the list, must have been for arrays. It is surely a good
12838 idea to have a scalar version there if there's something to finalize. */
12839 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
12840 gfc_warning (OPT_Wsurprising
,
12841 "Only array FINAL procedures declared for derived type %qs"
12842 " defined at %L, suggest also scalar one",
12843 derived
->name
, &derived
->declared_at
);
12845 vtab
= gfc_find_derived_vtab (derived
);
12846 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12847 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12850 *finalizable
= true;
12856 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12859 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12860 const char* generic_name
, locus where
)
12862 gfc_symbol
*sym1
, *sym2
;
12863 const char *pass1
, *pass2
;
12864 gfc_formal_arglist
*dummy_args
;
12866 gcc_assert (t1
->specific
&& t2
->specific
);
12867 gcc_assert (!t1
->specific
->is_generic
);
12868 gcc_assert (!t2
->specific
->is_generic
);
12869 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12871 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12872 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12877 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12878 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12879 || sym1
->attr
.function
!= sym2
->attr
.function
)
12881 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12882 " GENERIC %qs at %L",
12883 sym1
->name
, sym2
->name
, generic_name
, &where
);
12887 /* Determine PASS arguments. */
12888 if (t1
->specific
->nopass
)
12890 else if (t1
->specific
->pass_arg
)
12891 pass1
= t1
->specific
->pass_arg
;
12894 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12896 pass1
= dummy_args
->sym
->name
;
12900 if (t2
->specific
->nopass
)
12902 else if (t2
->specific
->pass_arg
)
12903 pass2
= t2
->specific
->pass_arg
;
12906 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12908 pass2
= dummy_args
->sym
->name
;
12913 /* Compare the interfaces. */
12914 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12915 NULL
, 0, pass1
, pass2
))
12917 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12918 sym1
->name
, sym2
->name
, generic_name
, &where
);
12926 /* Worker function for resolving a generic procedure binding; this is used to
12927 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12929 The difference between those cases is finding possible inherited bindings
12930 that are overridden, as one has to look for them in tb_sym_root,
12931 tb_uop_root or tb_op, respectively. Thus the caller must already find
12932 the super-type and set p->overridden correctly. */
12935 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12936 gfc_typebound_proc
* p
, const char* name
)
12938 gfc_tbp_generic
* target
;
12939 gfc_symtree
* first_target
;
12940 gfc_symtree
* inherited
;
12942 gcc_assert (p
&& p
->is_generic
);
12944 /* Try to find the specific bindings for the symtrees in our target-list. */
12945 gcc_assert (p
->u
.generic
);
12946 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12947 if (!target
->specific
)
12949 gfc_typebound_proc
* overridden_tbp
;
12950 gfc_tbp_generic
* g
;
12951 const char* target_name
;
12953 target_name
= target
->specific_st
->name
;
12955 /* Defined for this type directly. */
12956 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12958 target
->specific
= target
->specific_st
->n
.tb
;
12959 goto specific_found
;
12962 /* Look for an inherited specific binding. */
12965 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12970 gcc_assert (inherited
->n
.tb
);
12971 target
->specific
= inherited
->n
.tb
;
12972 goto specific_found
;
12976 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12977 " at %L", target_name
, name
, &p
->where
);
12980 /* Once we've found the specific binding, check it is not ambiguous with
12981 other specifics already found or inherited for the same GENERIC. */
12983 gcc_assert (target
->specific
);
12985 /* This must really be a specific binding! */
12986 if (target
->specific
->is_generic
)
12988 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12989 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12993 /* Check those already resolved on this type directly. */
12994 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12995 if (g
!= target
&& g
->specific
12996 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12999 /* Check for ambiguity with inherited specific targets. */
13000 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13001 overridden_tbp
= overridden_tbp
->overridden
)
13002 if (overridden_tbp
->is_generic
)
13004 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13006 gcc_assert (g
->specific
);
13007 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13013 /* If we attempt to "overwrite" a specific binding, this is an error. */
13014 if (p
->overridden
&& !p
->overridden
->is_generic
)
13016 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
13017 " the same name", name
, &p
->where
);
13021 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13022 all must have the same attributes here. */
13023 first_target
= p
->u
.generic
->specific
->u
.specific
;
13024 gcc_assert (first_target
);
13025 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13026 p
->function
= first_target
->n
.sym
->attr
.function
;
13032 /* Resolve a GENERIC procedure binding for a derived type. */
13035 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13037 gfc_symbol
* super_type
;
13039 /* Find the overridden binding if any. */
13040 st
->n
.tb
->overridden
= NULL
;
13041 super_type
= gfc_get_derived_super_type (derived
);
13044 gfc_symtree
* overridden
;
13045 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13048 if (overridden
&& overridden
->n
.tb
)
13049 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13052 /* Resolve using worker function. */
13053 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13057 /* Retrieve the target-procedure of an operator binding and do some checks in
13058 common for intrinsic and user-defined type-bound operators. */
13061 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13063 gfc_symbol
* target_proc
;
13065 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13066 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13067 gcc_assert (target_proc
);
13069 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13070 if (target
->specific
->nopass
)
13072 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
13076 return target_proc
;
13080 /* Resolve a type-bound intrinsic operator. */
13083 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13084 gfc_typebound_proc
* p
)
13086 gfc_symbol
* super_type
;
13087 gfc_tbp_generic
* target
;
13089 /* If there's already an error here, do nothing (but don't fail again). */
13093 /* Operators should always be GENERIC bindings. */
13094 gcc_assert (p
->is_generic
);
13096 /* Look for an overridden binding. */
13097 super_type
= gfc_get_derived_super_type (derived
);
13098 if (super_type
&& super_type
->f2k_derived
)
13099 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13102 p
->overridden
= NULL
;
13104 /* Resolve general GENERIC properties using worker function. */
13105 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13108 /* Check the targets to be procedures of correct interface. */
13109 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13111 gfc_symbol
* target_proc
;
13113 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13117 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13120 /* Add target to non-typebound operator list. */
13121 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13122 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13124 gfc_interface
*head
, *intr
;
13126 /* Preempt 'gfc_check_new_interface' for submodules, where the
13127 mechanism for handling module procedures winds up resolving
13128 operator interfaces twice and would otherwise cause an error. */
13129 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13130 if (intr
->sym
== target_proc
13131 && target_proc
->attr
.used_in_submodule
)
13134 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13135 target_proc
, p
->where
))
13137 head
= derived
->ns
->op
[op
];
13138 intr
= gfc_get_interface ();
13139 intr
->sym
= target_proc
;
13140 intr
->where
= p
->where
;
13142 derived
->ns
->op
[op
] = intr
;
13154 /* Resolve a type-bound user operator (tree-walker callback). */
13156 static gfc_symbol
* resolve_bindings_derived
;
13157 static bool resolve_bindings_result
;
13159 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13162 resolve_typebound_user_op (gfc_symtree
* stree
)
13164 gfc_symbol
* super_type
;
13165 gfc_tbp_generic
* target
;
13167 gcc_assert (stree
&& stree
->n
.tb
);
13169 if (stree
->n
.tb
->error
)
13172 /* Operators should always be GENERIC bindings. */
13173 gcc_assert (stree
->n
.tb
->is_generic
);
13175 /* Find overridden procedure, if any. */
13176 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13177 if (super_type
&& super_type
->f2k_derived
)
13179 gfc_symtree
* overridden
;
13180 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13181 stree
->name
, true, NULL
);
13183 if (overridden
&& overridden
->n
.tb
)
13184 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13187 stree
->n
.tb
->overridden
= NULL
;
13189 /* Resolve basically using worker function. */
13190 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13193 /* Check the targets to be functions of correct interface. */
13194 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13196 gfc_symbol
* target_proc
;
13198 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13202 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13209 resolve_bindings_result
= false;
13210 stree
->n
.tb
->error
= 1;
13214 /* Resolve the type-bound procedures for a derived type. */
13217 resolve_typebound_procedure (gfc_symtree
* stree
)
13221 gfc_symbol
* me_arg
;
13222 gfc_symbol
* super_type
;
13223 gfc_component
* comp
;
13225 gcc_assert (stree
);
13227 /* Undefined specific symbol from GENERIC target definition. */
13231 if (stree
->n
.tb
->error
)
13234 /* If this is a GENERIC binding, use that routine. */
13235 if (stree
->n
.tb
->is_generic
)
13237 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13242 /* Get the target-procedure to check it. */
13243 gcc_assert (!stree
->n
.tb
->is_generic
);
13244 gcc_assert (stree
->n
.tb
->u
.specific
);
13245 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13246 where
= stree
->n
.tb
->where
;
13248 /* Default access should already be resolved from the parser. */
13249 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13251 if (stree
->n
.tb
->deferred
)
13253 if (!check_proc_interface (proc
, &where
))
13258 /* Check for F08:C465. */
13259 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13260 || (proc
->attr
.proc
!= PROC_MODULE
13261 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13262 || proc
->attr
.abstract
)
13264 gfc_error ("%qs must be a module procedure or an external procedure with"
13265 " an explicit interface at %L", proc
->name
, &where
);
13270 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13271 stree
->n
.tb
->function
= proc
->attr
.function
;
13273 /* Find the super-type of the current derived type. We could do this once and
13274 store in a global if speed is needed, but as long as not I believe this is
13275 more readable and clearer. */
13276 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13278 /* If PASS, resolve and check arguments if not already resolved / loaded
13279 from a .mod file. */
13280 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13282 gfc_formal_arglist
*dummy_args
;
13284 dummy_args
= gfc_sym_get_dummy_args (proc
);
13285 if (stree
->n
.tb
->pass_arg
)
13287 gfc_formal_arglist
*i
;
13289 /* If an explicit passing argument name is given, walk the arg-list
13290 and look for it. */
13293 stree
->n
.tb
->pass_arg_num
= 1;
13294 for (i
= dummy_args
; i
; i
= i
->next
)
13296 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13301 ++stree
->n
.tb
->pass_arg_num
;
13306 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13308 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13309 stree
->n
.tb
->pass_arg
);
13315 /* Otherwise, take the first one; there should in fact be at least
13317 stree
->n
.tb
->pass_arg_num
= 1;
13320 gfc_error ("Procedure %qs with PASS at %L must have at"
13321 " least one argument", proc
->name
, &where
);
13324 me_arg
= dummy_args
->sym
;
13327 /* Now check that the argument-type matches and the passed-object
13328 dummy argument is generally fine. */
13330 gcc_assert (me_arg
);
13332 if (me_arg
->ts
.type
!= BT_CLASS
)
13334 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13335 " at %L", proc
->name
, &where
);
13339 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13340 != resolve_bindings_derived
)
13342 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13343 " the derived-type %qs", me_arg
->name
, proc
->name
,
13344 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13348 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13349 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13351 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13352 " scalar", proc
->name
, &where
);
13355 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13357 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13358 " be ALLOCATABLE", proc
->name
, &where
);
13361 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13363 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13364 " be POINTER", proc
->name
, &where
);
13369 /* If we are extending some type, check that we don't override a procedure
13370 flagged NON_OVERRIDABLE. */
13371 stree
->n
.tb
->overridden
= NULL
;
13374 gfc_symtree
* overridden
;
13375 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13376 stree
->name
, true, NULL
);
13380 if (overridden
->n
.tb
)
13381 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13383 if (!gfc_check_typebound_override (stree
, overridden
))
13388 /* See if there's a name collision with a component directly in this type. */
13389 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13390 if (!strcmp (comp
->name
, stree
->name
))
13392 gfc_error ("Procedure %qs at %L has the same name as a component of"
13394 stree
->name
, &where
, resolve_bindings_derived
->name
);
13398 /* Try to find a name collision with an inherited component. */
13399 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13402 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13403 " component of %qs",
13404 stree
->name
, &where
, resolve_bindings_derived
->name
);
13408 stree
->n
.tb
->error
= 0;
13412 resolve_bindings_result
= false;
13413 stree
->n
.tb
->error
= 1;
13418 resolve_typebound_procedures (gfc_symbol
* derived
)
13421 gfc_symbol
* super_type
;
13423 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13426 super_type
= gfc_get_derived_super_type (derived
);
13428 resolve_symbol (super_type
);
13430 resolve_bindings_derived
= derived
;
13431 resolve_bindings_result
= true;
13433 if (derived
->f2k_derived
->tb_sym_root
)
13434 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13435 &resolve_typebound_procedure
);
13437 if (derived
->f2k_derived
->tb_uop_root
)
13438 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13439 &resolve_typebound_user_op
);
13441 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13443 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13444 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13445 (gfc_intrinsic_op
)op
, p
))
13446 resolve_bindings_result
= false;
13449 return resolve_bindings_result
;
13453 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13454 to give all identical derived types the same backend_decl. */
13456 add_dt_to_dt_list (gfc_symbol
*derived
)
13458 gfc_dt_list
*dt_list
;
13460 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
13461 if (derived
== dt_list
->derived
)
13464 dt_list
= gfc_get_dt_list ();
13465 dt_list
->next
= gfc_derived_types
;
13466 dt_list
->derived
= derived
;
13467 gfc_derived_types
= dt_list
;
13471 /* Ensure that a derived-type is really not abstract, meaning that every
13472 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13475 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13480 if (!ensure_not_abstract_walker (sub
, st
->left
))
13482 if (!ensure_not_abstract_walker (sub
, st
->right
))
13485 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13487 gfc_symtree
* overriding
;
13488 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13491 gcc_assert (overriding
->n
.tb
);
13492 if (overriding
->n
.tb
->deferred
)
13494 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13495 " %qs is DEFERRED and not overridden",
13496 sub
->name
, &sub
->declared_at
, st
->name
);
13505 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13507 /* The algorithm used here is to recursively travel up the ancestry of sub
13508 and for each ancestor-type, check all bindings. If any of them is
13509 DEFERRED, look it up starting from sub and see if the found (overriding)
13510 binding is not DEFERRED.
13511 This is not the most efficient way to do this, but it should be ok and is
13512 clearer than something sophisticated. */
13514 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13516 if (!ancestor
->attr
.abstract
)
13519 /* Walk bindings of this ancestor. */
13520 if (ancestor
->f2k_derived
)
13523 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13528 /* Find next ancestor type and recurse on it. */
13529 ancestor
= gfc_get_derived_super_type (ancestor
);
13531 return ensure_not_abstract (sub
, ancestor
);
13537 /* This check for typebound defined assignments is done recursively
13538 since the order in which derived types are resolved is not always in
13539 order of the declarations. */
13542 check_defined_assignments (gfc_symbol
*derived
)
13546 for (c
= derived
->components
; c
; c
= c
->next
)
13548 if (!gfc_bt_struct (c
->ts
.type
)
13550 || c
->attr
.allocatable
13551 || c
->attr
.proc_pointer_comp
13552 || c
->attr
.class_pointer
13553 || c
->attr
.proc_pointer
)
13556 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13557 || (c
->ts
.u
.derived
->f2k_derived
13558 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13560 derived
->attr
.defined_assign_comp
= 1;
13564 check_defined_assignments (c
->ts
.u
.derived
);
13565 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13567 derived
->attr
.defined_assign_comp
= 1;
13574 /* Resolve a single component of a derived type or structure. */
13577 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13579 gfc_symbol
*super_type
;
13581 if (c
->attr
.artificial
)
13584 /* Do not allow vtype components to be resolved in nameless namespaces
13585 such as block data because the procedure pointers will cause ICEs
13586 and vtables are not needed in these contexts. */
13587 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13588 && sym
->ns
->proc_name
== NULL
)
13592 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13593 && c
->attr
.codimension
13594 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13596 gfc_error ("Coarray component %qs at %L must be allocatable with "
13597 "deferred shape", c
->name
, &c
->loc
);
13602 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13603 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13605 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13606 "shall not be a coarray", c
->name
, &c
->loc
);
13611 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13612 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13613 || c
->attr
.allocatable
))
13615 gfc_error ("Component %qs at %L with coarray component "
13616 "shall be a nonpointer, nonallocatable scalar",
13622 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13624 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13625 "is not an array pointer", c
->name
, &c
->loc
);
13629 /* F2003, 15.2.1 - length has to be one. */
13630 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13631 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
13632 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
13633 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
13635 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13640 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13642 gfc_symbol
*ifc
= c
->ts
.interface
;
13644 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13650 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13652 /* Resolve interface and copy attributes. */
13653 if (ifc
->formal
&& !ifc
->formal_ns
)
13654 resolve_symbol (ifc
);
13655 if (ifc
->attr
.intrinsic
)
13656 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13660 c
->ts
= ifc
->result
->ts
;
13661 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13662 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13663 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13664 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13665 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13670 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13671 c
->attr
.pointer
= ifc
->attr
.pointer
;
13672 c
->attr
.dimension
= ifc
->attr
.dimension
;
13673 c
->as
= gfc_copy_array_spec (ifc
->as
);
13674 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13676 c
->ts
.interface
= ifc
;
13677 c
->attr
.function
= ifc
->attr
.function
;
13678 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13680 c
->attr
.pure
= ifc
->attr
.pure
;
13681 c
->attr
.elemental
= ifc
->attr
.elemental
;
13682 c
->attr
.recursive
= ifc
->attr
.recursive
;
13683 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13684 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13685 /* Copy char length. */
13686 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13688 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13689 if (cl
->length
&& !cl
->resolved
13690 && !gfc_resolve_expr (cl
->length
))
13699 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13701 /* Since PPCs are not implicitly typed, a PPC without an explicit
13702 interface must be a subroutine. */
13703 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13706 /* Procedure pointer components: Check PASS arg. */
13707 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13708 && !sym
->attr
.vtype
)
13710 gfc_symbol
* me_arg
;
13712 if (c
->tb
->pass_arg
)
13714 gfc_formal_arglist
* i
;
13716 /* If an explicit passing argument name is given, walk the arg-list
13717 and look for it. */
13720 c
->tb
->pass_arg_num
= 1;
13721 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13723 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13728 c
->tb
->pass_arg_num
++;
13733 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13734 "at %L has no argument %qs", c
->name
,
13735 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13742 /* Otherwise, take the first one; there should in fact be at least
13744 c
->tb
->pass_arg_num
= 1;
13745 if (!c
->ts
.interface
->formal
)
13747 gfc_error ("Procedure pointer component %qs with PASS at %L "
13748 "must have at least one argument",
13753 me_arg
= c
->ts
.interface
->formal
->sym
;
13756 /* Now check that the argument-type matches. */
13757 gcc_assert (me_arg
);
13758 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13759 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13760 || (me_arg
->ts
.type
== BT_CLASS
13761 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13763 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13764 " the derived type %qs", me_arg
->name
, c
->name
,
13765 me_arg
->name
, &c
->loc
, sym
->name
);
13770 /* Check for F03:C453. */
13771 if (CLASS_DATA (me_arg
)->attr
.dimension
)
13773 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13774 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13780 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13782 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13783 "may not have the POINTER attribute", me_arg
->name
,
13784 c
->name
, me_arg
->name
, &c
->loc
);
13789 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13791 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13792 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13793 me_arg
->name
, &c
->loc
);
13798 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13800 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13801 " at %L", c
->name
, &c
->loc
);
13807 /* Check type-spec if this is not the parent-type component. */
13808 if (((sym
->attr
.is_class
13809 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13810 || c
!= sym
->components
->ts
.u
.derived
->components
))
13811 || (!sym
->attr
.is_class
13812 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13813 && !sym
->attr
.vtype
13814 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13817 super_type
= gfc_get_derived_super_type (sym
);
13819 /* If this type is an extension, set the accessibility of the parent
13822 && ((sym
->attr
.is_class
13823 && c
== sym
->components
->ts
.u
.derived
->components
)
13824 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13825 && strcmp (super_type
->name
, c
->name
) == 0)
13826 c
->attr
.access
= super_type
->attr
.access
;
13828 /* If this type is an extension, see if this component has the same name
13829 as an inherited type-bound procedure. */
13830 if (super_type
&& !sym
->attr
.is_class
13831 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13833 gfc_error ("Component %qs of %qs at %L has the same name as an"
13834 " inherited type-bound procedure",
13835 c
->name
, sym
->name
, &c
->loc
);
13839 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13840 && !c
->ts
.deferred
)
13842 if (c
->ts
.u
.cl
->length
== NULL
13843 || (!resolve_charlen(c
->ts
.u
.cl
))
13844 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13846 gfc_error ("Character length of component %qs needs to "
13847 "be a constant specification expression at %L",
13849 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13854 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13855 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13857 gfc_error ("Character component %qs of %qs at %L with deferred "
13858 "length must be a POINTER or ALLOCATABLE",
13859 c
->name
, sym
->name
, &c
->loc
);
13863 /* Add the hidden deferred length field. */
13864 if (c
->ts
.type
== BT_CHARACTER
13865 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
13866 && !c
->attr
.function
13867 && !sym
->attr
.is_class
)
13869 char name
[GFC_MAX_SYMBOL_LEN
+9];
13870 gfc_component
*strlen
;
13871 sprintf (name
, "_%s_length", c
->name
);
13872 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
13873 if (strlen
== NULL
)
13875 if (!gfc_add_component (sym
, name
, &strlen
))
13877 strlen
->ts
.type
= BT_INTEGER
;
13878 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13879 strlen
->attr
.access
= ACCESS_PRIVATE
;
13880 strlen
->attr
.artificial
= 1;
13884 if (c
->ts
.type
== BT_DERIVED
13885 && sym
->component_access
!= ACCESS_PRIVATE
13886 && gfc_check_symbol_access (sym
)
13887 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13888 && !c
->ts
.u
.derived
->attr
.use_assoc
13889 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13890 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13891 "PRIVATE type and cannot be a component of "
13892 "%qs, which is PUBLIC at %L", c
->name
,
13893 sym
->name
, &sym
->declared_at
))
13896 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13898 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13899 "type %s", c
->name
, &c
->loc
, sym
->name
);
13903 if (sym
->attr
.sequence
)
13905 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13907 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13908 "not have the SEQUENCE attribute",
13909 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13914 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13915 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13916 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13917 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13918 CLASS_DATA (c
)->ts
.u
.derived
13919 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13921 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13922 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13923 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13925 gfc_error ("The pointer component %qs of %qs at %L is a type "
13926 "that has not been declared", c
->name
, sym
->name
,
13931 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13932 && CLASS_DATA (c
)->attr
.class_pointer
13933 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13934 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13935 && !UNLIMITED_POLY (c
))
13937 gfc_error ("The pointer component %qs of %qs at %L is a type "
13938 "that has not been declared", c
->name
, sym
->name
,
13943 /* If an allocatable component derived type is of the same type as
13944 the enclosing derived type, we need a vtable generating so that
13945 the __deallocate procedure is created. */
13946 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
13947 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
13948 gfc_find_vtab (&c
->ts
);
13950 /* Ensure that all the derived type components are put on the
13951 derived type list; even in formal namespaces, where derived type
13952 pointer components might not have been declared. */
13953 if (c
->ts
.type
== BT_DERIVED
13955 && c
->ts
.u
.derived
->components
13957 && sym
!= c
->ts
.u
.derived
)
13958 add_dt_to_dt_list (c
->ts
.u
.derived
);
13960 if (!gfc_resolve_array_spec (c
->as
,
13961 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13962 || c
->attr
.allocatable
)))
13965 if (c
->initializer
&& !sym
->attr
.vtype
13966 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
13967 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13974 /* Be nice about the locus for a structure expression - show the locus of the
13975 first non-null sub-expression if we can. */
13978 cons_where (gfc_expr
*struct_expr
)
13980 gfc_constructor
*cons
;
13982 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
13984 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
13985 for (; cons
; cons
= gfc_constructor_next (cons
))
13987 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
13988 return &cons
->expr
->where
;
13991 return &struct_expr
->where
;
13994 /* Resolve the components of a structure type. Much less work than derived
13998 resolve_fl_struct (gfc_symbol
*sym
)
14001 gfc_expr
*init
= NULL
;
14004 /* Make sure UNIONs do not have overlapping initializers. */
14005 if (sym
->attr
.flavor
== FL_UNION
)
14007 for (c
= sym
->components
; c
; c
= c
->next
)
14009 if (init
&& c
->initializer
)
14011 gfc_error ("Conflicting initializers in union at %L and %L",
14012 cons_where (init
), cons_where (c
->initializer
));
14013 gfc_free_expr (c
->initializer
);
14014 c
->initializer
= NULL
;
14017 init
= c
->initializer
;
14022 for (c
= sym
->components
; c
; c
= c
->next
)
14023 if (!resolve_component (c
, sym
))
14029 if (sym
->components
)
14030 add_dt_to_dt_list (sym
);
14036 /* Resolve the components of a derived type. This does not have to wait until
14037 resolution stage, but can be done as soon as the dt declaration has been
14041 resolve_fl_derived0 (gfc_symbol
*sym
)
14043 gfc_symbol
* super_type
;
14045 gfc_formal_arglist
*f
;
14048 if (sym
->attr
.unlimited_polymorphic
)
14051 super_type
= gfc_get_derived_super_type (sym
);
14054 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14056 gfc_error ("As extending type %qs at %L has a coarray component, "
14057 "parent type %qs shall also have one", sym
->name
,
14058 &sym
->declared_at
, super_type
->name
);
14062 /* Ensure the extended type gets resolved before we do. */
14063 if (super_type
&& !resolve_fl_derived0 (super_type
))
14066 /* An ABSTRACT type must be extensible. */
14067 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14069 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14070 sym
->name
, &sym
->declared_at
);
14074 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14078 for ( ; c
!= NULL
; c
= c
->next
)
14079 if (!resolve_component (c
, sym
))
14085 /* Now add the caf token field, where needed. */
14086 if (flag_coarray
!= GFC_FCOARRAY_NONE
14087 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14089 for (c
= sym
->components
; c
; c
= c
->next
)
14090 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14091 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14093 char name
[GFC_MAX_SYMBOL_LEN
+9];
14094 gfc_component
*token
;
14095 sprintf (name
, "_caf_%s", c
->name
);
14096 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14099 if (!gfc_add_component (sym
, name
, &token
))
14101 token
->ts
.type
= BT_VOID
;
14102 token
->ts
.kind
= gfc_default_integer_kind
;
14103 token
->attr
.access
= ACCESS_PRIVATE
;
14104 token
->attr
.artificial
= 1;
14105 token
->attr
.caf_token
= 1;
14110 check_defined_assignments (sym
);
14112 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14113 sym
->attr
.defined_assign_comp
14114 = super_type
->attr
.defined_assign_comp
;
14116 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14117 all DEFERRED bindings are overridden. */
14118 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14119 && !sym
->attr
.is_class
14120 && !ensure_not_abstract (sym
, super_type
))
14123 /* Check that there is a component for every PDT parameter. */
14124 if (sym
->attr
.pdt_template
)
14126 for (f
= sym
->formal
; f
; f
= f
->next
)
14130 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14133 gfc_error ("Parameterized type %qs does not have a component "
14134 "corresponding to parameter %qs at %L", sym
->name
,
14135 f
->sym
->name
, &sym
->declared_at
);
14141 /* Add derived type to the derived type list. */
14142 add_dt_to_dt_list (sym
);
14148 /* The following procedure does the full resolution of a derived type,
14149 including resolution of all type-bound procedures (if present). In contrast
14150 to 'resolve_fl_derived0' this can only be done after the module has been
14151 parsed completely. */
14154 resolve_fl_derived (gfc_symbol
*sym
)
14156 gfc_symbol
*gen_dt
= NULL
;
14158 if (sym
->attr
.unlimited_polymorphic
)
14161 if (!sym
->attr
.is_class
)
14162 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14163 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14164 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14165 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14166 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14167 "%qs at %L being the same name as derived "
14168 "type at %L", sym
->name
,
14169 gen_dt
->generic
->sym
== sym
14170 ? gen_dt
->generic
->next
->sym
->name
14171 : gen_dt
->generic
->sym
->name
,
14172 gen_dt
->generic
->sym
== sym
14173 ? &gen_dt
->generic
->next
->sym
->declared_at
14174 : &gen_dt
->generic
->sym
->declared_at
,
14175 &sym
->declared_at
))
14178 /* Resolve the finalizer procedures. */
14179 if (!gfc_resolve_finalizers (sym
, NULL
))
14182 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14184 /* Fix up incomplete CLASS symbols. */
14185 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14186 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14188 /* Nothing more to do for unlimited polymorphic entities. */
14189 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14191 else if (vptr
->ts
.u
.derived
== NULL
)
14193 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14195 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14196 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14201 if (!resolve_fl_derived0 (sym
))
14204 /* Resolve the type-bound procedures. */
14205 if (!resolve_typebound_procedures (sym
))
14208 /* Generate module vtables subject to their accessibility and their not
14209 being vtables or pdt templates. If this is not done class declarations
14210 in external procedures wind up with their own version and so SELECT TYPE
14211 fails because the vptrs do not have the same address. */
14212 if (gfc_option
.allow_std
& GFC_STD_F2003
14213 && sym
->ns
->proc_name
14214 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14215 && sym
->attr
.access
!= ACCESS_PRIVATE
14216 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14218 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14219 gfc_set_sym_referenced (vtab
);
14227 resolve_fl_namelist (gfc_symbol
*sym
)
14232 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14234 /* Check again, the check in match only works if NAMELIST comes
14236 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14238 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14239 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14243 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14244 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14245 "with assumed shape in namelist %qs at %L",
14246 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14249 if (is_non_constant_shape_array (nl
->sym
)
14250 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14251 "with nonconstant shape in namelist %qs at %L",
14252 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14255 if (nl
->sym
->ts
.type
== BT_CHARACTER
14256 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14257 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14258 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14259 "nonconstant character length in "
14260 "namelist %qs at %L", nl
->sym
->name
,
14261 sym
->name
, &sym
->declared_at
))
14266 /* Reject PRIVATE objects in a PUBLIC namelist. */
14267 if (gfc_check_symbol_access (sym
))
14269 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14271 if (!nl
->sym
->attr
.use_assoc
14272 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14273 && !gfc_check_symbol_access (nl
->sym
))
14275 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14276 "cannot be member of PUBLIC namelist %qs at %L",
14277 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14281 if (nl
->sym
->ts
.type
== BT_DERIVED
14282 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14283 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14285 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14286 "namelist %qs at %L with ALLOCATABLE "
14287 "or POINTER components", nl
->sym
->name
,
14288 sym
->name
, &sym
->declared_at
))
14293 /* Types with private components that came here by USE-association. */
14294 if (nl
->sym
->ts
.type
== BT_DERIVED
14295 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14297 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14298 "components and cannot be member of namelist %qs at %L",
14299 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14303 /* Types with private components that are defined in the same module. */
14304 if (nl
->sym
->ts
.type
== BT_DERIVED
14305 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14306 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14308 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14309 "cannot be a member of PUBLIC namelist %qs at %L",
14310 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14317 /* 14.1.2 A module or internal procedure represent local entities
14318 of the same type as a namelist member and so are not allowed. */
14319 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14321 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14324 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14325 if ((nl
->sym
== sym
->ns
->proc_name
)
14327 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14332 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14333 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14335 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14336 "attribute in %qs at %L", nlsym
->name
,
14337 &sym
->declared_at
);
14344 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14345 nl
->sym
->attr
.asynchronous
= 1;
14352 resolve_fl_parameter (gfc_symbol
*sym
)
14354 /* A parameter array's shape needs to be constant. */
14355 if (sym
->as
!= NULL
14356 && (sym
->as
->type
== AS_DEFERRED
14357 || is_non_constant_shape_array (sym
)))
14359 gfc_error ("Parameter array %qs at %L cannot be automatic "
14360 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14364 /* Constraints on deferred type parameter. */
14365 if (!deferred_requirements (sym
))
14368 /* Make sure a parameter that has been implicitly typed still
14369 matches the implicit type, since PARAMETER statements can precede
14370 IMPLICIT statements. */
14371 if (sym
->attr
.implicit_type
14372 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14375 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14376 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14380 /* Make sure the types of derived parameters are consistent. This
14381 type checking is deferred until resolution because the type may
14382 refer to a derived type from the host. */
14383 if (sym
->ts
.type
== BT_DERIVED
14384 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14386 gfc_error ("Incompatible derived type in PARAMETER at %L",
14387 &sym
->value
->where
);
14391 /* F03:C509,C514. */
14392 if (sym
->ts
.type
== BT_CLASS
)
14394 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14395 sym
->name
, &sym
->declared_at
);
14403 /* Called by resolve_symbol to check PDTs. */
14406 resolve_pdt (gfc_symbol
* sym
)
14408 gfc_symbol
*derived
= NULL
;
14409 gfc_actual_arglist
*param
;
14411 bool const_len_exprs
= true;
14412 bool assumed_len_exprs
= false;
14413 symbol_attribute
*attr
;
14415 if (sym
->ts
.type
== BT_DERIVED
)
14417 derived
= sym
->ts
.u
.derived
;
14418 attr
= &(sym
->attr
);
14420 else if (sym
->ts
.type
== BT_CLASS
)
14422 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14423 attr
= &(CLASS_DATA (sym
)->attr
);
14426 gcc_unreachable ();
14428 gcc_assert (derived
->attr
.pdt_type
);
14430 for (param
= sym
->param_list
; param
; param
= param
->next
)
14432 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14434 if (c
->attr
.pdt_kind
)
14437 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14438 && c
->attr
.pdt_len
)
14439 const_len_exprs
= false;
14440 else if (param
->spec_type
== SPEC_ASSUMED
)
14441 assumed_len_exprs
= true;
14443 if (param
->spec_type
== SPEC_DEFERRED
14444 && !attr
->allocatable
&& !attr
->pointer
)
14445 gfc_error ("The object %qs at %L has a deferred LEN "
14446 "parameter %qs and is neither allocatable "
14447 "nor a pointer", sym
->name
, &sym
->declared_at
,
14452 if (!const_len_exprs
14453 && (sym
->ns
->proc_name
->attr
.is_main_program
14454 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14455 || sym
->attr
.save
!= SAVE_NONE
))
14456 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14457 "SAVE attribute or be a variable declared in the "
14458 "main program, a module or a submodule(F08/C513)",
14459 sym
->name
, &sym
->declared_at
);
14461 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14462 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14463 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14464 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14465 sym
->name
, &sym
->declared_at
);
14469 /* Do anything necessary to resolve a symbol. Right now, we just
14470 assume that an otherwise unknown symbol is a variable. This sort
14471 of thing commonly happens for symbols in module. */
14474 resolve_symbol (gfc_symbol
*sym
)
14476 int check_constant
, mp_flag
;
14477 gfc_symtree
*symtree
;
14478 gfc_symtree
*this_symtree
;
14481 symbol_attribute class_attr
;
14482 gfc_array_spec
*as
;
14483 bool saved_specification_expr
;
14489 /* No symbol will ever have union type; only components can be unions.
14490 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14491 (just like derived type declaration symbols have flavor FL_DERIVED). */
14492 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14494 /* Coarrayed polymorphic objects with allocatable or pointer components are
14495 yet unsupported for -fcoarray=lib. */
14496 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14497 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14498 && CLASS_DATA (sym
)->attr
.codimension
14499 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14500 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14502 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14503 "type coarrays at %L are unsupported", &sym
->declared_at
);
14507 if (sym
->attr
.artificial
)
14510 if (sym
->attr
.unlimited_polymorphic
)
14513 if (sym
->attr
.flavor
== FL_UNKNOWN
14514 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14515 && !sym
->attr
.generic
&& !sym
->attr
.external
14516 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14517 && sym
->ts
.type
== BT_UNKNOWN
))
14520 /* If we find that a flavorless symbol is an interface in one of the
14521 parent namespaces, find its symtree in this namespace, free the
14522 symbol and set the symtree to point to the interface symbol. */
14523 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14525 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14526 if (symtree
&& (symtree
->n
.sym
->generic
||
14527 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14528 && sym
->ns
->construct_entities
)))
14530 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14532 if (this_symtree
->n
.sym
== sym
)
14534 symtree
->n
.sym
->refs
++;
14535 gfc_release_symbol (sym
);
14536 this_symtree
->n
.sym
= symtree
->n
.sym
;
14542 /* Otherwise give it a flavor according to such attributes as
14544 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14545 && sym
->attr
.intrinsic
== 0)
14546 sym
->attr
.flavor
= FL_VARIABLE
;
14547 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14549 sym
->attr
.flavor
= FL_PROCEDURE
;
14550 if (sym
->attr
.dimension
)
14551 sym
->attr
.function
= 1;
14555 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14556 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14558 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14559 && !resolve_procedure_interface (sym
))
14562 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14563 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14565 if (sym
->attr
.external
)
14566 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14567 "at %L", &sym
->declared_at
);
14569 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14570 "at %L", &sym
->declared_at
);
14575 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14578 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14579 && !resolve_fl_struct (sym
))
14582 /* Symbols that are module procedures with results (functions) have
14583 the types and array specification copied for type checking in
14584 procedures that call them, as well as for saving to a module
14585 file. These symbols can't stand the scrutiny that their results
14587 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14589 /* Make sure that the intrinsic is consistent with its internal
14590 representation. This needs to be done before assigning a default
14591 type to avoid spurious warnings. */
14592 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14593 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14596 /* Resolve associate names. */
14598 resolve_assoc_var (sym
, true);
14600 /* Assign default type to symbols that need one and don't have one. */
14601 if (sym
->ts
.type
== BT_UNKNOWN
)
14603 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14605 gfc_set_default_type (sym
, 1, NULL
);
14608 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14609 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14610 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14611 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14613 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14615 /* The specific case of an external procedure should emit an error
14616 in the case that there is no implicit type. */
14619 if (!sym
->attr
.mixed_entry_master
)
14620 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14624 /* Result may be in another namespace. */
14625 resolve_symbol (sym
->result
);
14627 if (!sym
->result
->attr
.proc_pointer
)
14629 sym
->ts
= sym
->result
->ts
;
14630 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14631 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14632 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14633 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14634 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14639 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14641 bool saved_specification_expr
= specification_expr
;
14642 specification_expr
= true;
14643 gfc_resolve_array_spec (sym
->result
->as
, false);
14644 specification_expr
= saved_specification_expr
;
14647 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14649 as
= CLASS_DATA (sym
)->as
;
14650 class_attr
= CLASS_DATA (sym
)->attr
;
14651 class_attr
.pointer
= class_attr
.class_pointer
;
14655 class_attr
= sym
->attr
;
14660 if (sym
->attr
.contiguous
14661 && (!class_attr
.dimension
14662 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14663 && !class_attr
.pointer
)))
14665 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14666 "array pointer or an assumed-shape or assumed-rank array",
14667 sym
->name
, &sym
->declared_at
);
14671 /* Assumed size arrays and assumed shape arrays must be dummy
14672 arguments. Array-spec's of implied-shape should have been resolved to
14673 AS_EXPLICIT already. */
14677 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14678 specification expression. */
14679 if (as
->type
== AS_IMPLIED_SHAPE
)
14682 for (i
=0; i
<as
->rank
; i
++)
14684 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
14686 gfc_error ("Bad specification for assumed size array at %L",
14687 &as
->lower
[i
]->where
);
14694 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14695 || as
->type
== AS_ASSUMED_SHAPE
)
14696 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14698 if (as
->type
== AS_ASSUMED_SIZE
)
14699 gfc_error ("Assumed size array at %L must be a dummy argument",
14700 &sym
->declared_at
);
14702 gfc_error ("Assumed shape array at %L must be a dummy argument",
14703 &sym
->declared_at
);
14706 /* TS 29113, C535a. */
14707 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14708 && !sym
->attr
.select_type_temporary
)
14710 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14711 &sym
->declared_at
);
14714 if (as
->type
== AS_ASSUMED_RANK
14715 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14717 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14718 "CODIMENSION attribute", &sym
->declared_at
);
14723 /* Make sure symbols with known intent or optional are really dummy
14724 variable. Because of ENTRY statement, this has to be deferred
14725 until resolution time. */
14727 if (!sym
->attr
.dummy
14728 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14730 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14734 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14736 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14737 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14741 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14743 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14744 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14746 gfc_error ("Character dummy variable %qs at %L with VALUE "
14747 "attribute must have constant length",
14748 sym
->name
, &sym
->declared_at
);
14752 if (sym
->ts
.is_c_interop
14753 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14755 gfc_error ("C interoperable character dummy variable %qs at %L "
14756 "with VALUE attribute must have length one",
14757 sym
->name
, &sym
->declared_at
);
14762 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14763 && sym
->ts
.u
.derived
->attr
.generic
)
14765 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14766 if (!sym
->ts
.u
.derived
)
14768 gfc_error ("The derived type %qs at %L is of type %qs, "
14769 "which has not been defined", sym
->name
,
14770 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14771 sym
->ts
.type
= BT_UNKNOWN
;
14776 /* Use the same constraints as TYPE(*), except for the type check
14777 and that only scalars and assumed-size arrays are permitted. */
14778 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14780 if (!sym
->attr
.dummy
)
14782 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14783 "a dummy argument", sym
->name
, &sym
->declared_at
);
14787 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14788 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14789 && sym
->ts
.type
!= BT_COMPLEX
)
14791 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14792 "of type TYPE(*) or of an numeric intrinsic type",
14793 sym
->name
, &sym
->declared_at
);
14797 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14798 || sym
->attr
.pointer
|| sym
->attr
.value
)
14800 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14801 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14802 "attribute", sym
->name
, &sym
->declared_at
);
14806 if (sym
->attr
.intent
== INTENT_OUT
)
14808 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14809 "have the INTENT(OUT) attribute",
14810 sym
->name
, &sym
->declared_at
);
14813 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14815 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14816 "either be a scalar or an assumed-size array",
14817 sym
->name
, &sym
->declared_at
);
14821 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14822 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14824 sym
->ts
.type
= BT_ASSUMED
;
14825 sym
->as
= gfc_get_array_spec ();
14826 sym
->as
->type
= AS_ASSUMED_SIZE
;
14828 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14830 else if (sym
->ts
.type
== BT_ASSUMED
)
14832 /* TS 29113, C407a. */
14833 if (!sym
->attr
.dummy
)
14835 gfc_error ("Assumed type of variable %s at %L is only permitted "
14836 "for dummy variables", sym
->name
, &sym
->declared_at
);
14839 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14840 || sym
->attr
.pointer
|| sym
->attr
.value
)
14842 gfc_error ("Assumed-type variable %s at %L may not have the "
14843 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14844 sym
->name
, &sym
->declared_at
);
14847 if (sym
->attr
.intent
== INTENT_OUT
)
14849 gfc_error ("Assumed-type variable %s at %L may not have the "
14850 "INTENT(OUT) attribute",
14851 sym
->name
, &sym
->declared_at
);
14854 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14856 gfc_error ("Assumed-type variable %s at %L shall not be an "
14857 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14862 /* If the symbol is marked as bind(c), that it is declared at module level
14863 scope and verify its type and kind. Do not do the latter for symbols
14864 that are implicitly typed because that is handled in
14865 gfc_set_default_type. Handle dummy arguments and procedure definitions
14866 separately. Also, anything that is use associated is not handled here
14867 but instead is handled in the module it is declared in. Finally, derived
14868 type definitions are allowed to be BIND(C) since that only implies that
14869 they're interoperable, and they are checked fully for interoperability
14870 when a variable is declared of that type. */
14871 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
14872 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
14873 && sym
->attr
.flavor
!= FL_DERIVED
)
14877 /* First, make sure the variable is declared at the
14878 module-level scope (J3/04-007, Section 15.3). */
14879 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
14880 sym
->attr
.in_common
== 0)
14882 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14883 "is neither a COMMON block nor declared at the "
14884 "module level scope", sym
->name
, &(sym
->declared_at
));
14887 else if (sym
->ts
.type
== BT_CHARACTER
14888 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
14889 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
14890 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14892 gfc_error ("BIND(C) Variable %qs at %L must have length one",
14893 sym
->name
, &sym
->declared_at
);
14896 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
14898 t
= verify_com_block_vars_c_interop (sym
->common_head
);
14900 else if (sym
->attr
.implicit_type
== 0)
14902 /* If type() declaration, we need to verify that the components
14903 of the given type are all C interoperable, etc. */
14904 if (sym
->ts
.type
== BT_DERIVED
&&
14905 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
14907 /* Make sure the user marked the derived type as BIND(C). If
14908 not, call the verify routine. This could print an error
14909 for the derived type more than once if multiple variables
14910 of that type are declared. */
14911 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
14912 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
14916 /* Verify the variable itself as C interoperable if it
14917 is BIND(C). It is not possible for this to succeed if
14918 the verify_bind_c_derived_type failed, so don't have to handle
14919 any error returned by verify_bind_c_derived_type. */
14920 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
14921 sym
->common_block
);
14926 /* clear the is_bind_c flag to prevent reporting errors more than
14927 once if something failed. */
14928 sym
->attr
.is_bind_c
= 0;
14933 /* If a derived type symbol has reached this point, without its
14934 type being declared, we have an error. Notice that most
14935 conditions that produce undefined derived types have already
14936 been dealt with. However, the likes of:
14937 implicit type(t) (t) ..... call foo (t) will get us here if
14938 the type is not declared in the scope of the implicit
14939 statement. Change the type to BT_UNKNOWN, both because it is so
14940 and to prevent an ICE. */
14941 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14942 && sym
->ts
.u
.derived
->components
== NULL
14943 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14945 gfc_error ("The derived type %qs at %L is of type %qs, "
14946 "which has not been defined", sym
->name
,
14947 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14948 sym
->ts
.type
= BT_UNKNOWN
;
14952 /* Make sure that the derived type has been resolved and that the
14953 derived type is visible in the symbol's namespace, if it is a
14954 module function and is not PRIVATE. */
14955 if (sym
->ts
.type
== BT_DERIVED
14956 && sym
->ts
.u
.derived
->attr
.use_assoc
14957 && sym
->ns
->proc_name
14958 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14959 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14962 /* Unless the derived-type declaration is use associated, Fortran 95
14963 does not allow public entries of private derived types.
14964 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14965 161 in 95-006r3. */
14966 if (sym
->ts
.type
== BT_DERIVED
14967 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14968 && !sym
->ts
.u
.derived
->attr
.use_assoc
14969 && gfc_check_symbol_access (sym
)
14970 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14971 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14972 "derived type %qs",
14973 (sym
->attr
.flavor
== FL_PARAMETER
)
14974 ? "parameter" : "variable",
14975 sym
->name
, &sym
->declared_at
,
14976 sym
->ts
.u
.derived
->name
))
14979 /* F2008, C1302. */
14980 if (sym
->ts
.type
== BT_DERIVED
14981 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14982 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14983 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14984 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14986 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14987 "type LOCK_TYPE must be a coarray", sym
->name
,
14988 &sym
->declared_at
);
14992 /* TS18508, C702/C703. */
14993 if (sym
->ts
.type
== BT_DERIVED
14994 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14995 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14996 || sym
->ts
.u
.derived
->attr
.event_comp
)
14997 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14999 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15000 "type EVENT_TYPE must be a coarray", sym
->name
,
15001 &sym
->declared_at
);
15005 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15006 default initialization is defined (5.1.2.4.4). */
15007 if (sym
->ts
.type
== BT_DERIVED
15009 && sym
->attr
.intent
== INTENT_OUT
15011 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15013 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15015 if (c
->initializer
)
15017 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15018 "ASSUMED SIZE and so cannot have a default initializer",
15019 sym
->name
, &sym
->declared_at
);
15026 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15027 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15029 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15030 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15035 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15036 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15038 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15039 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15044 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15045 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15046 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15047 || class_attr
.codimension
)
15048 && (sym
->attr
.result
|| sym
->result
== sym
))
15050 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15051 "a coarray component", sym
->name
, &sym
->declared_at
);
15056 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15057 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15059 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15060 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15065 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15066 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15067 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15068 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15069 || class_attr
.allocatable
))
15071 gfc_error ("Variable %qs at %L with coarray component shall be a "
15072 "nonpointer, nonallocatable scalar, which is not a coarray",
15073 sym
->name
, &sym
->declared_at
);
15077 /* F2008, C526. The function-result case was handled above. */
15078 if (class_attr
.codimension
15079 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15080 || sym
->attr
.select_type_temporary
15081 || sym
->attr
.associate_var
15082 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15083 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15084 || sym
->ns
->proc_name
->attr
.is_main_program
15085 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15087 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15088 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15092 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15093 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15095 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15096 "deferred shape", sym
->name
, &sym
->declared_at
);
15099 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15100 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15102 gfc_error ("Allocatable coarray variable %qs at %L must have "
15103 "deferred shape", sym
->name
, &sym
->declared_at
);
15108 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15109 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15110 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15111 || (class_attr
.codimension
&& class_attr
.allocatable
))
15112 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15114 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15115 "allocatable coarray or have coarray components",
15116 sym
->name
, &sym
->declared_at
);
15120 if (class_attr
.codimension
&& sym
->attr
.dummy
15121 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15123 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15124 "procedure %qs", sym
->name
, &sym
->declared_at
,
15125 sym
->ns
->proc_name
->name
);
15129 if (sym
->ts
.type
== BT_LOGICAL
15130 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15131 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15132 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15135 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15136 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15138 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15139 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15140 "%L with non-C_Bool kind in BIND(C) procedure "
15141 "%qs", sym
->name
, &sym
->declared_at
,
15142 sym
->ns
->proc_name
->name
))
15144 else if (!gfc_logical_kinds
[i
].c_bool
15145 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15146 "%qs at %L with non-C_Bool kind in "
15147 "BIND(C) procedure %qs", sym
->name
,
15149 sym
->attr
.function
? sym
->name
15150 : sym
->ns
->proc_name
->name
))
15154 switch (sym
->attr
.flavor
)
15157 if (!resolve_fl_variable (sym
, mp_flag
))
15162 if (sym
->formal
&& !sym
->formal_ns
)
15164 /* Check that none of the arguments are a namelist. */
15165 gfc_formal_arglist
*formal
= sym
->formal
;
15167 for (; formal
; formal
= formal
->next
)
15168 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15170 gfc_error ("Namelist %qs can not be an argument to "
15171 "subroutine or function at %L",
15172 formal
->sym
->name
, &sym
->declared_at
);
15177 if (!resolve_fl_procedure (sym
, mp_flag
))
15182 if (!resolve_fl_namelist (sym
))
15187 if (!resolve_fl_parameter (sym
))
15195 /* Resolve array specifier. Check as well some constraints
15196 on COMMON blocks. */
15198 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15200 /* Set the formal_arg_flag so that check_conflict will not throw
15201 an error for host associated variables in the specification
15202 expression for an array_valued function. */
15203 if (sym
->attr
.function
&& sym
->as
)
15204 formal_arg_flag
= true;
15206 saved_specification_expr
= specification_expr
;
15207 specification_expr
= true;
15208 gfc_resolve_array_spec (sym
->as
, check_constant
);
15209 specification_expr
= saved_specification_expr
;
15211 formal_arg_flag
= false;
15213 /* Resolve formal namespaces. */
15214 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15215 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15216 gfc_resolve (sym
->formal_ns
);
15218 /* Make sure the formal namespace is present. */
15219 if (sym
->formal
&& !sym
->formal_ns
)
15221 gfc_formal_arglist
*formal
= sym
->formal
;
15222 while (formal
&& !formal
->sym
)
15223 formal
= formal
->next
;
15227 sym
->formal_ns
= formal
->sym
->ns
;
15228 if (sym
->ns
!= formal
->sym
->ns
)
15229 sym
->formal_ns
->refs
++;
15233 /* Check threadprivate restrictions. */
15234 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15235 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15236 && (!sym
->attr
.in_common
15237 && sym
->module
== NULL
15238 && (sym
->ns
->proc_name
== NULL
15239 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15240 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15242 /* Check omp declare target restrictions. */
15243 if (sym
->attr
.omp_declare_target
15244 && sym
->attr
.flavor
== FL_VARIABLE
15246 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15247 && (!sym
->attr
.in_common
15248 && sym
->module
== NULL
15249 && (sym
->ns
->proc_name
== NULL
15250 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15251 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15252 sym
->name
, &sym
->declared_at
);
15254 /* If we have come this far we can apply default-initializers, as
15255 described in 14.7.5, to those variables that have not already
15256 been assigned one. */
15257 if (sym
->ts
.type
== BT_DERIVED
15259 && !sym
->attr
.allocatable
15260 && !sym
->attr
.alloc_comp
)
15262 symbol_attribute
*a
= &sym
->attr
;
15264 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15265 && !a
->in_common
&& !a
->use_assoc
15267 && !((a
->function
|| a
->result
)
15269 || sym
->ts
.u
.derived
->attr
.alloc_comp
15270 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15271 && !(a
->function
&& sym
!= sym
->result
))
15272 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15273 apply_default_init (sym
);
15274 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15275 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15276 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15277 /* Mark the result symbol to be referenced, when it has allocatable
15279 sym
->result
->attr
.referenced
= 1;
15282 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15283 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15284 && !CLASS_DATA (sym
)->attr
.class_pointer
15285 && !CLASS_DATA (sym
)->attr
.allocatable
)
15286 apply_default_init (sym
);
15288 /* If this symbol has a type-spec, check it. */
15289 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15290 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15291 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15294 if (sym
->param_list
)
15299 /************* Resolve DATA statements *************/
15303 gfc_data_value
*vnode
;
15309 /* Advance the values structure to point to the next value in the data list. */
15312 next_data_value (void)
15314 while (mpz_cmp_ui (values
.left
, 0) == 0)
15317 if (values
.vnode
->next
== NULL
)
15320 values
.vnode
= values
.vnode
->next
;
15321 mpz_set (values
.left
, values
.vnode
->repeat
);
15329 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15335 ar_type mark
= AR_UNKNOWN
;
15337 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15343 if (!gfc_resolve_expr (var
->expr
))
15347 mpz_init_set_si (offset
, 0);
15350 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15351 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15352 e
= e
->value
.function
.actual
->expr
;
15354 if (e
->expr_type
!= EXPR_VARIABLE
)
15355 gfc_internal_error ("check_data_variable(): Bad expression");
15357 sym
= e
->symtree
->n
.sym
;
15359 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15361 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15362 sym
->name
, &sym
->declared_at
);
15365 if (e
->ref
== NULL
&& sym
->as
)
15367 gfc_error ("DATA array %qs at %L must be specified in a previous"
15368 " declaration", sym
->name
, where
);
15372 has_pointer
= sym
->attr
.pointer
;
15374 if (gfc_is_coindexed (e
))
15376 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15381 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15383 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15387 && ref
->type
== REF_ARRAY
15388 && ref
->u
.ar
.type
!= AR_FULL
)
15390 gfc_error ("DATA element %qs at %L is a pointer and so must "
15391 "be a full array", sym
->name
, where
);
15396 if (e
->rank
== 0 || has_pointer
)
15398 mpz_init_set_ui (size
, 1);
15405 /* Find the array section reference. */
15406 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15408 if (ref
->type
!= REF_ARRAY
)
15410 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15416 /* Set marks according to the reference pattern. */
15417 switch (ref
->u
.ar
.type
)
15425 /* Get the start position of array section. */
15426 gfc_get_section_index (ar
, section_index
, &offset
);
15431 gcc_unreachable ();
15434 if (!gfc_array_size (e
, &size
))
15436 gfc_error ("Nonconstant array section at %L in DATA statement",
15438 mpz_clear (offset
);
15445 while (mpz_cmp_ui (size
, 0) > 0)
15447 if (!next_data_value ())
15449 gfc_error ("DATA statement at %L has more variables than values",
15455 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15459 /* If we have more than one element left in the repeat count,
15460 and we have more than one element left in the target variable,
15461 then create a range assignment. */
15462 /* FIXME: Only done for full arrays for now, since array sections
15464 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15465 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15469 if (mpz_cmp (size
, values
.left
) >= 0)
15471 mpz_init_set (range
, values
.left
);
15472 mpz_sub (size
, size
, values
.left
);
15473 mpz_set_ui (values
.left
, 0);
15477 mpz_init_set (range
, size
);
15478 mpz_sub (values
.left
, values
.left
, size
);
15479 mpz_set_ui (size
, 0);
15482 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15485 mpz_add (offset
, offset
, range
);
15492 /* Assign initial value to symbol. */
15495 mpz_sub_ui (values
.left
, values
.left
, 1);
15496 mpz_sub_ui (size
, size
, 1);
15498 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15503 if (mark
== AR_FULL
)
15504 mpz_add_ui (offset
, offset
, 1);
15506 /* Modify the array section indexes and recalculate the offset
15507 for next element. */
15508 else if (mark
== AR_SECTION
)
15509 gfc_advance_section (section_index
, ar
, &offset
);
15513 if (mark
== AR_SECTION
)
15515 for (i
= 0; i
< ar
->dimen
; i
++)
15516 mpz_clear (section_index
[i
]);
15520 mpz_clear (offset
);
15526 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15528 /* Iterate over a list of elements in a DATA statement. */
15531 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15534 iterator_stack frame
;
15535 gfc_expr
*e
, *start
, *end
, *step
;
15536 bool retval
= true;
15538 mpz_init (frame
.value
);
15541 start
= gfc_copy_expr (var
->iter
.start
);
15542 end
= gfc_copy_expr (var
->iter
.end
);
15543 step
= gfc_copy_expr (var
->iter
.step
);
15545 if (!gfc_simplify_expr (start
, 1)
15546 || start
->expr_type
!= EXPR_CONSTANT
)
15548 gfc_error ("start of implied-do loop at %L could not be "
15549 "simplified to a constant value", &start
->where
);
15553 if (!gfc_simplify_expr (end
, 1)
15554 || end
->expr_type
!= EXPR_CONSTANT
)
15556 gfc_error ("end of implied-do loop at %L could not be "
15557 "simplified to a constant value", &start
->where
);
15561 if (!gfc_simplify_expr (step
, 1)
15562 || step
->expr_type
!= EXPR_CONSTANT
)
15564 gfc_error ("step of implied-do loop at %L could not be "
15565 "simplified to a constant value", &start
->where
);
15570 mpz_set (trip
, end
->value
.integer
);
15571 mpz_sub (trip
, trip
, start
->value
.integer
);
15572 mpz_add (trip
, trip
, step
->value
.integer
);
15574 mpz_div (trip
, trip
, step
->value
.integer
);
15576 mpz_set (frame
.value
, start
->value
.integer
);
15578 frame
.prev
= iter_stack
;
15579 frame
.variable
= var
->iter
.var
->symtree
;
15580 iter_stack
= &frame
;
15582 while (mpz_cmp_ui (trip
, 0) > 0)
15584 if (!traverse_data_var (var
->list
, where
))
15590 e
= gfc_copy_expr (var
->expr
);
15591 if (!gfc_simplify_expr (e
, 1))
15598 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15600 mpz_sub_ui (trip
, trip
, 1);
15604 mpz_clear (frame
.value
);
15607 gfc_free_expr (start
);
15608 gfc_free_expr (end
);
15609 gfc_free_expr (step
);
15611 iter_stack
= frame
.prev
;
15616 /* Type resolve variables in the variable list of a DATA statement. */
15619 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15623 for (; var
; var
= var
->next
)
15625 if (var
->expr
== NULL
)
15626 t
= traverse_data_list (var
, where
);
15628 t
= check_data_variable (var
, where
);
15638 /* Resolve the expressions and iterators associated with a data statement.
15639 This is separate from the assignment checking because data lists should
15640 only be resolved once. */
15643 resolve_data_variables (gfc_data_variable
*d
)
15645 for (; d
; d
= d
->next
)
15647 if (d
->list
== NULL
)
15649 if (!gfc_resolve_expr (d
->expr
))
15654 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15657 if (!resolve_data_variables (d
->list
))
15666 /* Resolve a single DATA statement. We implement this by storing a pointer to
15667 the value list into static variables, and then recursively traversing the
15668 variables list, expanding iterators and such. */
15671 resolve_data (gfc_data
*d
)
15674 if (!resolve_data_variables (d
->var
))
15677 values
.vnode
= d
->value
;
15678 if (d
->value
== NULL
)
15679 mpz_set_ui (values
.left
, 0);
15681 mpz_set (values
.left
, d
->value
->repeat
);
15683 if (!traverse_data_var (d
->var
, &d
->where
))
15686 /* At this point, we better not have any values left. */
15688 if (next_data_value ())
15689 gfc_error ("DATA statement at %L has more values than variables",
15694 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15695 accessed by host or use association, is a dummy argument to a pure function,
15696 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15697 is storage associated with any such variable, shall not be used in the
15698 following contexts: (clients of this function). */
15700 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15701 procedure. Returns zero if assignment is OK, nonzero if there is a
15704 gfc_impure_variable (gfc_symbol
*sym
)
15709 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15712 /* Check if the symbol's ns is inside the pure procedure. */
15713 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15717 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15721 proc
= sym
->ns
->proc_name
;
15722 if (sym
->attr
.dummy
15723 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15724 || proc
->attr
.function
))
15727 /* TODO: Sort out what can be storage associated, if anything, and include
15728 it here. In principle equivalences should be scanned but it does not
15729 seem to be possible to storage associate an impure variable this way. */
15734 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15735 current namespace is inside a pure procedure. */
15738 gfc_pure (gfc_symbol
*sym
)
15740 symbol_attribute attr
;
15745 /* Check if the current namespace or one of its parents
15746 belongs to a pure procedure. */
15747 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15749 sym
= ns
->proc_name
;
15753 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15761 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15765 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15766 checks if the current namespace is implicitly pure. Note that this
15767 function returns false for a PURE procedure. */
15770 gfc_implicit_pure (gfc_symbol
*sym
)
15776 /* Check if the current procedure is implicit_pure. Walk up
15777 the procedure list until we find a procedure. */
15778 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15780 sym
= ns
->proc_name
;
15784 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15789 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15790 && !sym
->attr
.pure
;
15795 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15801 /* Check if the current procedure is implicit_pure. Walk up
15802 the procedure list until we find a procedure. */
15803 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15805 sym
= ns
->proc_name
;
15809 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15814 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15815 sym
->attr
.implicit_pure
= 0;
15817 sym
->attr
.pure
= 0;
15821 /* Test whether the current procedure is elemental or not. */
15824 gfc_elemental (gfc_symbol
*sym
)
15826 symbol_attribute attr
;
15829 sym
= gfc_current_ns
->proc_name
;
15834 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15838 /* Warn about unused labels. */
15841 warn_unused_fortran_label (gfc_st_label
*label
)
15846 warn_unused_fortran_label (label
->left
);
15848 if (label
->defined
== ST_LABEL_UNKNOWN
)
15851 switch (label
->referenced
)
15853 case ST_LABEL_UNKNOWN
:
15854 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
15855 label
->value
, &label
->where
);
15858 case ST_LABEL_BAD_TARGET
:
15859 gfc_warning (OPT_Wunused_label
,
15860 "Label %d at %L defined but cannot be used",
15861 label
->value
, &label
->where
);
15868 warn_unused_fortran_label (label
->right
);
15872 /* Returns the sequence type of a symbol or sequence. */
15875 sequence_type (gfc_typespec ts
)
15884 if (ts
.u
.derived
->components
== NULL
)
15885 return SEQ_NONDEFAULT
;
15887 result
= sequence_type (ts
.u
.derived
->components
->ts
);
15888 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
15889 if (sequence_type (c
->ts
) != result
)
15895 if (ts
.kind
!= gfc_default_character_kind
)
15896 return SEQ_NONDEFAULT
;
15898 return SEQ_CHARACTER
;
15901 if (ts
.kind
!= gfc_default_integer_kind
)
15902 return SEQ_NONDEFAULT
;
15904 return SEQ_NUMERIC
;
15907 if (!(ts
.kind
== gfc_default_real_kind
15908 || ts
.kind
== gfc_default_double_kind
))
15909 return SEQ_NONDEFAULT
;
15911 return SEQ_NUMERIC
;
15914 if (ts
.kind
!= gfc_default_complex_kind
)
15915 return SEQ_NONDEFAULT
;
15917 return SEQ_NUMERIC
;
15920 if (ts
.kind
!= gfc_default_logical_kind
)
15921 return SEQ_NONDEFAULT
;
15923 return SEQ_NUMERIC
;
15926 return SEQ_NONDEFAULT
;
15931 /* Resolve derived type EQUIVALENCE object. */
15934 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
15936 gfc_component
*c
= derived
->components
;
15941 /* Shall not be an object of nonsequence derived type. */
15942 if (!derived
->attr
.sequence
)
15944 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15945 "attribute to be an EQUIVALENCE object", sym
->name
,
15950 /* Shall not have allocatable components. */
15951 if (derived
->attr
.alloc_comp
)
15953 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15954 "components to be an EQUIVALENCE object",sym
->name
,
15959 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
15961 gfc_error ("Derived type variable %qs at %L with default "
15962 "initialization cannot be in EQUIVALENCE with a variable "
15963 "in COMMON", sym
->name
, &e
->where
);
15967 for (; c
; c
= c
->next
)
15969 if (gfc_bt_struct (c
->ts
.type
)
15970 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15973 /* Shall not be an object of sequence derived type containing a pointer
15974 in the structure. */
15975 if (c
->attr
.pointer
)
15977 gfc_error ("Derived type variable %qs at %L with pointer "
15978 "component(s) cannot be an EQUIVALENCE object",
15979 sym
->name
, &e
->where
);
15987 /* Resolve equivalence object.
15988 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15989 an allocatable array, an object of nonsequence derived type, an object of
15990 sequence derived type containing a pointer at any level of component
15991 selection, an automatic object, a function name, an entry name, a result
15992 name, a named constant, a structure component, or a subobject of any of
15993 the preceding objects. A substring shall not have length zero. A
15994 derived type shall not have components with default initialization nor
15995 shall two objects of an equivalence group be initialized.
15996 Either all or none of the objects shall have an protected attribute.
15997 The simple constraints are done in symbol.c(check_conflict) and the rest
15998 are implemented here. */
16001 resolve_equivalence (gfc_equiv
*eq
)
16004 gfc_symbol
*first_sym
;
16007 locus
*last_where
= NULL
;
16008 seq_type eq_type
, last_eq_type
;
16009 gfc_typespec
*last_ts
;
16010 int object
, cnt_protected
;
16013 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16015 first_sym
= eq
->expr
->symtree
->n
.sym
;
16019 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16023 e
->ts
= e
->symtree
->n
.sym
->ts
;
16024 /* match_varspec might not know yet if it is seeing
16025 array reference or substring reference, as it doesn't
16027 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16029 gfc_ref
*ref
= e
->ref
;
16030 sym
= e
->symtree
->n
.sym
;
16032 if (sym
->attr
.dimension
)
16034 ref
->u
.ar
.as
= sym
->as
;
16038 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16039 if (e
->ts
.type
== BT_CHARACTER
16041 && ref
->type
== REF_ARRAY
16042 && ref
->u
.ar
.dimen
== 1
16043 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16044 && ref
->u
.ar
.stride
[0] == NULL
)
16046 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16047 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16050 /* Optimize away the (:) reference. */
16051 if (start
== NULL
&& end
== NULL
)
16054 e
->ref
= ref
->next
;
16056 e
->ref
->next
= ref
->next
;
16061 ref
->type
= REF_SUBSTRING
;
16063 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16065 ref
->u
.ss
.start
= start
;
16066 if (end
== NULL
&& e
->ts
.u
.cl
)
16067 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16068 ref
->u
.ss
.end
= end
;
16069 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16076 /* Any further ref is an error. */
16079 gcc_assert (ref
->type
== REF_ARRAY
);
16080 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16086 if (!gfc_resolve_expr (e
))
16089 sym
= e
->symtree
->n
.sym
;
16091 if (sym
->attr
.is_protected
)
16093 if (cnt_protected
> 0 && cnt_protected
!= object
)
16095 gfc_error ("Either all or none of the objects in the "
16096 "EQUIVALENCE set at %L shall have the "
16097 "PROTECTED attribute",
16102 /* Shall not equivalence common block variables in a PURE procedure. */
16103 if (sym
->ns
->proc_name
16104 && sym
->ns
->proc_name
->attr
.pure
16105 && sym
->attr
.in_common
)
16107 /* Need to check for symbols that may have entered the pure
16108 procedure via a USE statement. */
16109 bool saw_sym
= false;
16110 if (sym
->ns
->use_stmts
)
16113 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16114 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16120 gfc_error ("COMMON block member %qs at %L cannot be an "
16121 "EQUIVALENCE object in the pure procedure %qs",
16122 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16126 /* Shall not be a named constant. */
16127 if (e
->expr_type
== EXPR_CONSTANT
)
16129 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16130 "object", sym
->name
, &e
->where
);
16134 if (e
->ts
.type
== BT_DERIVED
16135 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16138 /* Check that the types correspond correctly:
16140 A numeric sequence structure may be equivalenced to another sequence
16141 structure, an object of default integer type, default real type, double
16142 precision real type, default logical type such that components of the
16143 structure ultimately only become associated to objects of the same
16144 kind. A character sequence structure may be equivalenced to an object
16145 of default character kind or another character sequence structure.
16146 Other objects may be equivalenced only to objects of the same type and
16147 kind parameters. */
16149 /* Identical types are unconditionally OK. */
16150 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16151 goto identical_types
;
16153 last_eq_type
= sequence_type (*last_ts
);
16154 eq_type
= sequence_type (sym
->ts
);
16156 /* Since the pair of objects is not of the same type, mixed or
16157 non-default sequences can be rejected. */
16159 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16160 "statement at %L with different type objects";
16162 && last_eq_type
== SEQ_MIXED
16163 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16164 || (eq_type
== SEQ_MIXED
16165 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16168 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16169 "statement at %L with objects of different type";
16171 && last_eq_type
== SEQ_NONDEFAULT
16172 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16173 || (eq_type
== SEQ_NONDEFAULT
16174 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16177 msg
="Non-CHARACTER object %qs in default CHARACTER "
16178 "EQUIVALENCE statement at %L";
16179 if (last_eq_type
== SEQ_CHARACTER
16180 && eq_type
!= SEQ_CHARACTER
16181 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16184 msg
="Non-NUMERIC object %qs in default NUMERIC "
16185 "EQUIVALENCE statement at %L";
16186 if (last_eq_type
== SEQ_NUMERIC
16187 && eq_type
!= SEQ_NUMERIC
16188 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16193 last_where
= &e
->where
;
16198 /* Shall not be an automatic array. */
16199 if (e
->ref
->type
== REF_ARRAY
16200 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16202 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16203 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16210 /* Shall not be a structure component. */
16211 if (r
->type
== REF_COMPONENT
)
16213 gfc_error ("Structure component %qs at %L cannot be an "
16214 "EQUIVALENCE object",
16215 r
->u
.c
.component
->name
, &e
->where
);
16219 /* A substring shall not have length zero. */
16220 if (r
->type
== REF_SUBSTRING
)
16222 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16224 gfc_error ("Substring at %L has length zero",
16225 &r
->u
.ss
.start
->where
);
16235 /* Function called by resolve_fntype to flag other symbol used in the
16236 length type parameter specification of function resuls. */
16239 flag_fn_result_spec (gfc_expr
*expr
,
16241 int *f ATTRIBUTE_UNUSED
)
16246 if (expr
->expr_type
== EXPR_VARIABLE
)
16248 s
= expr
->symtree
->n
.sym
;
16249 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16255 gfc_error ("Self reference in character length expression "
16256 "for %qs at %L", sym
->name
, &expr
->where
);
16260 if (!s
->fn_result_spec
16261 && s
->attr
.flavor
== FL_PARAMETER
)
16263 /* Function contained in a module.... */
16264 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16267 s
->fn_result_spec
= 1;
16268 /* Make sure that this symbol is translated as a module
16270 st
= gfc_get_unique_symtree (ns
);
16274 /* ... which is use associated and called. */
16275 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16277 /* External function matched with an interface. */
16280 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16281 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16282 && s
->ns
->proc_name
->attr
.function
))
16283 s
->fn_result_spec
= 1;
16290 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16293 resolve_fntype (gfc_namespace
*ns
)
16295 gfc_entry_list
*el
;
16298 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16301 /* If there are any entries, ns->proc_name is the entry master
16302 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16304 sym
= ns
->entries
->sym
;
16306 sym
= ns
->proc_name
;
16307 if (sym
->result
== sym
16308 && sym
->ts
.type
== BT_UNKNOWN
16309 && !gfc_set_default_type (sym
, 0, NULL
)
16310 && !sym
->attr
.untyped
)
16312 gfc_error ("Function %qs at %L has no IMPLICIT type",
16313 sym
->name
, &sym
->declared_at
);
16314 sym
->attr
.untyped
= 1;
16317 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16318 && !sym
->attr
.contained
16319 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16320 && gfc_check_symbol_access (sym
))
16322 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16323 "%L of PRIVATE type %qs", sym
->name
,
16324 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16328 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16330 if (el
->sym
->result
== el
->sym
16331 && el
->sym
->ts
.type
== BT_UNKNOWN
16332 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16333 && !el
->sym
->attr
.untyped
)
16335 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16336 el
->sym
->name
, &el
->sym
->declared_at
);
16337 el
->sym
->attr
.untyped
= 1;
16341 if (sym
->ts
.type
== BT_CHARACTER
)
16342 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16346 /* 12.3.2.1.1 Defined operators. */
16349 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16351 gfc_formal_arglist
*formal
;
16353 if (!sym
->attr
.function
)
16355 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16356 sym
->name
, &where
);
16360 if (sym
->ts
.type
== BT_CHARACTER
16361 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16362 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16363 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16365 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16366 "character length", sym
->name
, &where
);
16370 formal
= gfc_sym_get_dummy_args (sym
);
16371 if (!formal
|| !formal
->sym
)
16373 gfc_error ("User operator procedure %qs at %L must have at least "
16374 "one argument", sym
->name
, &where
);
16378 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16380 gfc_error ("First argument of operator interface at %L must be "
16381 "INTENT(IN)", &where
);
16385 if (formal
->sym
->attr
.optional
)
16387 gfc_error ("First argument of operator interface at %L cannot be "
16388 "optional", &where
);
16392 formal
= formal
->next
;
16393 if (!formal
|| !formal
->sym
)
16396 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16398 gfc_error ("Second argument of operator interface at %L must be "
16399 "INTENT(IN)", &where
);
16403 if (formal
->sym
->attr
.optional
)
16405 gfc_error ("Second argument of operator interface at %L cannot be "
16406 "optional", &where
);
16412 gfc_error ("Operator interface at %L must have, at most, two "
16413 "arguments", &where
);
16421 gfc_resolve_uops (gfc_symtree
*symtree
)
16423 gfc_interface
*itr
;
16425 if (symtree
== NULL
)
16428 gfc_resolve_uops (symtree
->left
);
16429 gfc_resolve_uops (symtree
->right
);
16431 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16432 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16436 /* Examine all of the expressions associated with a program unit,
16437 assign types to all intermediate expressions, make sure that all
16438 assignments are to compatible types and figure out which names
16439 refer to which functions or subroutines. It doesn't check code
16440 block, which is handled by gfc_resolve_code. */
16443 resolve_types (gfc_namespace
*ns
)
16449 gfc_namespace
* old_ns
= gfc_current_ns
;
16451 if (ns
->types_resolved
)
16454 /* Check that all IMPLICIT types are ok. */
16455 if (!ns
->seen_implicit_none
)
16458 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16459 if (ns
->set_flag
[letter
]
16460 && !resolve_typespec_used (&ns
->default_type
[letter
],
16461 &ns
->implicit_loc
[letter
], NULL
))
16465 gfc_current_ns
= ns
;
16467 resolve_entries (ns
);
16469 resolve_common_vars (&ns
->blank_common
, false);
16470 resolve_common_blocks (ns
->common_root
);
16472 resolve_contained_functions (ns
);
16474 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16475 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16476 resolve_formal_arglist (ns
->proc_name
);
16478 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16480 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16481 resolve_charlen (cl
);
16483 gfc_traverse_ns (ns
, resolve_symbol
);
16485 resolve_fntype (ns
);
16487 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16489 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16490 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16491 "also be PURE", n
->proc_name
->name
,
16492 &n
->proc_name
->declared_at
);
16498 gfc_do_concurrent_flag
= 0;
16499 gfc_check_interfaces (ns
);
16501 gfc_traverse_ns (ns
, resolve_values
);
16507 for (d
= ns
->data
; d
; d
= d
->next
)
16511 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16513 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16515 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16516 resolve_equivalence (eq
);
16518 /* Warn about unused labels. */
16519 if (warn_unused_label
)
16520 warn_unused_fortran_label (ns
->st_labels
);
16522 gfc_resolve_uops (ns
->uop_root
);
16524 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16526 gfc_resolve_omp_declare_simd (ns
);
16528 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16530 ns
->types_resolved
= 1;
16532 gfc_current_ns
= old_ns
;
16536 /* Call gfc_resolve_code recursively. */
16539 resolve_codes (gfc_namespace
*ns
)
16542 bitmap_obstack old_obstack
;
16544 if (ns
->resolved
== 1)
16547 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16550 gfc_current_ns
= ns
;
16552 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16553 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16556 /* Set to an out of range value. */
16557 current_entry_id
= -1;
16559 old_obstack
= labels_obstack
;
16560 bitmap_obstack_initialize (&labels_obstack
);
16562 gfc_resolve_oacc_declare (ns
);
16563 gfc_resolve_omp_local_vars (ns
);
16564 gfc_resolve_code (ns
->code
, ns
);
16566 bitmap_obstack_release (&labels_obstack
);
16567 labels_obstack
= old_obstack
;
16571 /* This function is called after a complete program unit has been compiled.
16572 Its purpose is to examine all of the expressions associated with a program
16573 unit, assign types to all intermediate expressions, make sure that all
16574 assignments are to compatible types and figure out which names refer to
16575 which functions or subroutines. */
16578 gfc_resolve (gfc_namespace
*ns
)
16580 gfc_namespace
*old_ns
;
16581 code_stack
*old_cs_base
;
16582 struct gfc_omp_saved_state old_omp_state
;
16588 old_ns
= gfc_current_ns
;
16589 old_cs_base
= cs_base
;
16591 /* As gfc_resolve can be called during resolution of an OpenMP construct
16592 body, we should clear any state associated to it, so that say NS's
16593 DO loops are not interpreted as OpenMP loops. */
16594 if (!ns
->construct_entities
)
16595 gfc_omp_save_and_clear_state (&old_omp_state
);
16597 resolve_types (ns
);
16598 component_assignment_level
= 0;
16599 resolve_codes (ns
);
16601 gfc_current_ns
= old_ns
;
16602 cs_base
= old_cs_base
;
16605 gfc_run_passes (ns
);
16607 if (!ns
->construct_entities
)
16608 gfc_omp_restore_state (&old_omp_state
);