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 2008 Draft Standard, page 535, C418, on type-param-value
605 type, lists the only ways a character length value of * can be used:
606 dummy arguments of procedures, named constants, function results and
607 in allocate statements if the allocate_object is an assumed length dummy
608 in external functions. Internal function results and results of module
609 procedures are not on this list, ergo, not permitted. */
611 if (sym
->result
->ts
.type
== BT_CHARACTER
)
613 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
614 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
616 /* See if this is a module-procedure and adapt error message
619 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
620 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
622 gfc_error (module_proc
623 ? G_("Character-valued module procedure %qs at %L"
624 " must not be assumed length")
625 : G_("Character-valued internal function %qs at %L"
626 " must not be assumed length"),
627 sym
->name
, &sym
->declared_at
);
633 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
634 introduce duplicates. */
637 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
639 gfc_formal_arglist
*f
, *new_arglist
;
642 for (; new_args
!= NULL
; new_args
= new_args
->next
)
644 new_sym
= new_args
->sym
;
645 /* See if this arg is already in the formal argument list. */
646 for (f
= proc
->formal
; f
; f
= f
->next
)
648 if (new_sym
== f
->sym
)
655 /* Add a new argument. Argument order is not important. */
656 new_arglist
= gfc_get_formal_arglist ();
657 new_arglist
->sym
= new_sym
;
658 new_arglist
->next
= proc
->formal
;
659 proc
->formal
= new_arglist
;
664 /* Flag the arguments that are not present in all entries. */
667 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
669 gfc_formal_arglist
*f
, *head
;
672 for (f
= proc
->formal
; f
; f
= f
->next
)
677 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
679 if (new_args
->sym
== f
->sym
)
686 f
->sym
->attr
.not_always_present
= 1;
691 /* Resolve alternate entry points. If a symbol has multiple entry points we
692 create a new master symbol for the main routine, and turn the existing
693 symbol into an entry point. */
696 resolve_entries (gfc_namespace
*ns
)
698 gfc_namespace
*old_ns
;
702 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
703 static int master_count
= 0;
705 if (ns
->proc_name
== NULL
)
708 /* No need to do anything if this procedure doesn't have alternate entry
713 /* We may already have resolved alternate entry points. */
714 if (ns
->proc_name
->attr
.entry_master
)
717 /* If this isn't a procedure something has gone horribly wrong. */
718 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
720 /* Remember the current namespace. */
721 old_ns
= gfc_current_ns
;
725 /* Add the main entry point to the list of entry points. */
726 el
= gfc_get_entry_list ();
727 el
->sym
= ns
->proc_name
;
729 el
->next
= ns
->entries
;
731 ns
->proc_name
->attr
.entry
= 1;
733 /* If it is a module function, it needs to be in the right namespace
734 so that gfc_get_fake_result_decl can gather up the results. The
735 need for this arose in get_proc_name, where these beasts were
736 left in their own namespace, to keep prior references linked to
737 the entry declaration.*/
738 if (ns
->proc_name
->attr
.function
739 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
742 /* Do the same for entries where the master is not a module
743 procedure. These are retained in the module namespace because
744 of the module procedure declaration. */
745 for (el
= el
->next
; el
; el
= el
->next
)
746 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
747 && el
->sym
->attr
.mod_proc
)
751 /* Add an entry statement for it. */
752 c
= gfc_get_code (EXEC_ENTRY
);
757 /* Create a new symbol for the master function. */
758 /* Give the internal function a unique name (within this file).
759 Also include the function name so the user has some hope of figuring
760 out what is going on. */
761 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
762 master_count
++, ns
->proc_name
->name
);
763 gfc_get_ha_symbol (name
, &proc
);
764 gcc_assert (proc
!= NULL
);
766 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
767 if (ns
->proc_name
->attr
.subroutine
)
768 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
772 gfc_typespec
*ts
, *fts
;
773 gfc_array_spec
*as
, *fas
;
774 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
776 fas
= ns
->entries
->sym
->as
;
777 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
778 fts
= &ns
->entries
->sym
->result
->ts
;
779 if (fts
->type
== BT_UNKNOWN
)
780 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
781 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
783 ts
= &el
->sym
->result
->ts
;
785 as
= as
? as
: el
->sym
->result
->as
;
786 if (ts
->type
== BT_UNKNOWN
)
787 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
789 if (! gfc_compare_types (ts
, fts
)
790 || (el
->sym
->result
->attr
.dimension
791 != ns
->entries
->sym
->result
->attr
.dimension
)
792 || (el
->sym
->result
->attr
.pointer
793 != ns
->entries
->sym
->result
->attr
.pointer
))
795 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
796 && gfc_compare_array_spec (as
, fas
) == 0)
797 gfc_error ("Function %s at %L has entries with mismatched "
798 "array specifications", ns
->entries
->sym
->name
,
799 &ns
->entries
->sym
->declared_at
);
800 /* The characteristics need to match and thus both need to have
801 the same string length, i.e. both len=*, or both len=4.
802 Having both len=<variable> is also possible, but difficult to
803 check at compile time. */
804 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
805 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
806 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
808 && ts
->u
.cl
->length
->expr_type
809 != fts
->u
.cl
->length
->expr_type
)
811 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
812 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
813 fts
->u
.cl
->length
->value
.integer
) != 0)))
814 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
815 "entries returning variables of different "
816 "string lengths", ns
->entries
->sym
->name
,
817 &ns
->entries
->sym
->declared_at
);
822 sym
= ns
->entries
->sym
->result
;
823 /* All result types the same. */
825 if (sym
->attr
.dimension
)
826 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
827 if (sym
->attr
.pointer
)
828 gfc_add_pointer (&proc
->attr
, NULL
);
832 /* Otherwise the result will be passed through a union by
834 proc
->attr
.mixed_entry_master
= 1;
835 for (el
= ns
->entries
; el
; el
= el
->next
)
837 sym
= el
->sym
->result
;
838 if (sym
->attr
.dimension
)
840 if (el
== ns
->entries
)
841 gfc_error ("FUNCTION result %s can't be an array in "
842 "FUNCTION %s at %L", sym
->name
,
843 ns
->entries
->sym
->name
, &sym
->declared_at
);
845 gfc_error ("ENTRY result %s can't be an array in "
846 "FUNCTION %s at %L", sym
->name
,
847 ns
->entries
->sym
->name
, &sym
->declared_at
);
849 else if (sym
->attr
.pointer
)
851 if (el
== ns
->entries
)
852 gfc_error ("FUNCTION result %s can't be a POINTER in "
853 "FUNCTION %s at %L", sym
->name
,
854 ns
->entries
->sym
->name
, &sym
->declared_at
);
856 gfc_error ("ENTRY result %s can't be a POINTER in "
857 "FUNCTION %s at %L", sym
->name
,
858 ns
->entries
->sym
->name
, &sym
->declared_at
);
863 if (ts
->type
== BT_UNKNOWN
)
864 ts
= gfc_get_default_type (sym
->name
, NULL
);
868 if (ts
->kind
== gfc_default_integer_kind
)
872 if (ts
->kind
== gfc_default_real_kind
873 || ts
->kind
== gfc_default_double_kind
)
877 if (ts
->kind
== gfc_default_complex_kind
)
881 if (ts
->kind
== gfc_default_logical_kind
)
885 /* We will issue error elsewhere. */
893 if (el
== ns
->entries
)
894 gfc_error ("FUNCTION result %s can't be of type %s "
895 "in FUNCTION %s at %L", sym
->name
,
896 gfc_typename (ts
), ns
->entries
->sym
->name
,
899 gfc_error ("ENTRY result %s can't be of type %s "
900 "in FUNCTION %s at %L", sym
->name
,
901 gfc_typename (ts
), ns
->entries
->sym
->name
,
908 proc
->attr
.access
= ACCESS_PRIVATE
;
909 proc
->attr
.entry_master
= 1;
911 /* Merge all the entry point arguments. */
912 for (el
= ns
->entries
; el
; el
= el
->next
)
913 merge_argument_lists (proc
, el
->sym
->formal
);
915 /* Check the master formal arguments for any that are not
916 present in all entry points. */
917 for (el
= ns
->entries
; el
; el
= el
->next
)
918 check_argument_lists (proc
, el
->sym
->formal
);
920 /* Use the master function for the function body. */
921 ns
->proc_name
= proc
;
923 /* Finalize the new symbols. */
924 gfc_commit_symbols ();
926 /* Restore the original namespace. */
927 gfc_current_ns
= old_ns
;
931 /* Resolve common variables. */
933 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
935 gfc_symbol
*csym
= common_block
->head
;
937 for (; csym
; csym
= csym
->common_next
)
939 /* gfc_add_in_common may have been called before, but the reported errors
940 have been ignored to continue parsing.
941 We do the checks again here. */
942 if (!csym
->attr
.use_assoc
)
943 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
945 if (csym
->value
|| csym
->attr
.data
)
947 if (!csym
->ns
->is_block_data
)
948 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
949 "but only in BLOCK DATA initialization is "
950 "allowed", csym
->name
, &csym
->declared_at
);
951 else if (!named_common
)
952 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
953 "in a blank COMMON but initialization is only "
954 "allowed in named common blocks", csym
->name
,
958 if (UNLIMITED_POLY (csym
))
959 gfc_error_now ("%qs in cannot appear in COMMON at %L "
960 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
962 if (csym
->ts
.type
!= BT_DERIVED
)
965 if (!(csym
->ts
.u
.derived
->attr
.sequence
966 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
967 gfc_error_now ("Derived type variable %qs in COMMON at %L "
968 "has neither the SEQUENCE nor the BIND(C) "
969 "attribute", csym
->name
, &csym
->declared_at
);
970 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
971 gfc_error_now ("Derived type variable %qs in COMMON at %L "
972 "has an ultimate component that is "
973 "allocatable", csym
->name
, &csym
->declared_at
);
974 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
975 gfc_error_now ("Derived type variable %qs in COMMON at %L "
976 "may not have default initializer", csym
->name
,
979 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
980 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
984 /* Resolve common blocks. */
986 resolve_common_blocks (gfc_symtree
*common_root
)
991 if (common_root
== NULL
)
994 if (common_root
->left
)
995 resolve_common_blocks (common_root
->left
);
996 if (common_root
->right
)
997 resolve_common_blocks (common_root
->right
);
999 resolve_common_vars (common_root
->n
.common
, true);
1001 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
1002 &common_root
->n
.common
->where
))
1005 /* The common name is a global name - in Fortran 2003 also if it has a
1006 C binding name, since Fortran 2008 only the C binding name is a global
1008 if (!common_root
->n
.common
->binding_label
1009 || gfc_notification_std (GFC_STD_F2008
))
1011 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1012 common_root
->n
.common
->name
);
1014 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1015 && gsym
->type
== GSYM_COMMON
1016 && ((common_root
->n
.common
->binding_label
1017 && (!gsym
->binding_label
1018 || strcmp (common_root
->n
.common
->binding_label
,
1019 gsym
->binding_label
) != 0))
1020 || (!common_root
->n
.common
->binding_label
1021 && gsym
->binding_label
)))
1023 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1024 "identifier and must thus have the same binding name "
1025 "as the same-named COMMON block at %L: %s vs %s",
1026 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1028 common_root
->n
.common
->binding_label
1029 ? common_root
->n
.common
->binding_label
: "(blank)",
1030 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1034 if (gsym
&& gsym
->type
!= GSYM_COMMON
1035 && !common_root
->n
.common
->binding_label
)
1037 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1039 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1043 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1045 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1046 "%L sharing the identifier with global non-COMMON-block "
1047 "entity at %L", common_root
->n
.common
->name
,
1048 &common_root
->n
.common
->where
, &gsym
->where
);
1053 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1054 gsym
->type
= GSYM_COMMON
;
1055 gsym
->where
= common_root
->n
.common
->where
;
1061 if (common_root
->n
.common
->binding_label
)
1063 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1064 common_root
->n
.common
->binding_label
);
1065 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1067 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1068 "global identifier as entity at %L",
1069 &common_root
->n
.common
->where
,
1070 common_root
->n
.common
->binding_label
, &gsym
->where
);
1075 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1076 gsym
->type
= GSYM_COMMON
;
1077 gsym
->where
= common_root
->n
.common
->where
;
1083 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1087 if (sym
->attr
.flavor
== FL_PARAMETER
)
1088 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1089 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1091 if (sym
->attr
.external
)
1092 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1093 sym
->name
, &common_root
->n
.common
->where
);
1095 if (sym
->attr
.intrinsic
)
1096 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1097 sym
->name
, &common_root
->n
.common
->where
);
1098 else if (sym
->attr
.result
1099 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1100 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1101 "that is also a function result", sym
->name
,
1102 &common_root
->n
.common
->where
);
1103 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1104 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1105 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1106 "that is also a global procedure", sym
->name
,
1107 &common_root
->n
.common
->where
);
1111 /* Resolve contained function types. Because contained functions can call one
1112 another, they have to be worked out before any of the contained procedures
1115 The good news is that if a function doesn't already have a type, the only
1116 way it can get one is through an IMPLICIT type or a RESULT variable, because
1117 by definition contained functions are contained namespace they're contained
1118 in, not in a sibling or parent namespace. */
1121 resolve_contained_functions (gfc_namespace
*ns
)
1123 gfc_namespace
*child
;
1126 resolve_formal_arglists (ns
);
1128 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1130 /* Resolve alternate entry points first. */
1131 resolve_entries (child
);
1133 /* Then check function return types. */
1134 resolve_contained_fntype (child
->proc_name
, child
);
1135 for (el
= child
->entries
; el
; el
= el
->next
)
1136 resolve_contained_fntype (el
->sym
, child
);
1142 /* A Parameterized Derived Type constructor must contain values for
1143 the PDT KIND parameters or they must have a default initializer.
1144 Go through the constructor picking out the KIND expressions,
1145 storing them in 'param_list' and then call gfc_get_pdt_instance
1146 to obtain the PDT instance. */
1148 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1151 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1153 param
= gfc_get_actual_arglist ();
1155 param_list
= param_tail
= param
;
1158 param_tail
->next
= param
;
1159 param_tail
= param_tail
->next
;
1162 param_tail
->name
= c
->name
;
1164 param_tail
->expr
= gfc_copy_expr (expr
);
1165 else if (c
->initializer
)
1166 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1169 param_tail
->spec_type
= SPEC_ASSUMED
;
1170 if (c
->attr
.pdt_kind
)
1172 gfc_error ("The KIND parameter %qs in the PDT constructor "
1173 "at %C has no value", param
->name
);
1182 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1183 gfc_symbol
*derived
)
1185 gfc_constructor
*cons
= NULL
;
1186 gfc_component
*comp
;
1189 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1190 cons
= gfc_constructor_first (expr
->value
.constructor
);
1195 comp
= derived
->components
;
1197 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1200 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1201 && comp
->ts
.type
== BT_DERIVED
)
1203 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1207 else if (comp
->ts
.type
== BT_DERIVED
)
1209 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1213 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1214 && derived
->attr
.pdt_template
)
1216 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1225 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1226 static bool resolve_fl_struct (gfc_symbol
*sym
);
1229 /* Resolve all of the elements of a structure constructor and make sure that
1230 the types are correct. The 'init' flag indicates that the given
1231 constructor is an initializer. */
1234 resolve_structure_cons (gfc_expr
*expr
, int init
)
1236 gfc_constructor
*cons
;
1237 gfc_component
*comp
;
1243 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1245 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1246 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1248 resolve_fl_struct (expr
->ts
.u
.derived
);
1250 /* If this is a Parameterized Derived Type template, find the
1251 instance corresponding to the PDT kind parameters. */
1252 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1255 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1258 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1260 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1263 gfc_free_actual_arglist (param_list
);
1265 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1270 cons
= gfc_constructor_first (expr
->value
.constructor
);
1272 /* A constructor may have references if it is the result of substituting a
1273 parameter variable. In this case we just pull out the component we
1276 comp
= expr
->ref
->u
.c
.sym
->components
;
1278 comp
= expr
->ts
.u
.derived
->components
;
1280 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1287 /* Unions use an EXPR_NULL contrived expression to tell the translation
1288 phase to generate an initializer of the appropriate length.
1290 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1293 if (!gfc_resolve_expr (cons
->expr
))
1299 rank
= comp
->as
? comp
->as
->rank
: 0;
1300 if (comp
->ts
.type
== BT_CLASS
1301 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1302 && CLASS_DATA (comp
)->as
)
1303 rank
= CLASS_DATA (comp
)->as
->rank
;
1305 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1306 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1308 gfc_error ("The rank of the element in the structure "
1309 "constructor at %L does not match that of the "
1310 "component (%d/%d)", &cons
->expr
->where
,
1311 cons
->expr
->rank
, rank
);
1315 /* If we don't have the right type, try to convert it. */
1317 if (!comp
->attr
.proc_pointer
&&
1318 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1320 if (strcmp (comp
->name
, "_extends") == 0)
1322 /* Can afford to be brutal with the _extends initializer.
1323 The derived type can get lost because it is PRIVATE
1324 but it is not usage constrained by the standard. */
1325 cons
->expr
->ts
= comp
->ts
;
1327 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1329 gfc_error ("The element in the structure constructor at %L, "
1330 "for pointer component %qs, is %s but should be %s",
1331 &cons
->expr
->where
, comp
->name
,
1332 gfc_basic_typename (cons
->expr
->ts
.type
),
1333 gfc_basic_typename (comp
->ts
.type
));
1338 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1344 /* For strings, the length of the constructor should be the same as
1345 the one of the structure, ensure this if the lengths are known at
1346 compile time and when we are dealing with PARAMETER or structure
1348 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1349 && comp
->ts
.u
.cl
->length
1350 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1351 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1352 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1353 && cons
->expr
->rank
!= 0
1354 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1355 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1357 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1358 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1360 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1361 to make use of the gfc_resolve_character_array_constructor
1362 machinery. The expression is later simplified away to
1363 an array of string literals. */
1364 gfc_expr
*para
= cons
->expr
;
1365 cons
->expr
= gfc_get_expr ();
1366 cons
->expr
->ts
= para
->ts
;
1367 cons
->expr
->where
= para
->where
;
1368 cons
->expr
->expr_type
= EXPR_ARRAY
;
1369 cons
->expr
->rank
= para
->rank
;
1370 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1371 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1372 para
, &cons
->expr
->where
);
1375 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1377 /* Rely on the cleanup of the namespace to deal correctly with
1378 the old charlen. (There was a block here that attempted to
1379 remove the charlen but broke the chain in so doing.) */
1380 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1381 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1382 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1383 gfc_resolve_character_array_constructor (cons
->expr
);
1387 if (cons
->expr
->expr_type
== EXPR_NULL
1388 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1389 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1390 || (comp
->ts
.type
== BT_CLASS
1391 && (CLASS_DATA (comp
)->attr
.class_pointer
1392 || CLASS_DATA (comp
)->attr
.allocatable
))))
1395 gfc_error ("The NULL in the structure constructor at %L is "
1396 "being applied to component %qs, which is neither "
1397 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1401 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1403 /* Check procedure pointer interface. */
1404 gfc_symbol
*s2
= NULL
;
1409 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1412 s2
= c2
->ts
.interface
;
1415 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1417 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1418 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1420 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1422 s2
= cons
->expr
->symtree
->n
.sym
;
1423 name
= cons
->expr
->symtree
->n
.sym
->name
;
1426 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1427 err
, sizeof (err
), NULL
, NULL
))
1429 gfc_error_opt (OPT_Wargument_mismatch
,
1430 "Interface mismatch for procedure-pointer "
1431 "component %qs in structure constructor at %L:"
1432 " %s", comp
->name
, &cons
->expr
->where
, err
);
1437 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1438 || cons
->expr
->expr_type
== EXPR_NULL
)
1441 a
= gfc_expr_attr (cons
->expr
);
1443 if (!a
.pointer
&& !a
.target
)
1446 gfc_error ("The element in the structure constructor at %L, "
1447 "for pointer component %qs should be a POINTER or "
1448 "a TARGET", &cons
->expr
->where
, comp
->name
);
1453 /* F08:C461. Additional checks for pointer initialization. */
1457 gfc_error ("Pointer initialization target at %L "
1458 "must not be ALLOCATABLE", &cons
->expr
->where
);
1463 gfc_error ("Pointer initialization target at %L "
1464 "must have the SAVE attribute", &cons
->expr
->where
);
1468 /* F2003, C1272 (3). */
1469 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1470 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1471 || gfc_is_coindexed (cons
->expr
));
1472 if (impure
&& gfc_pure (NULL
))
1475 gfc_error ("Invalid expression in the structure constructor for "
1476 "pointer component %qs at %L in PURE procedure",
1477 comp
->name
, &cons
->expr
->where
);
1481 gfc_unset_implicit_pure (NULL
);
1488 /****************** Expression name resolution ******************/
1490 /* Returns 0 if a symbol was not declared with a type or
1491 attribute declaration statement, nonzero otherwise. */
1494 was_declared (gfc_symbol
*sym
)
1500 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1503 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1504 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1505 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1506 || a
.asynchronous
|| a
.codimension
)
1513 /* Determine if a symbol is generic or not. */
1516 generic_sym (gfc_symbol
*sym
)
1520 if (sym
->attr
.generic
||
1521 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1524 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1527 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1534 return generic_sym (s
);
1541 /* Determine if a symbol is specific or not. */
1544 specific_sym (gfc_symbol
*sym
)
1548 if (sym
->attr
.if_source
== IFSRC_IFBODY
1549 || sym
->attr
.proc
== PROC_MODULE
1550 || sym
->attr
.proc
== PROC_INTERNAL
1551 || sym
->attr
.proc
== PROC_ST_FUNCTION
1552 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1553 || sym
->attr
.external
)
1556 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1559 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1561 return (s
== NULL
) ? 0 : specific_sym (s
);
1565 /* Figure out if the procedure is specific, generic or unknown. */
1568 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1571 procedure_kind (gfc_symbol
*sym
)
1573 if (generic_sym (sym
))
1574 return PTYPE_GENERIC
;
1576 if (specific_sym (sym
))
1577 return PTYPE_SPECIFIC
;
1579 return PTYPE_UNKNOWN
;
1582 /* Check references to assumed size arrays. The flag need_full_assumed_size
1583 is nonzero when matching actual arguments. */
1585 static int need_full_assumed_size
= 0;
1588 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1590 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1593 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1594 What should it be? */
1595 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1596 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1597 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1599 gfc_error ("The upper bound in the last dimension must "
1600 "appear in the reference to the assumed size "
1601 "array %qs at %L", sym
->name
, &e
->where
);
1608 /* Look for bad assumed size array references in argument expressions
1609 of elemental and array valued intrinsic procedures. Since this is
1610 called from procedure resolution functions, it only recurses at
1614 resolve_assumed_size_actual (gfc_expr
*e
)
1619 switch (e
->expr_type
)
1622 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1627 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1628 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1639 /* Check a generic procedure, passed as an actual argument, to see if
1640 there is a matching specific name. If none, it is an error, and if
1641 more than one, the reference is ambiguous. */
1643 count_specific_procs (gfc_expr
*e
)
1650 sym
= e
->symtree
->n
.sym
;
1652 for (p
= sym
->generic
; p
; p
= p
->next
)
1653 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1655 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1661 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1665 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1666 "argument at %L", sym
->name
, &e
->where
);
1672 /* See if a call to sym could possibly be a not allowed RECURSION because of
1673 a missing RECURSIVE declaration. This means that either sym is the current
1674 context itself, or sym is the parent of a contained procedure calling its
1675 non-RECURSIVE containing procedure.
1676 This also works if sym is an ENTRY. */
1679 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1681 gfc_symbol
* proc_sym
;
1682 gfc_symbol
* context_proc
;
1683 gfc_namespace
* real_context
;
1685 if (sym
->attr
.flavor
== FL_PROGRAM
1686 || gfc_fl_struct (sym
->attr
.flavor
))
1689 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1691 /* If we've got an ENTRY, find real procedure. */
1692 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1693 proc_sym
= sym
->ns
->entries
->sym
;
1697 /* If sym is RECURSIVE, all is well of course. */
1698 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1701 /* Find the context procedure's "real" symbol if it has entries.
1702 We look for a procedure symbol, so recurse on the parents if we don't
1703 find one (like in case of a BLOCK construct). */
1704 for (real_context
= context
; ; real_context
= real_context
->parent
)
1706 /* We should find something, eventually! */
1707 gcc_assert (real_context
);
1709 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1710 : real_context
->proc_name
);
1712 /* In some special cases, there may not be a proc_name, like for this
1714 real(bad_kind()) function foo () ...
1715 when checking the call to bad_kind ().
1716 In these cases, we simply return here and assume that the
1721 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1725 /* A call from sym's body to itself is recursion, of course. */
1726 if (context_proc
== proc_sym
)
1729 /* The same is true if context is a contained procedure and sym the
1731 if (context_proc
->attr
.contained
)
1733 gfc_symbol
* parent_proc
;
1735 gcc_assert (context
->parent
);
1736 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1737 : context
->parent
->proc_name
);
1739 if (parent_proc
== proc_sym
)
1747 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1748 its typespec and formal argument list. */
1751 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1753 gfc_intrinsic_sym
* isym
= NULL
;
1759 /* Already resolved. */
1760 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1763 /* We already know this one is an intrinsic, so we don't call
1764 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1765 gfc_find_subroutine directly to check whether it is a function or
1768 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1770 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1771 isym
= gfc_intrinsic_subroutine_by_id (id
);
1773 else if (sym
->intmod_sym_id
)
1775 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1776 isym
= gfc_intrinsic_function_by_id (id
);
1778 else if (!sym
->attr
.subroutine
)
1779 isym
= gfc_find_function (sym
->name
);
1781 if (isym
&& !sym
->attr
.subroutine
)
1783 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1784 && !sym
->attr
.implicit_type
)
1785 gfc_warning (OPT_Wsurprising
,
1786 "Type specified for intrinsic function %qs at %L is"
1787 " ignored", sym
->name
, &sym
->declared_at
);
1789 if (!sym
->attr
.function
&&
1790 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1795 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1797 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1799 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1800 " specifier", sym
->name
, &sym
->declared_at
);
1804 if (!sym
->attr
.subroutine
&&
1805 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1810 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1815 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1817 sym
->attr
.pure
= isym
->pure
;
1818 sym
->attr
.elemental
= isym
->elemental
;
1820 /* Check it is actually available in the standard settings. */
1821 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1823 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1824 "available in the current standard settings but %s. Use "
1825 "an appropriate %<-std=*%> option or enable "
1826 "%<-fall-intrinsics%> in order to use it.",
1827 sym
->name
, &sym
->declared_at
, symstd
);
1835 /* Resolve a procedure expression, like passing it to a called procedure or as
1836 RHS for a procedure pointer assignment. */
1839 resolve_procedure_expression (gfc_expr
* expr
)
1843 if (expr
->expr_type
!= EXPR_VARIABLE
)
1845 gcc_assert (expr
->symtree
);
1847 sym
= expr
->symtree
->n
.sym
;
1849 if (sym
->attr
.intrinsic
)
1850 gfc_resolve_intrinsic (sym
, &expr
->where
);
1852 if (sym
->attr
.flavor
!= FL_PROCEDURE
1853 || (sym
->attr
.function
&& sym
->result
== sym
))
1856 /* A non-RECURSIVE procedure that is used as procedure expression within its
1857 own body is in danger of being called recursively. */
1858 if (is_illegal_recursion (sym
, gfc_current_ns
))
1859 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1860 " itself recursively. Declare it RECURSIVE or use"
1861 " %<-frecursive%>", sym
->name
, &expr
->where
);
1867 /* Resolve an actual argument list. Most of the time, this is just
1868 resolving the expressions in the list.
1869 The exception is that we sometimes have to decide whether arguments
1870 that look like procedure arguments are really simple variable
1874 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1875 bool no_formal_args
)
1878 gfc_symtree
*parent_st
;
1880 gfc_component
*comp
;
1881 int save_need_full_assumed_size
;
1882 bool return_value
= false;
1883 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1886 first_actual_arg
= true;
1888 for (; arg
; arg
= arg
->next
)
1893 /* Check the label is a valid branching target. */
1896 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1898 gfc_error ("Label %d referenced at %L is never defined",
1899 arg
->label
->value
, &arg
->label
->where
);
1903 first_actual_arg
= false;
1907 if (e
->expr_type
== EXPR_VARIABLE
1908 && e
->symtree
->n
.sym
->attr
.generic
1910 && count_specific_procs (e
) != 1)
1913 if (e
->ts
.type
!= BT_PROCEDURE
)
1915 save_need_full_assumed_size
= need_full_assumed_size
;
1916 if (e
->expr_type
!= EXPR_VARIABLE
)
1917 need_full_assumed_size
= 0;
1918 if (!gfc_resolve_expr (e
))
1920 need_full_assumed_size
= save_need_full_assumed_size
;
1924 /* See if the expression node should really be a variable reference. */
1926 sym
= e
->symtree
->n
.sym
;
1928 if (sym
->attr
.flavor
== FL_PROCEDURE
1929 || sym
->attr
.intrinsic
1930 || sym
->attr
.external
)
1934 /* If a procedure is not already determined to be something else
1935 check if it is intrinsic. */
1936 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1937 sym
->attr
.intrinsic
= 1;
1939 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1941 gfc_error ("Statement function %qs at %L is not allowed as an "
1942 "actual argument", sym
->name
, &e
->where
);
1945 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1946 sym
->attr
.subroutine
);
1947 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1949 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1950 "actual argument", sym
->name
, &e
->where
);
1953 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1954 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1956 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1957 " used as actual argument at %L",
1958 sym
->name
, &e
->where
))
1962 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1964 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1965 "allowed as an actual argument at %L", sym
->name
,
1969 /* Check if a generic interface has a specific procedure
1970 with the same name before emitting an error. */
1971 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1974 /* Just in case a specific was found for the expression. */
1975 sym
= e
->symtree
->n
.sym
;
1977 /* If the symbol is the function that names the current (or
1978 parent) scope, then we really have a variable reference. */
1980 if (gfc_is_function_return_value (sym
, sym
->ns
))
1983 /* If all else fails, see if we have a specific intrinsic. */
1984 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1986 gfc_intrinsic_sym
*isym
;
1988 isym
= gfc_find_function (sym
->name
);
1989 if (isym
== NULL
|| !isym
->specific
)
1991 gfc_error ("Unable to find a specific INTRINSIC procedure "
1992 "for the reference %qs at %L", sym
->name
,
1997 sym
->attr
.intrinsic
= 1;
1998 sym
->attr
.function
= 1;
2001 if (!gfc_resolve_expr (e
))
2006 /* See if the name is a module procedure in a parent unit. */
2008 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2011 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2013 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2017 if (parent_st
== NULL
)
2020 sym
= parent_st
->n
.sym
;
2021 e
->symtree
= parent_st
; /* Point to the right thing. */
2023 if (sym
->attr
.flavor
== FL_PROCEDURE
2024 || sym
->attr
.intrinsic
2025 || sym
->attr
.external
)
2027 if (!gfc_resolve_expr (e
))
2033 e
->expr_type
= EXPR_VARIABLE
;
2035 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2036 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2037 && CLASS_DATA (sym
)->as
))
2039 e
->rank
= sym
->ts
.type
== BT_CLASS
2040 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2041 e
->ref
= gfc_get_ref ();
2042 e
->ref
->type
= REF_ARRAY
;
2043 e
->ref
->u
.ar
.type
= AR_FULL
;
2044 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2045 ? CLASS_DATA (sym
)->as
: sym
->as
;
2048 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2049 primary.c (match_actual_arg). If above code determines that it
2050 is a variable instead, it needs to be resolved as it was not
2051 done at the beginning of this function. */
2052 save_need_full_assumed_size
= need_full_assumed_size
;
2053 if (e
->expr_type
!= EXPR_VARIABLE
)
2054 need_full_assumed_size
= 0;
2055 if (!gfc_resolve_expr (e
))
2057 need_full_assumed_size
= save_need_full_assumed_size
;
2060 /* Check argument list functions %VAL, %LOC and %REF. There is
2061 nothing to do for %REF. */
2062 if (arg
->name
&& arg
->name
[0] == '%')
2064 if (strcmp ("%VAL", arg
->name
) == 0)
2066 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2068 gfc_error ("By-value argument at %L is not of numeric "
2075 gfc_error ("By-value argument at %L cannot be an array or "
2076 "an array section", &e
->where
);
2080 /* Intrinsics are still PROC_UNKNOWN here. However,
2081 since same file external procedures are not resolvable
2082 in gfortran, it is a good deal easier to leave them to
2084 if (ptype
!= PROC_UNKNOWN
2085 && ptype
!= PROC_DUMMY
2086 && ptype
!= PROC_EXTERNAL
2087 && ptype
!= PROC_MODULE
)
2089 gfc_error ("By-value argument at %L is not allowed "
2090 "in this context", &e
->where
);
2095 /* Statement functions have already been excluded above. */
2096 else if (strcmp ("%LOC", arg
->name
) == 0
2097 && e
->ts
.type
== BT_PROCEDURE
)
2099 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2101 gfc_error ("Passing internal procedure at %L by location "
2102 "not allowed", &e
->where
);
2108 comp
= gfc_get_proc_ptr_comp(e
);
2109 if (e
->expr_type
== EXPR_VARIABLE
2110 && comp
&& comp
->attr
.elemental
)
2112 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2113 "allowed as an actual argument at %L", comp
->name
,
2117 /* Fortran 2008, C1237. */
2118 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2119 && gfc_has_ultimate_pointer (e
))
2121 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2122 "component", &e
->where
);
2126 first_actual_arg
= false;
2129 return_value
= true;
2132 actual_arg
= actual_arg_sav
;
2133 first_actual_arg
= first_actual_arg_sav
;
2135 return return_value
;
2139 /* Do the checks of the actual argument list that are specific to elemental
2140 procedures. If called with c == NULL, we have a function, otherwise if
2141 expr == NULL, we have a subroutine. */
2144 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2146 gfc_actual_arglist
*arg0
;
2147 gfc_actual_arglist
*arg
;
2148 gfc_symbol
*esym
= NULL
;
2149 gfc_intrinsic_sym
*isym
= NULL
;
2151 gfc_intrinsic_arg
*iformal
= NULL
;
2152 gfc_formal_arglist
*eformal
= NULL
;
2153 bool formal_optional
= false;
2154 bool set_by_optional
= false;
2158 /* Is this an elemental procedure? */
2159 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2161 if (expr
->value
.function
.esym
!= NULL
2162 && expr
->value
.function
.esym
->attr
.elemental
)
2164 arg0
= expr
->value
.function
.actual
;
2165 esym
= expr
->value
.function
.esym
;
2167 else if (expr
->value
.function
.isym
!= NULL
2168 && expr
->value
.function
.isym
->elemental
)
2170 arg0
= expr
->value
.function
.actual
;
2171 isym
= expr
->value
.function
.isym
;
2176 else if (c
&& c
->ext
.actual
!= NULL
)
2178 arg0
= c
->ext
.actual
;
2180 if (c
->resolved_sym
)
2181 esym
= c
->resolved_sym
;
2183 esym
= c
->symtree
->n
.sym
;
2186 if (!esym
->attr
.elemental
)
2192 /* The rank of an elemental is the rank of its array argument(s). */
2193 for (arg
= arg0
; arg
; arg
= arg
->next
)
2195 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2197 rank
= arg
->expr
->rank
;
2198 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2199 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2200 set_by_optional
= true;
2202 /* Function specific; set the result rank and shape. */
2206 if (!expr
->shape
&& arg
->expr
->shape
)
2208 expr
->shape
= gfc_get_shape (rank
);
2209 for (i
= 0; i
< rank
; i
++)
2210 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2217 /* If it is an array, it shall not be supplied as an actual argument
2218 to an elemental procedure unless an array of the same rank is supplied
2219 as an actual argument corresponding to a nonoptional dummy argument of
2220 that elemental procedure(12.4.1.5). */
2221 formal_optional
= false;
2223 iformal
= isym
->formal
;
2225 eformal
= esym
->formal
;
2227 for (arg
= arg0
; arg
; arg
= arg
->next
)
2231 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2232 formal_optional
= true;
2233 eformal
= eformal
->next
;
2235 else if (isym
&& iformal
)
2237 if (iformal
->optional
)
2238 formal_optional
= true;
2239 iformal
= iformal
->next
;
2242 formal_optional
= true;
2244 if (pedantic
&& arg
->expr
!= NULL
2245 && arg
->expr
->expr_type
== EXPR_VARIABLE
2246 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2249 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2250 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2252 gfc_warning (OPT_Wpedantic
,
2253 "%qs at %L is an array and OPTIONAL; IF IT IS "
2254 "MISSING, it cannot be the actual argument of an "
2255 "ELEMENTAL procedure unless there is a non-optional "
2256 "argument with the same rank (12.4.1.5)",
2257 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2261 for (arg
= arg0
; arg
; arg
= arg
->next
)
2263 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2266 /* Being elemental, the last upper bound of an assumed size array
2267 argument must be present. */
2268 if (resolve_assumed_size_actual (arg
->expr
))
2271 /* Elemental procedure's array actual arguments must conform. */
2274 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2281 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2282 is an array, the intent inout/out variable needs to be also an array. */
2283 if (rank
> 0 && esym
&& expr
== NULL
)
2284 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2285 arg
= arg
->next
, eformal
= eformal
->next
)
2286 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2287 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2288 && arg
->expr
&& arg
->expr
->rank
== 0)
2290 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2291 "ELEMENTAL subroutine %qs is a scalar, but another "
2292 "actual argument is an array", &arg
->expr
->where
,
2293 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2294 : "INOUT", eformal
->sym
->name
, esym
->name
);
2301 /* This function does the checking of references to global procedures
2302 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2303 77 and 95 standards. It checks for a gsymbol for the name, making
2304 one if it does not already exist. If it already exists, then the
2305 reference being resolved must correspond to the type of gsymbol.
2306 Otherwise, the new symbol is equipped with the attributes of the
2307 reference. The corresponding code that is called in creating
2308 global entities is parse.c.
2310 In addition, for all but -std=legacy, the gsymbols are used to
2311 check the interfaces of external procedures from the same file.
2312 The namespace of the gsymbol is resolved and then, once this is
2313 done the interface is checked. */
2317 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2319 if (!gsym_ns
->proc_name
->attr
.recursive
)
2322 if (sym
->ns
== gsym_ns
)
2325 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2332 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2334 if (gsym_ns
->entries
)
2336 gfc_entry_list
*entry
= gsym_ns
->entries
;
2338 for (; entry
; entry
= entry
->next
)
2340 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2342 if (strcmp (gsym_ns
->proc_name
->name
,
2343 sym
->ns
->proc_name
->name
) == 0)
2347 && strcmp (gsym_ns
->proc_name
->name
,
2348 sym
->ns
->parent
->proc_name
->name
) == 0)
2357 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2360 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2362 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2364 for ( ; arg
; arg
= arg
->next
)
2369 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2371 strncpy (errmsg
, _("allocatable argument"), err_len
);
2374 else if (arg
->sym
->attr
.asynchronous
)
2376 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2379 else if (arg
->sym
->attr
.optional
)
2381 strncpy (errmsg
, _("optional argument"), err_len
);
2384 else if (arg
->sym
->attr
.pointer
)
2386 strncpy (errmsg
, _("pointer argument"), err_len
);
2389 else if (arg
->sym
->attr
.target
)
2391 strncpy (errmsg
, _("target argument"), err_len
);
2394 else if (arg
->sym
->attr
.value
)
2396 strncpy (errmsg
, _("value argument"), err_len
);
2399 else if (arg
->sym
->attr
.volatile_
)
2401 strncpy (errmsg
, _("volatile argument"), err_len
);
2404 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2406 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2409 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2411 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2414 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2416 strncpy (errmsg
, _("coarray argument"), err_len
);
2419 else if (false) /* (2d) TODO: parametrized derived type */
2421 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2424 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2426 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2429 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2431 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2434 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2436 /* As assumed-type is unlimited polymorphic (cf. above).
2437 See also TS 29113, Note 6.1. */
2438 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2443 if (sym
->attr
.function
)
2445 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2447 if (res
->attr
.dimension
) /* (3a) */
2449 strncpy (errmsg
, _("array result"), err_len
);
2452 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2454 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2457 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2458 && res
->ts
.u
.cl
->length
2459 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2461 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2466 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2468 strncpy (errmsg
, _("elemental procedure"), err_len
);
2471 else if (sym
->attr
.is_bind_c
) /* (5) */
2473 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2482 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2483 gfc_actual_arglist
**actual
, int sub
)
2487 enum gfc_symbol_type type
;
2490 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2492 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2494 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2495 gfc_global_used (gsym
, where
);
2497 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2498 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2499 && gsym
->type
!= GSYM_UNKNOWN
2500 && !gsym
->binding_label
2502 && gsym
->ns
->resolved
!= -1
2503 && gsym
->ns
->proc_name
2504 && not_in_recursive (sym
, gsym
->ns
)
2505 && not_entry_self_reference (sym
, gsym
->ns
))
2507 gfc_symbol
*def_sym
;
2509 /* Resolve the gsymbol namespace if needed. */
2510 if (!gsym
->ns
->resolved
)
2512 gfc_symbol
*old_dt_list
;
2514 /* Stash away derived types so that the backend_decls do not
2516 old_dt_list
= gfc_derived_types
;
2517 gfc_derived_types
= NULL
;
2519 gfc_resolve (gsym
->ns
);
2521 /* Store the new derived types with the global namespace. */
2522 if (gfc_derived_types
)
2523 gsym
->ns
->derived_types
= gfc_derived_types
;
2525 /* Restore the derived types of this namespace. */
2526 gfc_derived_types
= old_dt_list
;
2529 /* Make sure that translation for the gsymbol occurs before
2530 the procedure currently being resolved. */
2531 ns
= gfc_global_ns_list
;
2532 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2534 if (ns
->sibling
== gsym
->ns
)
2536 ns
->sibling
= gsym
->ns
->sibling
;
2537 gsym
->ns
->sibling
= gfc_global_ns_list
;
2538 gfc_global_ns_list
= gsym
->ns
;
2543 def_sym
= gsym
->ns
->proc_name
;
2545 /* This can happen if a binding name has been specified. */
2546 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2547 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2549 if (def_sym
->attr
.entry_master
)
2551 gfc_entry_list
*entry
;
2552 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2553 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2555 def_sym
= entry
->sym
;
2560 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2562 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2563 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2564 gfc_typename (&def_sym
->ts
));
2568 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2569 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2571 gfc_error ("Explicit interface required for %qs at %L: %s",
2572 sym
->name
, &sym
->declared_at
, reason
);
2576 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2577 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2578 gfc_errors_to_warnings (true);
2580 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2581 reason
, sizeof(reason
), NULL
, NULL
))
2583 gfc_error_opt (OPT_Wargument_mismatch
,
2584 "Interface mismatch in global procedure %qs at %L:"
2585 " %s", sym
->name
, &sym
->declared_at
, reason
);
2590 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2591 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2592 gfc_errors_to_warnings (true);
2594 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2595 gfc_procedure_use (def_sym
, actual
, where
);
2599 gfc_errors_to_warnings (false);
2601 if (gsym
->type
== GSYM_UNKNOWN
)
2604 gsym
->where
= *where
;
2611 /************* Function resolution *************/
2613 /* Resolve a function call known to be generic.
2614 Section 14.1.2.4.1. */
2617 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2621 if (sym
->attr
.generic
)
2623 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2626 expr
->value
.function
.name
= s
->name
;
2627 expr
->value
.function
.esym
= s
;
2629 if (s
->ts
.type
!= BT_UNKNOWN
)
2631 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2632 expr
->ts
= s
->result
->ts
;
2635 expr
->rank
= s
->as
->rank
;
2636 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2637 expr
->rank
= s
->result
->as
->rank
;
2639 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2644 /* TODO: Need to search for elemental references in generic
2648 if (sym
->attr
.intrinsic
)
2649 return gfc_intrinsic_func_interface (expr
, 0);
2656 resolve_generic_f (gfc_expr
*expr
)
2660 gfc_interface
*intr
= NULL
;
2662 sym
= expr
->symtree
->n
.sym
;
2666 m
= resolve_generic_f0 (expr
, sym
);
2669 else if (m
== MATCH_ERROR
)
2674 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2675 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2678 if (sym
->ns
->parent
== NULL
)
2680 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2684 if (!generic_sym (sym
))
2688 /* Last ditch attempt. See if the reference is to an intrinsic
2689 that possesses a matching interface. 14.1.2.4 */
2690 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2692 if (gfc_init_expr_flag
)
2693 gfc_error ("Function %qs in initialization expression at %L "
2694 "must be an intrinsic function",
2695 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2697 gfc_error ("There is no specific function for the generic %qs "
2698 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2704 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2707 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2709 return resolve_structure_cons (expr
, 0);
2712 m
= gfc_intrinsic_func_interface (expr
, 0);
2717 gfc_error ("Generic function %qs at %L is not consistent with a "
2718 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2725 /* Resolve a function call known to be specific. */
2728 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2732 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2734 if (sym
->attr
.dummy
)
2736 sym
->attr
.proc
= PROC_DUMMY
;
2740 sym
->attr
.proc
= PROC_EXTERNAL
;
2744 if (sym
->attr
.proc
== PROC_MODULE
2745 || sym
->attr
.proc
== PROC_ST_FUNCTION
2746 || sym
->attr
.proc
== PROC_INTERNAL
)
2749 if (sym
->attr
.intrinsic
)
2751 m
= gfc_intrinsic_func_interface (expr
, 1);
2755 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2756 "with an intrinsic", sym
->name
, &expr
->where
);
2764 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2767 expr
->ts
= sym
->result
->ts
;
2770 expr
->value
.function
.name
= sym
->name
;
2771 expr
->value
.function
.esym
= sym
;
2772 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2774 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2776 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2777 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2778 else if (sym
->as
!= NULL
)
2779 expr
->rank
= sym
->as
->rank
;
2786 resolve_specific_f (gfc_expr
*expr
)
2791 sym
= expr
->symtree
->n
.sym
;
2795 m
= resolve_specific_f0 (sym
, expr
);
2798 if (m
== MATCH_ERROR
)
2801 if (sym
->ns
->parent
== NULL
)
2804 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2810 gfc_error ("Unable to resolve the specific function %qs at %L",
2811 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2816 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2817 candidates in CANDIDATES_LEN. */
2820 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2822 size_t &candidates_len
)
2828 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2829 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2830 vec_push (candidates
, candidates_len
, sym
->name
);
2834 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2838 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2842 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2845 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2847 char **candidates
= NULL
;
2848 size_t candidates_len
= 0;
2849 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2850 return gfc_closest_fuzzy_match (fn
, candidates
);
2854 /* Resolve a procedure call not known to be generic nor specific. */
2857 resolve_unknown_f (gfc_expr
*expr
)
2862 sym
= expr
->symtree
->n
.sym
;
2864 if (sym
->attr
.dummy
)
2866 sym
->attr
.proc
= PROC_DUMMY
;
2867 expr
->value
.function
.name
= sym
->name
;
2871 /* See if we have an intrinsic function reference. */
2873 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2875 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2880 /* The reference is to an external name. */
2882 sym
->attr
.proc
= PROC_EXTERNAL
;
2883 expr
->value
.function
.name
= sym
->name
;
2884 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2886 if (sym
->as
!= NULL
)
2887 expr
->rank
= sym
->as
->rank
;
2889 /* Type of the expression is either the type of the symbol or the
2890 default type of the symbol. */
2893 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2895 if (sym
->ts
.type
!= BT_UNKNOWN
)
2899 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2901 if (ts
->type
== BT_UNKNOWN
)
2904 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2906 gfc_error ("Function %qs at %L has no IMPLICIT type"
2907 "; did you mean %qs?",
2908 sym
->name
, &expr
->where
, guessed
);
2910 gfc_error ("Function %qs at %L has no IMPLICIT type",
2911 sym
->name
, &expr
->where
);
2922 /* Return true, if the symbol is an external procedure. */
2924 is_external_proc (gfc_symbol
*sym
)
2926 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2927 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2928 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2929 && !sym
->attr
.proc_pointer
2930 && !sym
->attr
.use_assoc
2938 /* Figure out if a function reference is pure or not. Also set the name
2939 of the function for a potential error message. Return nonzero if the
2940 function is PURE, zero if not. */
2942 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2945 gfc_pure_function (gfc_expr
*e
, const char **name
)
2948 gfc_component
*comp
;
2952 if (e
->symtree
!= NULL
2953 && e
->symtree
->n
.sym
!= NULL
2954 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2955 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2957 comp
= gfc_get_proc_ptr_comp (e
);
2960 pure
= gfc_pure (comp
->ts
.interface
);
2963 else if (e
->value
.function
.esym
)
2965 pure
= gfc_pure (e
->value
.function
.esym
);
2966 *name
= e
->value
.function
.esym
->name
;
2968 else if (e
->value
.function
.isym
)
2970 pure
= e
->value
.function
.isym
->pure
2971 || e
->value
.function
.isym
->elemental
;
2972 *name
= e
->value
.function
.isym
->name
;
2976 /* Implicit functions are not pure. */
2978 *name
= e
->value
.function
.name
;
2985 /* Check if the expression is a reference to an implicitly pure function. */
2988 gfc_implicit_pure_function (gfc_expr
*e
)
2990 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
2992 return gfc_implicit_pure (comp
->ts
.interface
);
2993 else if (e
->value
.function
.esym
)
2994 return gfc_implicit_pure (e
->value
.function
.esym
);
3001 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3002 int *f ATTRIBUTE_UNUSED
)
3006 /* Don't bother recursing into other statement functions
3007 since they will be checked individually for purity. */
3008 if (e
->expr_type
!= EXPR_FUNCTION
3010 || e
->symtree
->n
.sym
== sym
3011 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3014 return gfc_pure_function (e
, &name
) ? false : true;
3019 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3021 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3025 /* Check if an impure function is allowed in the current context. */
3027 static bool check_pure_function (gfc_expr
*e
)
3029 const char *name
= NULL
;
3030 if (!gfc_pure_function (e
, &name
) && name
)
3034 gfc_error ("Reference to impure function %qs at %L inside a "
3035 "FORALL %s", name
, &e
->where
,
3036 forall_flag
== 2 ? "mask" : "block");
3039 else if (gfc_do_concurrent_flag
)
3041 gfc_error ("Reference to impure function %qs at %L inside a "
3042 "DO CONCURRENT %s", name
, &e
->where
,
3043 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3046 else if (gfc_pure (NULL
))
3048 gfc_error ("Reference to impure function %qs at %L "
3049 "within a PURE procedure", name
, &e
->where
);
3052 if (!gfc_implicit_pure_function (e
))
3053 gfc_unset_implicit_pure (NULL
);
3059 /* Update current procedure's array_outer_dependency flag, considering
3060 a call to procedure SYM. */
3063 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3065 /* Check to see if this is a sibling function that has not yet
3067 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3068 for (; sibling
; sibling
= sibling
->sibling
)
3070 if (sibling
->proc_name
== sym
)
3072 gfc_resolve (sibling
);
3077 /* If SYM has references to outer arrays, so has the procedure calling
3078 SYM. If SYM is a procedure pointer, we can assume the worst. */
3079 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3080 && gfc_current_ns
->proc_name
)
3081 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3085 /* Resolve a function call, which means resolving the arguments, then figuring
3086 out which entity the name refers to. */
3089 resolve_function (gfc_expr
*expr
)
3091 gfc_actual_arglist
*arg
;
3095 procedure_type p
= PROC_INTRINSIC
;
3096 bool no_formal_args
;
3100 sym
= expr
->symtree
->n
.sym
;
3102 /* If this is a procedure pointer component, it has already been resolved. */
3103 if (gfc_is_proc_ptr_comp (expr
))
3106 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3108 if (sym
&& sym
->attr
.intrinsic
3109 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3110 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3113 if (sym
&& sym
->attr
.intrinsic
3114 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3117 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3119 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3123 /* If this is a deferred TBP with an abstract interface (which may
3124 of course be referenced), expr->value.function.esym will be set. */
3125 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3127 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3128 sym
->name
, &expr
->where
);
3132 /* If this is a deferred TBP with an abstract interface, its result
3133 cannot be an assumed length character (F2003: C418). */
3134 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3135 && sym
->result
->ts
.u
.cl
3136 && sym
->result
->ts
.u
.cl
->length
== NULL
3137 && !sym
->result
->ts
.deferred
)
3139 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3140 "character length result (F2008: C418)", sym
->name
,
3145 /* Switch off assumed size checking and do this again for certain kinds
3146 of procedure, once the procedure itself is resolved. */
3147 need_full_assumed_size
++;
3149 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3150 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3152 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3153 inquiry_argument
= true;
3154 no_formal_args
= sym
&& is_external_proc (sym
)
3155 && gfc_sym_get_dummy_args (sym
) == NULL
;
3157 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3160 inquiry_argument
= false;
3164 inquiry_argument
= false;
3166 /* Resume assumed_size checking. */
3167 need_full_assumed_size
--;
3169 /* If the procedure is external, check for usage. */
3170 if (sym
&& is_external_proc (sym
))
3171 resolve_global_procedure (sym
, &expr
->where
,
3172 &expr
->value
.function
.actual
, 0);
3174 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3176 && sym
->ts
.u
.cl
->length
== NULL
3178 && !sym
->ts
.deferred
3179 && expr
->value
.function
.esym
== NULL
3180 && !sym
->attr
.contained
)
3182 /* Internal procedures are taken care of in resolve_contained_fntype. */
3183 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3184 "be used at %L since it is not a dummy argument",
3185 sym
->name
, &expr
->where
);
3189 /* See if function is already resolved. */
3191 if (expr
->value
.function
.name
!= NULL
3192 || expr
->value
.function
.isym
!= NULL
)
3194 if (expr
->ts
.type
== BT_UNKNOWN
)
3200 /* Apply the rules of section 14.1.2. */
3202 switch (procedure_kind (sym
))
3205 t
= resolve_generic_f (expr
);
3208 case PTYPE_SPECIFIC
:
3209 t
= resolve_specific_f (expr
);
3213 t
= resolve_unknown_f (expr
);
3217 gfc_internal_error ("resolve_function(): bad function type");
3221 /* If the expression is still a function (it might have simplified),
3222 then we check to see if we are calling an elemental function. */
3224 if (expr
->expr_type
!= EXPR_FUNCTION
)
3227 temp
= need_full_assumed_size
;
3228 need_full_assumed_size
= 0;
3230 if (!resolve_elemental_actual (expr
, NULL
))
3233 if (omp_workshare_flag
3234 && expr
->value
.function
.esym
3235 && ! gfc_elemental (expr
->value
.function
.esym
))
3237 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3238 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3243 #define GENERIC_ID expr->value.function.isym->id
3244 else if (expr
->value
.function
.actual
!= NULL
3245 && expr
->value
.function
.isym
!= NULL
3246 && GENERIC_ID
!= GFC_ISYM_LBOUND
3247 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3248 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3249 && GENERIC_ID
!= GFC_ISYM_LEN
3250 && GENERIC_ID
!= GFC_ISYM_LOC
3251 && GENERIC_ID
!= GFC_ISYM_C_LOC
3252 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3254 /* Array intrinsics must also have the last upper bound of an
3255 assumed size array argument. UBOUND and SIZE have to be
3256 excluded from the check if the second argument is anything
3259 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3261 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3262 && arg
== expr
->value
.function
.actual
3263 && arg
->next
!= NULL
&& arg
->next
->expr
)
3265 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3268 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3271 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3276 if (arg
->expr
!= NULL
3277 && arg
->expr
->rank
> 0
3278 && resolve_assumed_size_actual (arg
->expr
))
3284 need_full_assumed_size
= temp
;
3286 if (!check_pure_function(expr
))
3289 /* Functions without the RECURSIVE attribution are not allowed to
3290 * call themselves. */
3291 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3294 esym
= expr
->value
.function
.esym
;
3296 if (is_illegal_recursion (esym
, gfc_current_ns
))
3298 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3299 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3300 " function %qs is not RECURSIVE",
3301 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3303 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3304 " is not RECURSIVE", esym
->name
, &expr
->where
);
3310 /* Character lengths of use associated functions may contains references to
3311 symbols not referenced from the current program unit otherwise. Make sure
3312 those symbols are marked as referenced. */
3314 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3315 && expr
->value
.function
.esym
->attr
.use_assoc
)
3317 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3320 /* Make sure that the expression has a typespec that works. */
3321 if (expr
->ts
.type
== BT_UNKNOWN
)
3323 if (expr
->symtree
->n
.sym
->result
3324 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3325 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3326 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3329 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3331 if (expr
->value
.function
.esym
)
3332 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3334 update_current_proc_array_outer_dependency (sym
);
3337 /* typebound procedure: Assume the worst. */
3338 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3344 /************* Subroutine resolution *************/
3347 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3354 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3358 else if (gfc_do_concurrent_flag
)
3360 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3364 else if (gfc_pure (NULL
))
3366 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3370 gfc_unset_implicit_pure (NULL
);
3376 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3380 if (sym
->attr
.generic
)
3382 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3385 c
->resolved_sym
= s
;
3386 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3391 /* TODO: Need to search for elemental references in generic interface. */
3394 if (sym
->attr
.intrinsic
)
3395 return gfc_intrinsic_sub_interface (c
, 0);
3402 resolve_generic_s (gfc_code
*c
)
3407 sym
= c
->symtree
->n
.sym
;
3411 m
= resolve_generic_s0 (c
, sym
);
3414 else if (m
== MATCH_ERROR
)
3418 if (sym
->ns
->parent
== NULL
)
3420 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3424 if (!generic_sym (sym
))
3428 /* Last ditch attempt. See if the reference is to an intrinsic
3429 that possesses a matching interface. 14.1.2.4 */
3430 sym
= c
->symtree
->n
.sym
;
3432 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3434 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3435 sym
->name
, &c
->loc
);
3439 m
= gfc_intrinsic_sub_interface (c
, 0);
3443 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3444 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3450 /* Resolve a subroutine call known to be specific. */
3453 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3457 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3459 if (sym
->attr
.dummy
)
3461 sym
->attr
.proc
= PROC_DUMMY
;
3465 sym
->attr
.proc
= PROC_EXTERNAL
;
3469 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3472 if (sym
->attr
.intrinsic
)
3474 m
= gfc_intrinsic_sub_interface (c
, 1);
3478 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3479 "with an intrinsic", sym
->name
, &c
->loc
);
3487 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3489 c
->resolved_sym
= sym
;
3490 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3498 resolve_specific_s (gfc_code
*c
)
3503 sym
= c
->symtree
->n
.sym
;
3507 m
= resolve_specific_s0 (c
, sym
);
3510 if (m
== MATCH_ERROR
)
3513 if (sym
->ns
->parent
== NULL
)
3516 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3522 sym
= c
->symtree
->n
.sym
;
3523 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3524 sym
->name
, &c
->loc
);
3530 /* Resolve a subroutine call not known to be generic nor specific. */
3533 resolve_unknown_s (gfc_code
*c
)
3537 sym
= c
->symtree
->n
.sym
;
3539 if (sym
->attr
.dummy
)
3541 sym
->attr
.proc
= PROC_DUMMY
;
3545 /* See if we have an intrinsic function reference. */
3547 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3549 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3554 /* The reference is to an external name. */
3557 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3559 c
->resolved_sym
= sym
;
3561 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3565 /* Resolve a subroutine call. Although it was tempting to use the same code
3566 for functions, subroutines and functions are stored differently and this
3567 makes things awkward. */
3570 resolve_call (gfc_code
*c
)
3573 procedure_type ptype
= PROC_INTRINSIC
;
3574 gfc_symbol
*csym
, *sym
;
3575 bool no_formal_args
;
3577 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3579 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3581 gfc_error ("%qs at %L has a type, which is not consistent with "
3582 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3586 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3589 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3590 sym
= st
? st
->n
.sym
: NULL
;
3591 if (sym
&& csym
!= sym
3592 && sym
->ns
== gfc_current_ns
3593 && sym
->attr
.flavor
== FL_PROCEDURE
3594 && sym
->attr
.contained
)
3597 if (csym
->attr
.generic
)
3598 c
->symtree
->n
.sym
= sym
;
3601 csym
= c
->symtree
->n
.sym
;
3605 /* If this ia a deferred TBP, c->expr1 will be set. */
3606 if (!c
->expr1
&& csym
)
3608 if (csym
->attr
.abstract
)
3610 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3611 csym
->name
, &c
->loc
);
3615 /* Subroutines without the RECURSIVE attribution are not allowed to
3617 if (is_illegal_recursion (csym
, gfc_current_ns
))
3619 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3620 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3621 "as subroutine %qs is not RECURSIVE",
3622 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3624 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3625 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3631 /* Switch off assumed size checking and do this again for certain kinds
3632 of procedure, once the procedure itself is resolved. */
3633 need_full_assumed_size
++;
3636 ptype
= csym
->attr
.proc
;
3638 no_formal_args
= csym
&& is_external_proc (csym
)
3639 && gfc_sym_get_dummy_args (csym
) == NULL
;
3640 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3643 /* Resume assumed_size checking. */
3644 need_full_assumed_size
--;
3646 /* If external, check for usage. */
3647 if (csym
&& is_external_proc (csym
))
3648 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3651 if (c
->resolved_sym
== NULL
)
3653 c
->resolved_isym
= NULL
;
3654 switch (procedure_kind (csym
))
3657 t
= resolve_generic_s (c
);
3660 case PTYPE_SPECIFIC
:
3661 t
= resolve_specific_s (c
);
3665 t
= resolve_unknown_s (c
);
3669 gfc_internal_error ("resolve_subroutine(): bad function type");
3673 /* Some checks of elemental subroutine actual arguments. */
3674 if (!resolve_elemental_actual (NULL
, c
))
3678 update_current_proc_array_outer_dependency (csym
);
3680 /* Typebound procedure: Assume the worst. */
3681 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3687 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3688 op1->shape and op2->shape are non-NULL return true if their shapes
3689 match. If both op1->shape and op2->shape are non-NULL return false
3690 if their shapes do not match. If either op1->shape or op2->shape is
3691 NULL, return true. */
3694 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3701 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3703 for (i
= 0; i
< op1
->rank
; i
++)
3705 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3707 gfc_error ("Shapes for operands at %L and %L are not conformable",
3708 &op1
->where
, &op2
->where
);
3718 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3719 For example A .AND. B becomes IAND(A, B). */
3721 logical_to_bitwise (gfc_expr
*e
)
3723 gfc_expr
*tmp
, *op1
, *op2
;
3725 gfc_actual_arglist
*args
= NULL
;
3727 gcc_assert (e
->expr_type
== EXPR_OP
);
3729 isym
= GFC_ISYM_NONE
;
3730 op1
= e
->value
.op
.op1
;
3731 op2
= e
->value
.op
.op2
;
3733 switch (e
->value
.op
.op
)
3736 isym
= GFC_ISYM_NOT
;
3739 isym
= GFC_ISYM_IAND
;
3742 isym
= GFC_ISYM_IOR
;
3744 case INTRINSIC_NEQV
:
3745 isym
= GFC_ISYM_IEOR
;
3748 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3749 Change the old expression to NEQV, which will get replaced by IEOR,
3750 and wrap it in NOT. */
3751 tmp
= gfc_copy_expr (e
);
3752 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3753 tmp
= logical_to_bitwise (tmp
);
3754 isym
= GFC_ISYM_NOT
;
3759 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3762 /* Inherit the original operation's operands as arguments. */
3763 args
= gfc_get_actual_arglist ();
3767 args
->next
= gfc_get_actual_arglist ();
3768 args
->next
->expr
= op2
;
3771 /* Convert the expression to a function call. */
3772 e
->expr_type
= EXPR_FUNCTION
;
3773 e
->value
.function
.actual
= args
;
3774 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3775 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3776 e
->value
.function
.esym
= NULL
;
3778 /* Make up a pre-resolved function call symtree if we need to. */
3779 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3782 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3783 sym
= e
->symtree
->n
.sym
;
3785 sym
->attr
.flavor
= FL_PROCEDURE
;
3786 sym
->attr
.function
= 1;
3787 sym
->attr
.elemental
= 1;
3789 sym
->attr
.referenced
= 1;
3790 gfc_intrinsic_symbol (sym
);
3791 gfc_commit_symbol (sym
);
3794 args
->name
= e
->value
.function
.isym
->formal
->name
;
3795 if (e
->value
.function
.isym
->formal
->next
)
3796 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3801 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3802 candidates in CANDIDATES_LEN. */
3804 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3806 size_t &candidates_len
)
3813 /* Not sure how to properly filter here. Use all for a start.
3814 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3815 these as i suppose they don't make terribly sense. */
3817 if (uop
->n
.uop
->op
!= NULL
)
3818 vec_push (candidates
, candidates_len
, uop
->name
);
3822 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3826 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3829 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3832 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3834 char **candidates
= NULL
;
3835 size_t candidates_len
= 0;
3836 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3837 return gfc_closest_fuzzy_match (op
, candidates
);
3841 /* Callback finding an impure function as an operand to an .and. or
3842 .or. expression. Remember the last function warned about to
3843 avoid double warnings when recursing. */
3846 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3851 static gfc_expr
*last
= NULL
;
3852 bool *found
= (bool *) data
;
3854 if (f
->expr_type
== EXPR_FUNCTION
)
3857 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3858 && !gfc_implicit_pure_function (f
))
3861 gfc_warning (OPT_Wfunction_elimination
,
3862 "Impure function %qs at %L might not be evaluated",
3865 gfc_warning (OPT_Wfunction_elimination
,
3866 "Impure function at %L might not be evaluated",
3876 /* Resolve an operator expression node. This can involve replacing the
3877 operation with a user defined function call. */
3880 resolve_operator (gfc_expr
*e
)
3882 gfc_expr
*op1
, *op2
;
3884 bool dual_locus_error
;
3887 /* Resolve all subnodes-- give them types. */
3889 switch (e
->value
.op
.op
)
3892 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3898 case INTRINSIC_UPLUS
:
3899 case INTRINSIC_UMINUS
:
3900 case INTRINSIC_PARENTHESES
:
3901 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3906 /* Typecheck the new node. */
3908 op1
= e
->value
.op
.op1
;
3909 op2
= e
->value
.op
.op2
;
3910 dual_locus_error
= false;
3912 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3913 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3915 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3919 switch (e
->value
.op
.op
)
3921 case INTRINSIC_UPLUS
:
3922 case INTRINSIC_UMINUS
:
3923 if (op1
->ts
.type
== BT_INTEGER
3924 || op1
->ts
.type
== BT_REAL
3925 || op1
->ts
.type
== BT_COMPLEX
)
3931 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3932 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3935 case INTRINSIC_PLUS
:
3936 case INTRINSIC_MINUS
:
3937 case INTRINSIC_TIMES
:
3938 case INTRINSIC_DIVIDE
:
3939 case INTRINSIC_POWER
:
3940 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3942 gfc_type_convert_binary (e
, 1);
3946 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3948 _("Unexpected derived-type entities in binary intrinsic "
3949 "numeric operator %%<%s%%> at %%L"),
3950 gfc_op2string (e
->value
.op
.op
));
3953 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3954 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3955 gfc_typename (&op2
->ts
));
3958 case INTRINSIC_CONCAT
:
3959 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3960 && op1
->ts
.kind
== op2
->ts
.kind
)
3962 e
->ts
.type
= BT_CHARACTER
;
3963 e
->ts
.kind
= op1
->ts
.kind
;
3968 _("Operands of string concatenation operator at %%L are %s/%s"),
3969 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3975 case INTRINSIC_NEQV
:
3976 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3978 e
->ts
.type
= BT_LOGICAL
;
3979 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3980 if (op1
->ts
.kind
< e
->ts
.kind
)
3981 gfc_convert_type (op1
, &e
->ts
, 2);
3982 else if (op2
->ts
.kind
< e
->ts
.kind
)
3983 gfc_convert_type (op2
, &e
->ts
, 2);
3985 if (flag_frontend_optimize
&&
3986 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
3988 /* Warn about short-circuiting
3989 with impure function as second operand. */
3991 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
3996 /* Logical ops on integers become bitwise ops with -fdec. */
3998 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4000 e
->ts
.type
= BT_INTEGER
;
4001 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4002 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4003 gfc_convert_type (op1
, &e
->ts
, 1);
4004 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4005 gfc_convert_type (op2
, &e
->ts
, 1);
4006 e
= logical_to_bitwise (e
);
4007 return resolve_function (e
);
4010 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4011 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4012 gfc_typename (&op2
->ts
));
4017 /* Logical ops on integers become bitwise ops with -fdec. */
4018 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4020 e
->ts
.type
= BT_INTEGER
;
4021 e
->ts
.kind
= op1
->ts
.kind
;
4022 e
= logical_to_bitwise (e
);
4023 return resolve_function (e
);
4026 if (op1
->ts
.type
== BT_LOGICAL
)
4028 e
->ts
.type
= BT_LOGICAL
;
4029 e
->ts
.kind
= op1
->ts
.kind
;
4033 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4034 gfc_typename (&op1
->ts
));
4038 case INTRINSIC_GT_OS
:
4040 case INTRINSIC_GE_OS
:
4042 case INTRINSIC_LT_OS
:
4044 case INTRINSIC_LE_OS
:
4045 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4047 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4054 case INTRINSIC_EQ_OS
:
4056 case INTRINSIC_NE_OS
:
4057 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4058 && op1
->ts
.kind
== op2
->ts
.kind
)
4060 e
->ts
.type
= BT_LOGICAL
;
4061 e
->ts
.kind
= gfc_default_logical_kind
;
4065 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4067 gfc_type_convert_binary (e
, 1);
4069 e
->ts
.type
= BT_LOGICAL
;
4070 e
->ts
.kind
= gfc_default_logical_kind
;
4072 if (warn_compare_reals
)
4074 gfc_intrinsic_op op
= e
->value
.op
.op
;
4076 /* Type conversion has made sure that the types of op1 and op2
4077 agree, so it is only necessary to check the first one. */
4078 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4079 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4080 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4084 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4085 msg
= "Equality comparison for %s at %L";
4087 msg
= "Inequality comparison for %s at %L";
4089 gfc_warning (OPT_Wcompare_reals
, msg
,
4090 gfc_typename (&op1
->ts
), &op1
->where
);
4097 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4099 _("Logicals at %%L must be compared with %s instead of %s"),
4100 (e
->value
.op
.op
== INTRINSIC_EQ
4101 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4102 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4105 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4106 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4107 gfc_typename (&op2
->ts
));
4111 case INTRINSIC_USER
:
4112 if (e
->value
.op
.uop
->op
== NULL
)
4114 const char *name
= e
->value
.op
.uop
->name
;
4115 const char *guessed
;
4116 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4118 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4121 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4123 else if (op2
== NULL
)
4124 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4125 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4128 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4129 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4130 gfc_typename (&op2
->ts
));
4131 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4136 case INTRINSIC_PARENTHESES
:
4138 if (e
->ts
.type
== BT_CHARACTER
)
4139 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4143 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4146 /* Deal with arrayness of an operand through an operator. */
4150 switch (e
->value
.op
.op
)
4152 case INTRINSIC_PLUS
:
4153 case INTRINSIC_MINUS
:
4154 case INTRINSIC_TIMES
:
4155 case INTRINSIC_DIVIDE
:
4156 case INTRINSIC_POWER
:
4157 case INTRINSIC_CONCAT
:
4161 case INTRINSIC_NEQV
:
4163 case INTRINSIC_EQ_OS
:
4165 case INTRINSIC_NE_OS
:
4167 case INTRINSIC_GT_OS
:
4169 case INTRINSIC_GE_OS
:
4171 case INTRINSIC_LT_OS
:
4173 case INTRINSIC_LE_OS
:
4175 if (op1
->rank
== 0 && op2
->rank
== 0)
4178 if (op1
->rank
== 0 && op2
->rank
!= 0)
4180 e
->rank
= op2
->rank
;
4182 if (e
->shape
== NULL
)
4183 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4186 if (op1
->rank
!= 0 && op2
->rank
== 0)
4188 e
->rank
= op1
->rank
;
4190 if (e
->shape
== NULL
)
4191 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4194 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4196 if (op1
->rank
== op2
->rank
)
4198 e
->rank
= op1
->rank
;
4199 if (e
->shape
== NULL
)
4201 t
= compare_shapes (op1
, op2
);
4205 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4210 /* Allow higher level expressions to work. */
4213 /* Try user-defined operators, and otherwise throw an error. */
4214 dual_locus_error
= true;
4216 _("Inconsistent ranks for operator at %%L and %%L"));
4223 case INTRINSIC_PARENTHESES
:
4225 case INTRINSIC_UPLUS
:
4226 case INTRINSIC_UMINUS
:
4227 /* Simply copy arrayness attribute */
4228 e
->rank
= op1
->rank
;
4230 if (e
->shape
== NULL
)
4231 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4239 /* Attempt to simplify the expression. */
4242 t
= gfc_simplify_expr (e
, 0);
4243 /* Some calls do not succeed in simplification and return false
4244 even though there is no error; e.g. variable references to
4245 PARAMETER arrays. */
4246 if (!gfc_is_constant_expr (e
))
4254 match m
= gfc_extend_expr (e
);
4257 if (m
== MATCH_ERROR
)
4261 if (dual_locus_error
)
4262 gfc_error (msg
, &op1
->where
, &op2
->where
);
4264 gfc_error (msg
, &e
->where
);
4270 /************** Array resolution subroutines **************/
4273 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4275 /* Compare two integer expressions. */
4277 static compare_result
4278 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4282 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4283 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4286 /* If either of the types isn't INTEGER, we must have
4287 raised an error earlier. */
4289 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4292 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4302 /* Compare an integer expression with an integer. */
4304 static compare_result
4305 compare_bound_int (gfc_expr
*a
, int b
)
4309 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4312 if (a
->ts
.type
!= BT_INTEGER
)
4313 gfc_internal_error ("compare_bound_int(): Bad expression");
4315 i
= mpz_cmp_si (a
->value
.integer
, b
);
4325 /* Compare an integer expression with a mpz_t. */
4327 static compare_result
4328 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4332 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4335 if (a
->ts
.type
!= BT_INTEGER
)
4336 gfc_internal_error ("compare_bound_int(): Bad expression");
4338 i
= mpz_cmp (a
->value
.integer
, b
);
4348 /* Compute the last value of a sequence given by a triplet.
4349 Return 0 if it wasn't able to compute the last value, or if the
4350 sequence if empty, and 1 otherwise. */
4353 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4354 gfc_expr
*stride
, mpz_t last
)
4358 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4359 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4360 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4363 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4364 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4367 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4369 if (compare_bound (start
, end
) == CMP_GT
)
4371 mpz_set (last
, end
->value
.integer
);
4375 if (compare_bound_int (stride
, 0) == CMP_GT
)
4377 /* Stride is positive */
4378 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4383 /* Stride is negative */
4384 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4389 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4390 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4391 mpz_sub (last
, end
->value
.integer
, rem
);
4398 /* Compare a single dimension of an array reference to the array
4402 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4406 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4408 gcc_assert (ar
->stride
[i
] == NULL
);
4409 /* This implies [*] as [*:] and [*:3] are not possible. */
4410 if (ar
->start
[i
] == NULL
)
4412 gcc_assert (ar
->end
[i
] == NULL
);
4417 /* Given start, end and stride values, calculate the minimum and
4418 maximum referenced indexes. */
4420 switch (ar
->dimen_type
[i
])
4423 case DIMEN_THIS_IMAGE
:
4428 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4431 gfc_warning (0, "Array reference at %L is out of bounds "
4432 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4433 mpz_get_si (ar
->start
[i
]->value
.integer
),
4434 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4436 gfc_warning (0, "Array reference at %L is out of bounds "
4437 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4438 mpz_get_si (ar
->start
[i
]->value
.integer
),
4439 mpz_get_si (as
->lower
[i
]->value
.integer
),
4443 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4446 gfc_warning (0, "Array reference at %L is out of bounds "
4447 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4448 mpz_get_si (ar
->start
[i
]->value
.integer
),
4449 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4451 gfc_warning (0, "Array reference at %L is out of bounds "
4452 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4453 mpz_get_si (ar
->start
[i
]->value
.integer
),
4454 mpz_get_si (as
->upper
[i
]->value
.integer
),
4463 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4464 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4466 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4468 /* Check for zero stride, which is not allowed. */
4469 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4471 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4475 /* if start == len || (stride > 0 && start < len)
4476 || (stride < 0 && start > len),
4477 then the array section contains at least one element. In this
4478 case, there is an out-of-bounds access if
4479 (start < lower || start > upper). */
4480 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4481 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4482 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4483 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4484 && comp_start_end
== CMP_GT
))
4486 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4488 gfc_warning (0, "Lower array reference at %L is out of bounds "
4489 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4490 mpz_get_si (AR_START
->value
.integer
),
4491 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4494 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4496 gfc_warning (0, "Lower array reference at %L is out of bounds "
4497 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4498 mpz_get_si (AR_START
->value
.integer
),
4499 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4504 /* If we can compute the highest index of the array section,
4505 then it also has to be between lower and upper. */
4506 mpz_init (last_value
);
4507 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4510 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4512 gfc_warning (0, "Upper array reference at %L is out of bounds "
4513 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4514 mpz_get_si (last_value
),
4515 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4516 mpz_clear (last_value
);
4519 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4521 gfc_warning (0, "Upper array reference at %L is out of bounds "
4522 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4523 mpz_get_si (last_value
),
4524 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4525 mpz_clear (last_value
);
4529 mpz_clear (last_value
);
4537 gfc_internal_error ("check_dimension(): Bad array reference");
4544 /* Compare an array reference with an array specification. */
4547 compare_spec_to_ref (gfc_array_ref
*ar
)
4554 /* TODO: Full array sections are only allowed as actual parameters. */
4555 if (as
->type
== AS_ASSUMED_SIZE
4556 && (/*ar->type == AR_FULL
4557 ||*/ (ar
->type
== AR_SECTION
4558 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4560 gfc_error ("Rightmost upper bound of assumed size array section "
4561 "not specified at %L", &ar
->where
);
4565 if (ar
->type
== AR_FULL
)
4568 if (as
->rank
!= ar
->dimen
)
4570 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4571 &ar
->where
, ar
->dimen
, as
->rank
);
4575 /* ar->codimen == 0 is a local array. */
4576 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4578 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4579 &ar
->where
, ar
->codimen
, as
->corank
);
4583 for (i
= 0; i
< as
->rank
; i
++)
4584 if (!check_dimension (i
, ar
, as
))
4587 /* Local access has no coarray spec. */
4588 if (ar
->codimen
!= 0)
4589 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4591 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4592 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4594 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4595 i
+ 1 - as
->rank
, &ar
->where
);
4598 if (!check_dimension (i
, ar
, as
))
4606 /* Resolve one part of an array index. */
4609 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4610 int force_index_integer_kind
)
4617 if (!gfc_resolve_expr (index
))
4620 if (check_scalar
&& index
->rank
!= 0)
4622 gfc_error ("Array index at %L must be scalar", &index
->where
);
4626 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4628 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4629 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4633 if (index
->ts
.type
== BT_REAL
)
4634 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4638 if ((index
->ts
.kind
!= gfc_index_integer_kind
4639 && force_index_integer_kind
)
4640 || index
->ts
.type
!= BT_INTEGER
)
4643 ts
.type
= BT_INTEGER
;
4644 ts
.kind
= gfc_index_integer_kind
;
4646 gfc_convert_type_warn (index
, &ts
, 2, 0);
4652 /* Resolve one part of an array index. */
4655 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4657 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4660 /* Resolve a dim argument to an intrinsic function. */
4663 gfc_resolve_dim_arg (gfc_expr
*dim
)
4668 if (!gfc_resolve_expr (dim
))
4673 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4678 if (dim
->ts
.type
!= BT_INTEGER
)
4680 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4684 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4689 ts
.type
= BT_INTEGER
;
4690 ts
.kind
= gfc_index_integer_kind
;
4692 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4698 /* Given an expression that contains array references, update those array
4699 references to point to the right array specifications. While this is
4700 filled in during matching, this information is difficult to save and load
4701 in a module, so we take care of it here.
4703 The idea here is that the original array reference comes from the
4704 base symbol. We traverse the list of reference structures, setting
4705 the stored reference to references. Component references can
4706 provide an additional array specification. */
4709 find_array_spec (gfc_expr
*e
)
4715 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4716 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4718 as
= e
->symtree
->n
.sym
->as
;
4720 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4725 gfc_internal_error ("find_array_spec(): Missing spec");
4732 c
= ref
->u
.c
.component
;
4733 if (c
->attr
.dimension
)
4736 gfc_internal_error ("find_array_spec(): unused as(1)");
4747 gfc_internal_error ("find_array_spec(): unused as(2)");
4751 /* Resolve an array reference. */
4754 resolve_array_ref (gfc_array_ref
*ar
)
4756 int i
, check_scalar
;
4759 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4761 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4763 /* Do not force gfc_index_integer_kind for the start. We can
4764 do fine with any integer kind. This avoids temporary arrays
4765 created for indexing with a vector. */
4766 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4768 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4770 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4775 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4779 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4783 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4784 if (e
->expr_type
== EXPR_VARIABLE
4785 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4786 ar
->start
[i
] = gfc_get_parentheses (e
);
4790 gfc_error ("Array index at %L is an array of rank %d",
4791 &ar
->c_where
[i
], e
->rank
);
4795 /* Fill in the upper bound, which may be lower than the
4796 specified one for something like a(2:10:5), which is
4797 identical to a(2:7:5). Only relevant for strides not equal
4798 to one. Don't try a division by zero. */
4799 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4800 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4801 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4802 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4806 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4808 if (ar
->end
[i
] == NULL
)
4811 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4813 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4815 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4816 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4818 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4829 if (ar
->type
== AR_FULL
)
4831 if (ar
->as
->rank
== 0)
4832 ar
->type
= AR_ELEMENT
;
4834 /* Make sure array is the same as array(:,:), this way
4835 we don't need to special case all the time. */
4836 ar
->dimen
= ar
->as
->rank
;
4837 for (i
= 0; i
< ar
->dimen
; i
++)
4839 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4841 gcc_assert (ar
->start
[i
] == NULL
);
4842 gcc_assert (ar
->end
[i
] == NULL
);
4843 gcc_assert (ar
->stride
[i
] == NULL
);
4847 /* If the reference type is unknown, figure out what kind it is. */
4849 if (ar
->type
== AR_UNKNOWN
)
4851 ar
->type
= AR_ELEMENT
;
4852 for (i
= 0; i
< ar
->dimen
; i
++)
4853 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4854 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4856 ar
->type
= AR_SECTION
;
4861 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4864 if (ar
->as
->corank
&& ar
->codimen
== 0)
4867 ar
->codimen
= ar
->as
->corank
;
4868 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4869 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4877 resolve_substring (gfc_ref
*ref
)
4879 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4881 if (ref
->u
.ss
.start
!= NULL
)
4883 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4886 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4888 gfc_error ("Substring start index at %L must be of type INTEGER",
4889 &ref
->u
.ss
.start
->where
);
4893 if (ref
->u
.ss
.start
->rank
!= 0)
4895 gfc_error ("Substring start index at %L must be scalar",
4896 &ref
->u
.ss
.start
->where
);
4900 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4901 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4902 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4904 gfc_error ("Substring start index at %L is less than one",
4905 &ref
->u
.ss
.start
->where
);
4910 if (ref
->u
.ss
.end
!= NULL
)
4912 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4915 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4917 gfc_error ("Substring end index at %L must be of type INTEGER",
4918 &ref
->u
.ss
.end
->where
);
4922 if (ref
->u
.ss
.end
->rank
!= 0)
4924 gfc_error ("Substring end index at %L must be scalar",
4925 &ref
->u
.ss
.end
->where
);
4929 if (ref
->u
.ss
.length
!= NULL
4930 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4931 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4932 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4934 gfc_error ("Substring end index at %L exceeds the string length",
4935 &ref
->u
.ss
.start
->where
);
4939 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4940 gfc_integer_kinds
[k
].huge
) == CMP_GT
4941 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4942 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4944 gfc_error ("Substring end index at %L is too large",
4945 &ref
->u
.ss
.end
->where
);
4954 /* This function supplies missing substring charlens. */
4957 gfc_resolve_substring_charlen (gfc_expr
*e
)
4960 gfc_expr
*start
, *end
;
4961 gfc_typespec
*ts
= NULL
;
4963 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4965 if (char_ref
->type
== REF_SUBSTRING
)
4967 if (char_ref
->type
== REF_COMPONENT
)
4968 ts
= &char_ref
->u
.c
.component
->ts
;
4974 gcc_assert (char_ref
->next
== NULL
);
4978 if (e
->ts
.u
.cl
->length
)
4979 gfc_free_expr (e
->ts
.u
.cl
->length
);
4980 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4984 e
->ts
.type
= BT_CHARACTER
;
4985 e
->ts
.kind
= gfc_default_character_kind
;
4988 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4990 if (char_ref
->u
.ss
.start
)
4991 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4993 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
4995 if (char_ref
->u
.ss
.end
)
4996 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4997 else if (e
->expr_type
== EXPR_VARIABLE
)
5000 ts
= &e
->symtree
->n
.sym
->ts
;
5001 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5008 gfc_free_expr (start
);
5009 gfc_free_expr (end
);
5013 /* Length = (end - start + 1). */
5014 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5015 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5016 gfc_get_int_expr (gfc_charlen_int_kind
,
5019 /* F2008, 6.4.1: Both the starting point and the ending point shall
5020 be within the range 1, 2, ..., n unless the starting point exceeds
5021 the ending point, in which case the substring has length zero. */
5023 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5024 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5026 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5027 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5029 /* Make sure that the length is simplified. */
5030 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5031 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5035 /* Resolve subtype references. */
5038 resolve_ref (gfc_expr
*expr
)
5040 int current_part_dimension
, n_components
, seen_part_dimension
;
5043 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5044 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5046 find_array_spec (expr
);
5050 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5054 if (!resolve_array_ref (&ref
->u
.ar
))
5062 if (!resolve_substring (ref
))
5067 /* Check constraints on part references. */
5069 current_part_dimension
= 0;
5070 seen_part_dimension
= 0;
5073 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5078 switch (ref
->u
.ar
.type
)
5081 /* Coarray scalar. */
5082 if (ref
->u
.ar
.as
->rank
== 0)
5084 current_part_dimension
= 0;
5089 current_part_dimension
= 1;
5093 current_part_dimension
= 0;
5097 gfc_internal_error ("resolve_ref(): Bad array reference");
5103 if (current_part_dimension
|| seen_part_dimension
)
5106 if (ref
->u
.c
.component
->attr
.pointer
5107 || ref
->u
.c
.component
->attr
.proc_pointer
5108 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5109 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5111 gfc_error ("Component to the right of a part reference "
5112 "with nonzero rank must not have the POINTER "
5113 "attribute at %L", &expr
->where
);
5116 else if (ref
->u
.c
.component
->attr
.allocatable
5117 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5118 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5121 gfc_error ("Component to the right of a part reference "
5122 "with nonzero rank must not have the ALLOCATABLE "
5123 "attribute at %L", &expr
->where
);
5135 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5136 || ref
->next
== NULL
)
5137 && current_part_dimension
5138 && seen_part_dimension
)
5140 gfc_error ("Two or more part references with nonzero rank must "
5141 "not be specified at %L", &expr
->where
);
5145 if (ref
->type
== REF_COMPONENT
)
5147 if (current_part_dimension
)
5148 seen_part_dimension
= 1;
5150 /* reset to make sure */
5151 current_part_dimension
= 0;
5159 /* Given an expression, determine its shape. This is easier than it sounds.
5160 Leaves the shape array NULL if it is not possible to determine the shape. */
5163 expression_shape (gfc_expr
*e
)
5165 mpz_t array
[GFC_MAX_DIMENSIONS
];
5168 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5171 for (i
= 0; i
< e
->rank
; i
++)
5172 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5175 e
->shape
= gfc_get_shape (e
->rank
);
5177 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5182 for (i
--; i
>= 0; i
--)
5183 mpz_clear (array
[i
]);
5187 /* Given a variable expression node, compute the rank of the expression by
5188 examining the base symbol and any reference structures it may have. */
5191 expression_rank (gfc_expr
*e
)
5196 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5197 could lead to serious confusion... */
5198 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5202 if (e
->expr_type
== EXPR_ARRAY
)
5204 /* Constructors can have a rank different from one via RESHAPE(). */
5206 if (e
->symtree
== NULL
)
5212 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5213 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5219 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5221 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5222 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5223 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5225 if (ref
->type
!= REF_ARRAY
)
5228 if (ref
->u
.ar
.type
== AR_FULL
)
5230 rank
= ref
->u
.ar
.as
->rank
;
5234 if (ref
->u
.ar
.type
== AR_SECTION
)
5236 /* Figure out the rank of the section. */
5238 gfc_internal_error ("expression_rank(): Two array specs");
5240 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5241 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5242 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5252 expression_shape (e
);
5257 add_caf_get_intrinsic (gfc_expr
*e
)
5259 gfc_expr
*wrapper
, *tmp_expr
;
5263 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5264 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5269 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5270 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5273 tmp_expr
= XCNEW (gfc_expr
);
5275 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5276 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5277 wrapper
->ts
= e
->ts
;
5278 wrapper
->rank
= e
->rank
;
5280 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5287 remove_caf_get_intrinsic (gfc_expr
*e
)
5289 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5290 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5291 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5292 e
->value
.function
.actual
->expr
= NULL
;
5293 gfc_free_actual_arglist (e
->value
.function
.actual
);
5294 gfc_free_shape (&e
->shape
, e
->rank
);
5300 /* Resolve a variable expression. */
5303 resolve_variable (gfc_expr
*e
)
5310 if (e
->symtree
== NULL
)
5312 sym
= e
->symtree
->n
.sym
;
5314 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5315 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5316 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5318 if (!actual_arg
|| inquiry_argument
)
5320 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5321 "be used as actual argument", sym
->name
, &e
->where
);
5325 /* TS 29113, 407b. */
5326 else if (e
->ts
.type
== BT_ASSUMED
)
5330 gfc_error ("Assumed-type variable %s at %L may only be used "
5331 "as actual argument", sym
->name
, &e
->where
);
5334 else if (inquiry_argument
&& !first_actual_arg
)
5336 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5337 for all inquiry functions in resolve_function; the reason is
5338 that the function-name resolution happens too late in that
5340 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5341 "an inquiry function shall be the first argument",
5342 sym
->name
, &e
->where
);
5346 /* TS 29113, C535b. */
5347 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5348 && CLASS_DATA (sym
)->as
5349 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5350 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5351 && sym
->as
->type
== AS_ASSUMED_RANK
))
5355 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5356 "actual argument", sym
->name
, &e
->where
);
5359 else if (inquiry_argument
&& !first_actual_arg
)
5361 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5362 for all inquiry functions in resolve_function; the reason is
5363 that the function-name resolution happens too late in that
5365 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5366 "to an inquiry function shall be the first argument",
5367 sym
->name
, &e
->where
);
5372 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5373 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5374 && e
->ref
->next
== NULL
))
5376 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5377 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5380 /* TS 29113, 407b. */
5381 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5382 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5383 && e
->ref
->next
== NULL
))
5385 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5386 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5390 /* TS 29113, C535b. */
5391 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5392 && CLASS_DATA (sym
)->as
5393 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5394 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5395 && sym
->as
->type
== AS_ASSUMED_RANK
))
5397 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5398 && e
->ref
->next
== NULL
))
5400 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5401 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5405 /* For variables that are used in an associate (target => object) where
5406 the object's basetype is array valued while the target is scalar,
5407 the ts' type of the component refs is still array valued, which
5408 can't be translated that way. */
5409 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5410 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5411 && CLASS_DATA (sym
->assoc
->target
)->as
)
5413 gfc_ref
*ref
= e
->ref
;
5419 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5420 /* Stop the loop. */
5430 /* If this is an associate-name, it may be parsed with an array reference
5431 in error even though the target is scalar. Fail directly in this case.
5432 TODO Understand why class scalar expressions must be excluded. */
5433 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5435 if (sym
->ts
.type
== BT_CLASS
)
5436 gfc_fix_class_refs (e
);
5437 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5439 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5441 /* This can happen because the parser did not detect that the
5442 associate name is an array and the expression had no array
5444 gfc_ref
*ref
= gfc_get_ref ();
5445 ref
->type
= REF_ARRAY
;
5446 ref
->u
.ar
= *gfc_get_array_ref();
5447 ref
->u
.ar
.type
= AR_FULL
;
5450 ref
->u
.ar
.as
= sym
->as
;
5451 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5459 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5460 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5462 /* On the other hand, the parser may not have known this is an array;
5463 in this case, we have to add a FULL reference. */
5464 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5466 e
->ref
= gfc_get_ref ();
5467 e
->ref
->type
= REF_ARRAY
;
5468 e
->ref
->u
.ar
.type
= AR_FULL
;
5469 e
->ref
->u
.ar
.dimen
= 0;
5472 /* Like above, but for class types, where the checking whether an array
5473 ref is present is more complicated. Furthermore make sure not to add
5474 the full array ref to _vptr or _len refs. */
5475 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5476 && CLASS_DATA (sym
)->attr
.dimension
5477 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5479 gfc_ref
*ref
, *newref
;
5481 newref
= gfc_get_ref ();
5482 newref
->type
= REF_ARRAY
;
5483 newref
->u
.ar
.type
= AR_FULL
;
5484 newref
->u
.ar
.dimen
= 0;
5485 /* Because this is an associate var and the first ref either is a ref to
5486 the _data component or not, no traversal of the ref chain is
5487 needed. The array ref needs to be inserted after the _data ref,
5488 or when that is not present, which may happend for polymorphic
5489 types, then at the first position. */
5493 else if (ref
->type
== REF_COMPONENT
5494 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5496 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5498 newref
->next
= ref
->next
;
5502 /* Array ref present already. */
5503 gfc_free_ref_list (newref
);
5505 else if (ref
->type
== REF_ARRAY
)
5506 /* Array ref present already. */
5507 gfc_free_ref_list (newref
);
5515 if (e
->ref
&& !resolve_ref (e
))
5518 if (sym
->attr
.flavor
== FL_PROCEDURE
5519 && (!sym
->attr
.function
5520 || (sym
->attr
.function
&& sym
->result
5521 && sym
->result
->attr
.proc_pointer
5522 && !sym
->result
->attr
.function
)))
5524 e
->ts
.type
= BT_PROCEDURE
;
5525 goto resolve_procedure
;
5528 if (sym
->ts
.type
!= BT_UNKNOWN
)
5529 gfc_variable_attr (e
, &e
->ts
);
5530 else if (sym
->attr
.flavor
== FL_PROCEDURE
5531 && sym
->attr
.function
&& sym
->result
5532 && sym
->result
->ts
.type
!= BT_UNKNOWN
5533 && sym
->result
->attr
.proc_pointer
)
5534 e
->ts
= sym
->result
->ts
;
5537 /* Must be a simple variable reference. */
5538 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5543 if (check_assumed_size_reference (sym
, e
))
5546 /* Deal with forward references to entries during gfc_resolve_code, to
5547 satisfy, at least partially, 12.5.2.5. */
5548 if (gfc_current_ns
->entries
5549 && current_entry_id
== sym
->entry_id
5552 && cs_base
->current
->op
!= EXEC_ENTRY
)
5554 gfc_entry_list
*entry
;
5555 gfc_formal_arglist
*formal
;
5557 bool seen
, saved_specification_expr
;
5559 /* If the symbol is a dummy... */
5560 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5562 entry
= gfc_current_ns
->entries
;
5565 /* ...test if the symbol is a parameter of previous entries. */
5566 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5567 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5569 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5576 /* If it has not been seen as a dummy, this is an error. */
5579 if (specification_expr
)
5580 gfc_error ("Variable %qs, used in a specification expression"
5581 ", is referenced at %L before the ENTRY statement "
5582 "in which it is a parameter",
5583 sym
->name
, &cs_base
->current
->loc
);
5585 gfc_error ("Variable %qs is used at %L before the ENTRY "
5586 "statement in which it is a parameter",
5587 sym
->name
, &cs_base
->current
->loc
);
5592 /* Now do the same check on the specification expressions. */
5593 saved_specification_expr
= specification_expr
;
5594 specification_expr
= true;
5595 if (sym
->ts
.type
== BT_CHARACTER
5596 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5600 for (n
= 0; n
< sym
->as
->rank
; n
++)
5602 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5604 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5607 specification_expr
= saved_specification_expr
;
5610 /* Update the symbol's entry level. */
5611 sym
->entry_id
= current_entry_id
+ 1;
5614 /* If a symbol has been host_associated mark it. This is used latter,
5615 to identify if aliasing is possible via host association. */
5616 if (sym
->attr
.flavor
== FL_VARIABLE
5617 && gfc_current_ns
->parent
5618 && (gfc_current_ns
->parent
== sym
->ns
5619 || (gfc_current_ns
->parent
->parent
5620 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5621 sym
->attr
.host_assoc
= 1;
5623 if (gfc_current_ns
->proc_name
5624 && sym
->attr
.dimension
5625 && (sym
->ns
!= gfc_current_ns
5626 || sym
->attr
.use_assoc
5627 || sym
->attr
.in_common
))
5628 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5631 if (t
&& !resolve_procedure_expression (e
))
5634 /* F2008, C617 and C1229. */
5635 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5636 && gfc_is_coindexed (e
))
5638 gfc_ref
*ref
, *ref2
= NULL
;
5640 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5642 if (ref
->type
== REF_COMPONENT
)
5644 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5648 for ( ; ref
; ref
= ref
->next
)
5649 if (ref
->type
== REF_COMPONENT
)
5652 /* Expression itself is not coindexed object. */
5653 if (ref
&& e
->ts
.type
== BT_CLASS
)
5655 gfc_error ("Polymorphic subobject of coindexed object at %L",
5660 /* Expression itself is coindexed object. */
5664 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5665 for ( ; c
; c
= c
->next
)
5666 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5668 gfc_error ("Coindexed object with polymorphic allocatable "
5669 "subcomponent at %L", &e
->where
);
5677 expression_rank (e
);
5679 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5680 add_caf_get_intrinsic (e
);
5682 /* Simplify cases where access to a parameter array results in a
5683 single constant. Suppress errors since those will have been
5684 issued before, as warnings. */
5685 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5687 gfc_push_suppress_errors ();
5688 gfc_simplify_expr (e
, 1);
5689 gfc_pop_suppress_errors ();
5696 /* Checks to see that the correct symbol has been host associated.
5697 The only situation where this arises is that in which a twice
5698 contained function is parsed after the host association is made.
5699 Therefore, on detecting this, change the symbol in the expression
5700 and convert the array reference into an actual arglist if the old
5701 symbol is a variable. */
5703 check_host_association (gfc_expr
*e
)
5705 gfc_symbol
*sym
, *old_sym
;
5709 gfc_actual_arglist
*arg
, *tail
= NULL
;
5710 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5712 /* If the expression is the result of substitution in
5713 interface.c(gfc_extend_expr) because there is no way in
5714 which the host association can be wrong. */
5715 if (e
->symtree
== NULL
5716 || e
->symtree
->n
.sym
== NULL
5717 || e
->user_operator
)
5720 old_sym
= e
->symtree
->n
.sym
;
5722 if (gfc_current_ns
->parent
5723 && old_sym
->ns
!= gfc_current_ns
)
5725 /* Use the 'USE' name so that renamed module symbols are
5726 correctly handled. */
5727 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5729 if (sym
&& old_sym
!= sym
5730 && sym
->ts
.type
== old_sym
->ts
.type
5731 && sym
->attr
.flavor
== FL_PROCEDURE
5732 && sym
->attr
.contained
)
5734 /* Clear the shape, since it might not be valid. */
5735 gfc_free_shape (&e
->shape
, e
->rank
);
5737 /* Give the expression the right symtree! */
5738 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5739 gcc_assert (st
!= NULL
);
5741 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5742 || e
->expr_type
== EXPR_FUNCTION
)
5744 /* Original was function so point to the new symbol, since
5745 the actual argument list is already attached to the
5747 e
->value
.function
.esym
= NULL
;
5752 /* Original was variable so convert array references into
5753 an actual arglist. This does not need any checking now
5754 since resolve_function will take care of it. */
5755 e
->value
.function
.actual
= NULL
;
5756 e
->expr_type
= EXPR_FUNCTION
;
5759 /* Ambiguity will not arise if the array reference is not
5760 the last reference. */
5761 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5762 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5765 gcc_assert (ref
->type
== REF_ARRAY
);
5767 /* Grab the start expressions from the array ref and
5768 copy them into actual arguments. */
5769 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5771 arg
= gfc_get_actual_arglist ();
5772 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5773 if (e
->value
.function
.actual
== NULL
)
5774 tail
= e
->value
.function
.actual
= arg
;
5782 /* Dump the reference list and set the rank. */
5783 gfc_free_ref_list (e
->ref
);
5785 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5788 gfc_resolve_expr (e
);
5792 /* This might have changed! */
5793 return e
->expr_type
== EXPR_FUNCTION
;
5798 gfc_resolve_character_operator (gfc_expr
*e
)
5800 gfc_expr
*op1
= e
->value
.op
.op1
;
5801 gfc_expr
*op2
= e
->value
.op
.op2
;
5802 gfc_expr
*e1
= NULL
;
5803 gfc_expr
*e2
= NULL
;
5805 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5807 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5808 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5809 else if (op1
->expr_type
== EXPR_CONSTANT
)
5810 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5811 op1
->value
.character
.length
);
5813 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5814 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5815 else if (op2
->expr_type
== EXPR_CONSTANT
)
5816 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5817 op2
->value
.character
.length
);
5819 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5829 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5830 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5831 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5832 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5833 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5839 /* Ensure that an character expression has a charlen and, if possible, a
5840 length expression. */
5843 fixup_charlen (gfc_expr
*e
)
5845 /* The cases fall through so that changes in expression type and the need
5846 for multiple fixes are picked up. In all circumstances, a charlen should
5847 be available for the middle end to hang a backend_decl on. */
5848 switch (e
->expr_type
)
5851 gfc_resolve_character_operator (e
);
5855 if (e
->expr_type
== EXPR_ARRAY
)
5856 gfc_resolve_character_array_constructor (e
);
5859 case EXPR_SUBSTRING
:
5860 if (!e
->ts
.u
.cl
&& e
->ref
)
5861 gfc_resolve_substring_charlen (e
);
5866 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5873 /* Update an actual argument to include the passed-object for type-bound
5874 procedures at the right position. */
5876 static gfc_actual_arglist
*
5877 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5880 gcc_assert (argpos
> 0);
5884 gfc_actual_arglist
* result
;
5886 result
= gfc_get_actual_arglist ();
5890 result
->name
= name
;
5896 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5898 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5903 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5906 extract_compcall_passed_object (gfc_expr
* e
)
5910 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5912 if (e
->value
.compcall
.base_object
)
5913 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5916 po
= gfc_get_expr ();
5917 po
->expr_type
= EXPR_VARIABLE
;
5918 po
->symtree
= e
->symtree
;
5919 po
->ref
= gfc_copy_ref (e
->ref
);
5920 po
->where
= e
->where
;
5923 if (!gfc_resolve_expr (po
))
5930 /* Update the arglist of an EXPR_COMPCALL expression to include the
5934 update_compcall_arglist (gfc_expr
* e
)
5937 gfc_typebound_proc
* tbp
;
5939 tbp
= e
->value
.compcall
.tbp
;
5944 po
= extract_compcall_passed_object (e
);
5948 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5954 if (tbp
->pass_arg_num
<= 0)
5957 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5965 /* Extract the passed object from a PPC call (a copy of it). */
5968 extract_ppc_passed_object (gfc_expr
*e
)
5973 po
= gfc_get_expr ();
5974 po
->expr_type
= EXPR_VARIABLE
;
5975 po
->symtree
= e
->symtree
;
5976 po
->ref
= gfc_copy_ref (e
->ref
);
5977 po
->where
= e
->where
;
5979 /* Remove PPC reference. */
5981 while ((*ref
)->next
)
5982 ref
= &(*ref
)->next
;
5983 gfc_free_ref_list (*ref
);
5986 if (!gfc_resolve_expr (po
))
5993 /* Update the actual arglist of a procedure pointer component to include the
5997 update_ppc_arglist (gfc_expr
* e
)
6001 gfc_typebound_proc
* tb
;
6003 ppc
= gfc_get_proc_ptr_comp (e
);
6011 else if (tb
->nopass
)
6014 po
= extract_ppc_passed_object (e
);
6021 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6026 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6028 gfc_error ("Base object for procedure-pointer component call at %L is of"
6029 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6033 gcc_assert (tb
->pass_arg_num
> 0);
6034 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6042 /* Check that the object a TBP is called on is valid, i.e. it must not be
6043 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6046 check_typebound_baseobject (gfc_expr
* e
)
6049 bool return_value
= false;
6051 base
= extract_compcall_passed_object (e
);
6055 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
6057 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6061 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6063 gfc_error ("Base object for type-bound procedure call at %L is of"
6064 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6068 /* F08:C1230. If the procedure called is NOPASS,
6069 the base object must be scalar. */
6070 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6072 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6073 " be scalar", &e
->where
);
6077 return_value
= true;
6080 gfc_free_expr (base
);
6081 return return_value
;
6085 /* Resolve a call to a type-bound procedure, either function or subroutine,
6086 statically from the data in an EXPR_COMPCALL expression. The adapted
6087 arglist and the target-procedure symtree are returned. */
6090 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6091 gfc_actual_arglist
** actual
)
6093 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6094 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6096 /* Update the actual arglist for PASS. */
6097 if (!update_compcall_arglist (e
))
6100 *actual
= e
->value
.compcall
.actual
;
6101 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6103 gfc_free_ref_list (e
->ref
);
6105 e
->value
.compcall
.actual
= NULL
;
6107 /* If we find a deferred typebound procedure, check for derived types
6108 that an overriding typebound procedure has not been missed. */
6109 if (e
->value
.compcall
.name
6110 && !e
->value
.compcall
.tbp
->non_overridable
6111 && e
->value
.compcall
.base_object
6112 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6115 gfc_symbol
*derived
;
6117 /* Use the derived type of the base_object. */
6118 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6121 /* If necessary, go through the inheritance chain. */
6122 while (!st
&& derived
)
6124 /* Look for the typebound procedure 'name'. */
6125 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6126 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6127 e
->value
.compcall
.name
);
6129 derived
= gfc_get_derived_super_type (derived
);
6132 /* Now find the specific name in the derived type namespace. */
6133 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6134 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6135 derived
->ns
, 1, &st
);
6143 /* Get the ultimate declared type from an expression. In addition,
6144 return the last class/derived type reference and the copy of the
6145 reference list. If check_types is set true, derived types are
6146 identified as well as class references. */
6148 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6149 gfc_expr
*e
, bool check_types
)
6151 gfc_symbol
*declared
;
6158 *new_ref
= gfc_copy_ref (e
->ref
);
6160 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6162 if (ref
->type
!= REF_COMPONENT
)
6165 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6166 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6167 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6169 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6175 if (declared
== NULL
)
6176 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6182 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6183 which of the specific bindings (if any) matches the arglist and transform
6184 the expression into a call of that binding. */
6187 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6189 gfc_typebound_proc
* genproc
;
6190 const char* genname
;
6192 gfc_symbol
*derived
;
6194 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6195 genname
= e
->value
.compcall
.name
;
6196 genproc
= e
->value
.compcall
.tbp
;
6198 if (!genproc
->is_generic
)
6201 /* Try the bindings on this type and in the inheritance hierarchy. */
6202 for (; genproc
; genproc
= genproc
->overridden
)
6206 gcc_assert (genproc
->is_generic
);
6207 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6210 gfc_actual_arglist
* args
;
6213 gcc_assert (g
->specific
);
6215 if (g
->specific
->error
)
6218 target
= g
->specific
->u
.specific
->n
.sym
;
6220 /* Get the right arglist by handling PASS/NOPASS. */
6221 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6222 if (!g
->specific
->nopass
)
6225 po
= extract_compcall_passed_object (e
);
6228 gfc_free_actual_arglist (args
);
6232 gcc_assert (g
->specific
->pass_arg_num
> 0);
6233 gcc_assert (!g
->specific
->error
);
6234 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6235 g
->specific
->pass_arg
);
6237 resolve_actual_arglist (args
, target
->attr
.proc
,
6238 is_external_proc (target
)
6239 && gfc_sym_get_dummy_args (target
) == NULL
);
6241 /* Check if this arglist matches the formal. */
6242 matches
= gfc_arglist_matches_symbol (&args
, target
);
6244 /* Clean up and break out of the loop if we've found it. */
6245 gfc_free_actual_arglist (args
);
6248 e
->value
.compcall
.tbp
= g
->specific
;
6249 genname
= g
->specific_st
->name
;
6250 /* Pass along the name for CLASS methods, where the vtab
6251 procedure pointer component has to be referenced. */
6259 /* Nothing matching found! */
6260 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6261 " %qs at %L", genname
, &e
->where
);
6265 /* Make sure that we have the right specific instance for the name. */
6266 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6268 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6270 e
->value
.compcall
.tbp
= st
->n
.tb
;
6276 /* Resolve a call to a type-bound subroutine. */
6279 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6281 gfc_actual_arglist
* newactual
;
6282 gfc_symtree
* target
;
6284 /* Check that's really a SUBROUTINE. */
6285 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6287 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6288 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6289 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6290 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6291 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6294 gfc_error ("%qs at %L should be a SUBROUTINE",
6295 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6300 if (!check_typebound_baseobject (c
->expr1
))
6303 /* Pass along the name for CLASS methods, where the vtab
6304 procedure pointer component has to be referenced. */
6306 *name
= c
->expr1
->value
.compcall
.name
;
6308 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6311 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6313 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6315 /* Transform into an ordinary EXEC_CALL for now. */
6317 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6320 c
->ext
.actual
= newactual
;
6321 c
->symtree
= target
;
6322 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6324 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6326 gfc_free_expr (c
->expr1
);
6327 c
->expr1
= gfc_get_expr ();
6328 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6329 c
->expr1
->symtree
= target
;
6330 c
->expr1
->where
= c
->loc
;
6332 return resolve_call (c
);
6336 /* Resolve a component-call expression. */
6338 resolve_compcall (gfc_expr
* e
, const char **name
)
6340 gfc_actual_arglist
* newactual
;
6341 gfc_symtree
* target
;
6343 /* Check that's really a FUNCTION. */
6344 if (!e
->value
.compcall
.tbp
->function
)
6346 gfc_error ("%qs at %L should be a FUNCTION",
6347 e
->value
.compcall
.name
, &e
->where
);
6351 /* These must not be assign-calls! */
6352 gcc_assert (!e
->value
.compcall
.assign
);
6354 if (!check_typebound_baseobject (e
))
6357 /* Pass along the name for CLASS methods, where the vtab
6358 procedure pointer component has to be referenced. */
6360 *name
= e
->value
.compcall
.name
;
6362 if (!resolve_typebound_generic_call (e
, name
))
6364 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6366 /* Take the rank from the function's symbol. */
6367 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6368 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6370 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6371 arglist to the TBP's binding target. */
6373 if (!resolve_typebound_static (e
, &target
, &newactual
))
6376 e
->value
.function
.actual
= newactual
;
6377 e
->value
.function
.name
= NULL
;
6378 e
->value
.function
.esym
= target
->n
.sym
;
6379 e
->value
.function
.isym
= NULL
;
6380 e
->symtree
= target
;
6381 e
->ts
= target
->n
.sym
->ts
;
6382 e
->expr_type
= EXPR_FUNCTION
;
6384 /* Resolution is not necessary if this is a class subroutine; this
6385 function only has to identify the specific proc. Resolution of
6386 the call will be done next in resolve_typebound_call. */
6387 return gfc_resolve_expr (e
);
6391 static bool resolve_fl_derived (gfc_symbol
*sym
);
6394 /* Resolve a typebound function, or 'method'. First separate all
6395 the non-CLASS references by calling resolve_compcall directly. */
6398 resolve_typebound_function (gfc_expr
* e
)
6400 gfc_symbol
*declared
;
6412 /* Deal with typebound operators for CLASS objects. */
6413 expr
= e
->value
.compcall
.base_object
;
6414 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6415 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6417 /* If the base_object is not a variable, the corresponding actual
6418 argument expression must be stored in e->base_expression so
6419 that the corresponding tree temporary can be used as the base
6420 object in gfc_conv_procedure_call. */
6421 if (expr
->expr_type
!= EXPR_VARIABLE
)
6423 gfc_actual_arglist
*args
;
6425 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6427 if (expr
== args
->expr
)
6432 /* Since the typebound operators are generic, we have to ensure
6433 that any delays in resolution are corrected and that the vtab
6436 declared
= ts
.u
.derived
;
6437 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6438 if (c
->ts
.u
.derived
== NULL
)
6439 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6441 if (!resolve_compcall (e
, &name
))
6444 /* Use the generic name if it is there. */
6445 name
= name
? name
: e
->value
.function
.esym
->name
;
6446 e
->symtree
= expr
->symtree
;
6447 e
->ref
= gfc_copy_ref (expr
->ref
);
6448 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6450 /* Trim away the extraneous references that emerge from nested
6451 use of interface.c (extend_expr). */
6452 if (class_ref
&& class_ref
->next
)
6454 gfc_free_ref_list (class_ref
->next
);
6455 class_ref
->next
= NULL
;
6457 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6459 gfc_free_ref_list (e
->ref
);
6463 gfc_add_vptr_component (e
);
6464 gfc_add_component_ref (e
, name
);
6465 e
->value
.function
.esym
= NULL
;
6466 if (expr
->expr_type
!= EXPR_VARIABLE
)
6467 e
->base_expr
= expr
;
6472 return resolve_compcall (e
, NULL
);
6474 if (!resolve_ref (e
))
6477 /* Get the CLASS declared type. */
6478 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6480 if (!resolve_fl_derived (declared
))
6483 /* Weed out cases of the ultimate component being a derived type. */
6484 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6485 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6487 gfc_free_ref_list (new_ref
);
6488 return resolve_compcall (e
, NULL
);
6491 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6492 declared
= c
->ts
.u
.derived
;
6494 /* Treat the call as if it is a typebound procedure, in order to roll
6495 out the correct name for the specific function. */
6496 if (!resolve_compcall (e
, &name
))
6498 gfc_free_ref_list (new_ref
);
6505 /* Convert the expression to a procedure pointer component call. */
6506 e
->value
.function
.esym
= NULL
;
6512 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6513 gfc_add_vptr_component (e
);
6514 gfc_add_component_ref (e
, name
);
6516 /* Recover the typespec for the expression. This is really only
6517 necessary for generic procedures, where the additional call
6518 to gfc_add_component_ref seems to throw the collection of the
6519 correct typespec. */
6523 gfc_free_ref_list (new_ref
);
6528 /* Resolve a typebound subroutine, or 'method'. First separate all
6529 the non-CLASS references by calling resolve_typebound_call
6533 resolve_typebound_subroutine (gfc_code
*code
)
6535 gfc_symbol
*declared
;
6545 st
= code
->expr1
->symtree
;
6547 /* Deal with typebound operators for CLASS objects. */
6548 expr
= code
->expr1
->value
.compcall
.base_object
;
6549 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6550 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6552 /* If the base_object is not a variable, the corresponding actual
6553 argument expression must be stored in e->base_expression so
6554 that the corresponding tree temporary can be used as the base
6555 object in gfc_conv_procedure_call. */
6556 if (expr
->expr_type
!= EXPR_VARIABLE
)
6558 gfc_actual_arglist
*args
;
6560 args
= code
->expr1
->value
.function
.actual
;
6561 for (; args
; args
= args
->next
)
6562 if (expr
== args
->expr
)
6566 /* Since the typebound operators are generic, we have to ensure
6567 that any delays in resolution are corrected and that the vtab
6569 declared
= expr
->ts
.u
.derived
;
6570 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6571 if (c
->ts
.u
.derived
== NULL
)
6572 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6574 if (!resolve_typebound_call (code
, &name
, NULL
))
6577 /* Use the generic name if it is there. */
6578 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6579 code
->expr1
->symtree
= expr
->symtree
;
6580 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6582 /* Trim away the extraneous references that emerge from nested
6583 use of interface.c (extend_expr). */
6584 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6585 if (class_ref
&& class_ref
->next
)
6587 gfc_free_ref_list (class_ref
->next
);
6588 class_ref
->next
= NULL
;
6590 else if (code
->expr1
->ref
&& !class_ref
)
6592 gfc_free_ref_list (code
->expr1
->ref
);
6593 code
->expr1
->ref
= NULL
;
6596 /* Now use the procedure in the vtable. */
6597 gfc_add_vptr_component (code
->expr1
);
6598 gfc_add_component_ref (code
->expr1
, name
);
6599 code
->expr1
->value
.function
.esym
= NULL
;
6600 if (expr
->expr_type
!= EXPR_VARIABLE
)
6601 code
->expr1
->base_expr
= expr
;
6606 return resolve_typebound_call (code
, NULL
, NULL
);
6608 if (!resolve_ref (code
->expr1
))
6611 /* Get the CLASS declared type. */
6612 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6614 /* Weed out cases of the ultimate component being a derived type. */
6615 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6616 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6618 gfc_free_ref_list (new_ref
);
6619 return resolve_typebound_call (code
, NULL
, NULL
);
6622 if (!resolve_typebound_call (code
, &name
, &overridable
))
6624 gfc_free_ref_list (new_ref
);
6627 ts
= code
->expr1
->ts
;
6631 /* Convert the expression to a procedure pointer component call. */
6632 code
->expr1
->value
.function
.esym
= NULL
;
6633 code
->expr1
->symtree
= st
;
6636 code
->expr1
->ref
= new_ref
;
6638 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6639 gfc_add_vptr_component (code
->expr1
);
6640 gfc_add_component_ref (code
->expr1
, name
);
6642 /* Recover the typespec for the expression. This is really only
6643 necessary for generic procedures, where the additional call
6644 to gfc_add_component_ref seems to throw the collection of the
6645 correct typespec. */
6646 code
->expr1
->ts
= ts
;
6649 gfc_free_ref_list (new_ref
);
6655 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6658 resolve_ppc_call (gfc_code
* c
)
6660 gfc_component
*comp
;
6662 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6663 gcc_assert (comp
!= NULL
);
6665 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6666 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6668 if (!comp
->attr
.subroutine
)
6669 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6671 if (!resolve_ref (c
->expr1
))
6674 if (!update_ppc_arglist (c
->expr1
))
6677 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6679 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6680 !(comp
->ts
.interface
6681 && comp
->ts
.interface
->formal
)))
6684 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6687 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6693 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6696 resolve_expr_ppc (gfc_expr
* e
)
6698 gfc_component
*comp
;
6700 comp
= gfc_get_proc_ptr_comp (e
);
6701 gcc_assert (comp
!= NULL
);
6703 /* Convert to EXPR_FUNCTION. */
6704 e
->expr_type
= EXPR_FUNCTION
;
6705 e
->value
.function
.isym
= NULL
;
6706 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6708 if (comp
->as
!= NULL
)
6709 e
->rank
= comp
->as
->rank
;
6711 if (!comp
->attr
.function
)
6712 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6714 if (!resolve_ref (e
))
6717 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6718 !(comp
->ts
.interface
6719 && comp
->ts
.interface
->formal
)))
6722 if (!update_ppc_arglist (e
))
6725 if (!check_pure_function(e
))
6728 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6735 gfc_is_expandable_expr (gfc_expr
*e
)
6737 gfc_constructor
*con
;
6739 if (e
->expr_type
== EXPR_ARRAY
)
6741 /* Traverse the constructor looking for variables that are flavor
6742 parameter. Parameters must be expanded since they are fully used at
6744 con
= gfc_constructor_first (e
->value
.constructor
);
6745 for (; con
; con
= gfc_constructor_next (con
))
6747 if (con
->expr
->expr_type
== EXPR_VARIABLE
6748 && con
->expr
->symtree
6749 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6750 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6752 if (con
->expr
->expr_type
== EXPR_ARRAY
6753 && gfc_is_expandable_expr (con
->expr
))
6762 /* Sometimes variables in specification expressions of the result
6763 of module procedures in submodules wind up not being the 'real'
6764 dummy. Find this, if possible, in the namespace of the first
6768 fixup_unique_dummy (gfc_expr
*e
)
6770 gfc_symtree
*st
= NULL
;
6771 gfc_symbol
*s
= NULL
;
6773 if (e
->symtree
->n
.sym
->ns
->proc_name
6774 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6775 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6778 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6781 && st
->n
.sym
!= NULL
6782 && st
->n
.sym
->attr
.dummy
)
6786 /* Resolve an expression. That is, make sure that types of operands agree
6787 with their operators, intrinsic operators are converted to function calls
6788 for overloaded types and unresolved function references are resolved. */
6791 gfc_resolve_expr (gfc_expr
*e
)
6794 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6799 /* inquiry_argument only applies to variables. */
6800 inquiry_save
= inquiry_argument
;
6801 actual_arg_save
= actual_arg
;
6802 first_actual_arg_save
= first_actual_arg
;
6804 if (e
->expr_type
!= EXPR_VARIABLE
)
6806 inquiry_argument
= false;
6808 first_actual_arg
= false;
6810 else if (e
->symtree
!= NULL
6811 && *e
->symtree
->name
== '@'
6812 && e
->symtree
->n
.sym
->attr
.dummy
)
6814 /* Deal with submodule specification expressions that are not
6815 found to be referenced in module.c(read_cleanup). */
6816 fixup_unique_dummy (e
);
6819 switch (e
->expr_type
)
6822 t
= resolve_operator (e
);
6828 if (check_host_association (e
))
6829 t
= resolve_function (e
);
6831 t
= resolve_variable (e
);
6833 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6834 && e
->ref
->type
!= REF_SUBSTRING
)
6835 gfc_resolve_substring_charlen (e
);
6840 t
= resolve_typebound_function (e
);
6843 case EXPR_SUBSTRING
:
6844 t
= resolve_ref (e
);
6853 t
= resolve_expr_ppc (e
);
6858 if (!resolve_ref (e
))
6861 t
= gfc_resolve_array_constructor (e
);
6862 /* Also try to expand a constructor. */
6865 expression_rank (e
);
6866 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6867 gfc_expand_constructor (e
, false);
6870 /* This provides the opportunity for the length of constructors with
6871 character valued function elements to propagate the string length
6872 to the expression. */
6873 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6875 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6876 here rather then add a duplicate test for it above. */
6877 gfc_expand_constructor (e
, false);
6878 t
= gfc_resolve_character_array_constructor (e
);
6883 case EXPR_STRUCTURE
:
6884 t
= resolve_ref (e
);
6888 t
= resolve_structure_cons (e
, 0);
6892 t
= gfc_simplify_expr (e
, 0);
6896 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6899 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6902 inquiry_argument
= inquiry_save
;
6903 actual_arg
= actual_arg_save
;
6904 first_actual_arg
= first_actual_arg_save
;
6910 /* Resolve an expression from an iterator. They must be scalar and have
6911 INTEGER or (optionally) REAL type. */
6914 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6915 const char *name_msgid
)
6917 if (!gfc_resolve_expr (expr
))
6920 if (expr
->rank
!= 0)
6922 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6926 if (expr
->ts
.type
!= BT_INTEGER
)
6928 if (expr
->ts
.type
== BT_REAL
)
6931 return gfc_notify_std (GFC_STD_F95_DEL
,
6932 "%s at %L must be integer",
6933 _(name_msgid
), &expr
->where
);
6936 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6943 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6951 /* Resolve the expressions in an iterator structure. If REAL_OK is
6952 false allow only INTEGER type iterators, otherwise allow REAL types.
6953 Set own_scope to true for ac-implied-do and data-implied-do as those
6954 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6957 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6959 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6962 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6963 _("iterator variable")))
6966 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6967 "Start expression in DO loop"))
6970 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6971 "End expression in DO loop"))
6974 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6975 "Step expression in DO loop"))
6978 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6980 if ((iter
->step
->ts
.type
== BT_INTEGER
6981 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6982 || (iter
->step
->ts
.type
== BT_REAL
6983 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6985 gfc_error ("Step expression in DO loop at %L cannot be zero",
6986 &iter
->step
->where
);
6991 /* Convert start, end, and step to the same type as var. */
6992 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6993 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6994 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6996 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6997 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6998 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7000 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7001 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7002 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7004 if (iter
->start
->expr_type
== EXPR_CONSTANT
7005 && iter
->end
->expr_type
== EXPR_CONSTANT
7006 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7009 if (iter
->start
->ts
.type
== BT_INTEGER
)
7011 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7012 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7016 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7017 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7019 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7020 gfc_warning (OPT_Wzerotrip
,
7021 "DO loop at %L will be executed zero times",
7022 &iter
->step
->where
);
7025 if (iter
->end
->expr_type
== EXPR_CONSTANT
7026 && iter
->end
->ts
.type
== BT_INTEGER
7027 && iter
->step
->expr_type
== EXPR_CONSTANT
7028 && iter
->step
->ts
.type
== BT_INTEGER
7029 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7030 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7032 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7033 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7035 if (is_step_positive
7036 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7037 gfc_warning (OPT_Wundefined_do_loop
,
7038 "DO loop at %L is undefined as it overflows",
7039 &iter
->step
->where
);
7040 else if (!is_step_positive
7041 && mpz_cmp (iter
->end
->value
.integer
,
7042 gfc_integer_kinds
[k
].min_int
) == 0)
7043 gfc_warning (OPT_Wundefined_do_loop
,
7044 "DO loop at %L is undefined as it underflows",
7045 &iter
->step
->where
);
7052 /* Traversal function for find_forall_index. f == 2 signals that
7053 that variable itself is not to be checked - only the references. */
7056 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7058 if (expr
->expr_type
!= EXPR_VARIABLE
)
7061 /* A scalar assignment */
7062 if (!expr
->ref
|| *f
== 1)
7064 if (expr
->symtree
->n
.sym
== sym
)
7076 /* Check whether the FORALL index appears in the expression or not.
7077 Returns true if SYM is found in EXPR. */
7080 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7082 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7089 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7090 to be a scalar INTEGER variable. The subscripts and stride are scalar
7091 INTEGERs, and if stride is a constant it must be nonzero.
7092 Furthermore "A subscript or stride in a forall-triplet-spec shall
7093 not contain a reference to any index-name in the
7094 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7097 resolve_forall_iterators (gfc_forall_iterator
*it
)
7099 gfc_forall_iterator
*iter
, *iter2
;
7101 for (iter
= it
; iter
; iter
= iter
->next
)
7103 if (gfc_resolve_expr (iter
->var
)
7104 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7105 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7108 if (gfc_resolve_expr (iter
->start
)
7109 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7110 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7111 &iter
->start
->where
);
7112 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7113 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7115 if (gfc_resolve_expr (iter
->end
)
7116 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7117 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7119 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7120 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7122 if (gfc_resolve_expr (iter
->stride
))
7124 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7125 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7126 &iter
->stride
->where
, "INTEGER");
7128 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7129 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7130 gfc_error ("FORALL stride expression at %L cannot be zero",
7131 &iter
->stride
->where
);
7133 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7134 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7137 for (iter
= it
; iter
; iter
= iter
->next
)
7138 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7140 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7141 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7142 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7143 gfc_error ("FORALL index %qs may not appear in triplet "
7144 "specification at %L", iter
->var
->symtree
->name
,
7145 &iter2
->start
->where
);
7150 /* Given a pointer to a symbol that is a derived type, see if it's
7151 inaccessible, i.e. if it's defined in another module and the components are
7152 PRIVATE. The search is recursive if necessary. Returns zero if no
7153 inaccessible components are found, nonzero otherwise. */
7156 derived_inaccessible (gfc_symbol
*sym
)
7160 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7163 for (c
= sym
->components
; c
; c
= c
->next
)
7165 /* Prevent an infinite loop through this function. */
7166 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7167 && sym
== c
->ts
.u
.derived
)
7170 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7178 /* Resolve the argument of a deallocate expression. The expression must be
7179 a pointer or a full array. */
7182 resolve_deallocate_expr (gfc_expr
*e
)
7184 symbol_attribute attr
;
7185 int allocatable
, pointer
;
7191 if (!gfc_resolve_expr (e
))
7194 if (e
->expr_type
!= EXPR_VARIABLE
)
7197 sym
= e
->symtree
->n
.sym
;
7198 unlimited
= UNLIMITED_POLY(sym
);
7200 if (sym
->ts
.type
== BT_CLASS
)
7202 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7203 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7207 allocatable
= sym
->attr
.allocatable
;
7208 pointer
= sym
->attr
.pointer
;
7210 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7215 if (ref
->u
.ar
.type
!= AR_FULL
7216 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7217 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7222 c
= ref
->u
.c
.component
;
7223 if (c
->ts
.type
== BT_CLASS
)
7225 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7226 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7230 allocatable
= c
->attr
.allocatable
;
7231 pointer
= c
->attr
.pointer
;
7241 attr
= gfc_expr_attr (e
);
7243 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7246 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7252 if (gfc_is_coindexed (e
))
7254 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7259 && !gfc_check_vardef_context (e
, true, true, false,
7260 _("DEALLOCATE object")))
7262 if (!gfc_check_vardef_context (e
, false, true, false,
7263 _("DEALLOCATE object")))
7270 /* Returns true if the expression e contains a reference to the symbol sym. */
7272 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7274 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7281 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7283 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7287 /* Given the expression node e for an allocatable/pointer of derived type to be
7288 allocated, get the expression node to be initialized afterwards (needed for
7289 derived types with default initializers, and derived types with allocatable
7290 components that need nullification.) */
7293 gfc_expr_to_initialize (gfc_expr
*e
)
7299 result
= gfc_copy_expr (e
);
7301 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7302 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7303 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7305 ref
->u
.ar
.type
= AR_FULL
;
7307 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7308 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7313 gfc_free_shape (&result
->shape
, result
->rank
);
7315 /* Recalculate rank, shape, etc. */
7316 gfc_resolve_expr (result
);
7321 /* If the last ref of an expression is an array ref, return a copy of the
7322 expression with that one removed. Otherwise, a copy of the original
7323 expression. This is used for allocate-expressions and pointer assignment
7324 LHS, where there may be an array specification that needs to be stripped
7325 off when using gfc_check_vardef_context. */
7328 remove_last_array_ref (gfc_expr
* e
)
7333 e2
= gfc_copy_expr (e
);
7334 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7335 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7337 gfc_free_ref_list (*r
);
7346 /* Used in resolve_allocate_expr to check that a allocation-object and
7347 a source-expr are conformable. This does not catch all possible
7348 cases; in particular a runtime checking is needed. */
7351 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7354 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7356 /* First compare rank. */
7357 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7358 || (!tail
&& e1
->rank
!= e2
->rank
))
7360 gfc_error ("Source-expr at %L must be scalar or have the "
7361 "same rank as the allocate-object at %L",
7362 &e1
->where
, &e2
->where
);
7373 for (i
= 0; i
< e1
->rank
; i
++)
7375 if (tail
->u
.ar
.start
[i
] == NULL
)
7378 if (tail
->u
.ar
.end
[i
])
7380 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7381 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7382 mpz_add_ui (s
, s
, 1);
7386 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7389 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7391 gfc_error ("Source-expr at %L and allocate-object at %L must "
7392 "have the same shape", &e1
->where
, &e2
->where
);
7405 /* Resolve the expression in an ALLOCATE statement, doing the additional
7406 checks to see whether the expression is OK or not. The expression must
7407 have a trailing array reference that gives the size of the array. */
7410 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7412 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7416 symbol_attribute attr
;
7417 gfc_ref
*ref
, *ref2
;
7420 gfc_symbol
*sym
= NULL
;
7425 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7426 checking of coarrays. */
7427 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7428 if (ref
->next
== NULL
)
7431 if (ref
&& ref
->type
== REF_ARRAY
)
7432 ref
->u
.ar
.in_allocate
= true;
7434 if (!gfc_resolve_expr (e
))
7437 /* Make sure the expression is allocatable or a pointer. If it is
7438 pointer, the next-to-last reference must be a pointer. */
7442 sym
= e
->symtree
->n
.sym
;
7444 /* Check whether ultimate component is abstract and CLASS. */
7447 /* Is the allocate-object unlimited polymorphic? */
7448 unlimited
= UNLIMITED_POLY(e
);
7450 if (e
->expr_type
!= EXPR_VARIABLE
)
7453 attr
= gfc_expr_attr (e
);
7454 pointer
= attr
.pointer
;
7455 dimension
= attr
.dimension
;
7456 codimension
= attr
.codimension
;
7460 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7462 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7463 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7464 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7465 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7466 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7470 allocatable
= sym
->attr
.allocatable
;
7471 pointer
= sym
->attr
.pointer
;
7472 dimension
= sym
->attr
.dimension
;
7473 codimension
= sym
->attr
.codimension
;
7478 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7483 if (ref
->u
.ar
.codimen
> 0)
7486 for (n
= ref
->u
.ar
.dimen
;
7487 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7488 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7495 if (ref
->next
!= NULL
)
7503 gfc_error ("Coindexed allocatable object at %L",
7508 c
= ref
->u
.c
.component
;
7509 if (c
->ts
.type
== BT_CLASS
)
7511 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7512 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7513 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7514 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7515 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7519 allocatable
= c
->attr
.allocatable
;
7520 pointer
= c
->attr
.pointer
;
7521 dimension
= c
->attr
.dimension
;
7522 codimension
= c
->attr
.codimension
;
7523 is_abstract
= c
->attr
.abstract
;
7535 /* Check for F08:C628. */
7536 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7538 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7543 /* Some checks for the SOURCE tag. */
7546 /* Check F03:C631. */
7547 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7549 gfc_error ("Type of entity at %L is type incompatible with "
7550 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7554 /* Check F03:C632 and restriction following Note 6.18. */
7555 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7558 /* Check F03:C633. */
7559 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7561 gfc_error ("The allocate-object at %L and the source-expr at %L "
7562 "shall have the same kind type parameter",
7563 &e
->where
, &code
->expr3
->where
);
7567 /* Check F2008, C642. */
7568 if (code
->expr3
->ts
.type
== BT_DERIVED
7569 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7570 || (code
->expr3
->ts
.u
.derived
->from_intmod
7571 == INTMOD_ISO_FORTRAN_ENV
7572 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7573 == ISOFORTRAN_LOCK_TYPE
)))
7575 gfc_error ("The source-expr at %L shall neither be of type "
7576 "LOCK_TYPE nor have a LOCK_TYPE component if "
7577 "allocate-object at %L is a coarray",
7578 &code
->expr3
->where
, &e
->where
);
7582 /* Check TS18508, C702/C703. */
7583 if (code
->expr3
->ts
.type
== BT_DERIVED
7584 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7585 || (code
->expr3
->ts
.u
.derived
->from_intmod
7586 == INTMOD_ISO_FORTRAN_ENV
7587 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7588 == ISOFORTRAN_EVENT_TYPE
)))
7590 gfc_error ("The source-expr at %L shall neither be of type "
7591 "EVENT_TYPE nor have a EVENT_TYPE component if "
7592 "allocate-object at %L is a coarray",
7593 &code
->expr3
->where
, &e
->where
);
7598 /* Check F08:C629. */
7599 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7602 gcc_assert (e
->ts
.type
== BT_CLASS
);
7603 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7604 "type-spec or source-expr", sym
->name
, &e
->where
);
7608 /* Check F08:C632. */
7609 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7610 && !UNLIMITED_POLY (e
))
7614 if (!e
->ts
.u
.cl
->length
)
7617 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7618 code
->ext
.alloc
.ts
.u
.cl
->length
);
7619 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7621 gfc_error ("Allocating %s at %L with type-spec requires the same "
7622 "character-length parameter as in the declaration",
7623 sym
->name
, &e
->where
);
7628 /* In the variable definition context checks, gfc_expr_attr is used
7629 on the expression. This is fooled by the array specification
7630 present in e, thus we have to eliminate that one temporarily. */
7631 e2
= remove_last_array_ref (e
);
7634 t
= gfc_check_vardef_context (e2
, true, true, false,
7635 _("ALLOCATE object"));
7637 t
= gfc_check_vardef_context (e2
, false, true, false,
7638 _("ALLOCATE object"));
7643 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7644 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7646 /* For class arrays, the initialization with SOURCE is done
7647 using _copy and trans_call. It is convenient to exploit that
7648 when the allocated type is different from the declared type but
7649 no SOURCE exists by setting expr3. */
7650 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7652 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7653 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7654 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7656 /* We have to zero initialize the integer variable. */
7657 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7660 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7662 /* Make sure the vtab symbol is present when
7663 the module variables are generated. */
7664 gfc_typespec ts
= e
->ts
;
7666 ts
= code
->expr3
->ts
;
7667 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7668 ts
= code
->ext
.alloc
.ts
;
7670 /* Finding the vtab also publishes the type's symbol. Therefore this
7671 statement is necessary. */
7672 gfc_find_derived_vtab (ts
.u
.derived
);
7674 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7676 /* Again, make sure the vtab symbol is present when
7677 the module variables are generated. */
7678 gfc_typespec
*ts
= NULL
;
7680 ts
= &code
->expr3
->ts
;
7682 ts
= &code
->ext
.alloc
.ts
;
7686 /* Finding the vtab also publishes the type's symbol. Therefore this
7687 statement is necessary. */
7691 if (dimension
== 0 && codimension
== 0)
7694 /* Make sure the last reference node is an array specification. */
7696 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7697 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7702 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7703 "in ALLOCATE statement at %L", &e
->where
))
7705 if (code
->expr3
->rank
!= 0)
7706 *array_alloc_wo_spec
= true;
7709 gfc_error ("Array specification or array-valued SOURCE= "
7710 "expression required in ALLOCATE statement at %L",
7717 gfc_error ("Array specification required in ALLOCATE statement "
7718 "at %L", &e
->where
);
7723 /* Make sure that the array section reference makes sense in the
7724 context of an ALLOCATE specification. */
7729 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7730 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7732 gfc_error ("Coarray specification required in ALLOCATE statement "
7733 "at %L", &e
->where
);
7737 for (i
= 0; i
< ar
->dimen
; i
++)
7739 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7742 switch (ar
->dimen_type
[i
])
7748 if (ar
->start
[i
] != NULL
7749 && ar
->end
[i
] != NULL
7750 && ar
->stride
[i
] == NULL
)
7758 case DIMEN_THIS_IMAGE
:
7759 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7765 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7767 sym
= a
->expr
->symtree
->n
.sym
;
7769 /* TODO - check derived type components. */
7770 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7773 if ((ar
->start
[i
] != NULL
7774 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7775 || (ar
->end
[i
] != NULL
7776 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7778 gfc_error ("%qs must not appear in the array specification at "
7779 "%L in the same ALLOCATE statement where it is "
7780 "itself allocated", sym
->name
, &ar
->where
);
7786 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7788 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7789 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7791 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7793 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7794 "statement at %L", &e
->where
);
7800 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7801 && ar
->stride
[i
] == NULL
)
7804 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7818 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7820 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7821 gfc_alloc
*a
, *p
, *q
;
7824 errmsg
= code
->expr2
;
7826 /* Check the stat variable. */
7829 gfc_check_vardef_context (stat
, false, false, false,
7830 _("STAT variable"));
7832 if ((stat
->ts
.type
!= BT_INTEGER
7833 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7834 || stat
->ref
->type
== REF_COMPONENT
)))
7836 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7837 "variable", &stat
->where
);
7839 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7840 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7842 gfc_ref
*ref1
, *ref2
;
7845 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7846 ref1
= ref1
->next
, ref2
= ref2
->next
)
7848 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7850 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7859 gfc_error ("Stat-variable at %L shall not be %sd within "
7860 "the same %s statement", &stat
->where
, fcn
, fcn
);
7866 /* Check the errmsg variable. */
7870 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7873 gfc_check_vardef_context (errmsg
, false, false, false,
7874 _("ERRMSG variable"));
7876 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
7877 F18:R930 errmsg-variable is scalar-default-char-variable
7878 F18:R906 default-char-variable is variable
7879 F18:C906 default-char-variable shall be default character. */
7880 if ((errmsg
->ts
.type
!= BT_CHARACTER
7882 && (errmsg
->ref
->type
== REF_ARRAY
7883 || errmsg
->ref
->type
== REF_COMPONENT
)))
7885 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
7886 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
7887 "variable", &errmsg
->where
);
7889 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7890 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7892 gfc_ref
*ref1
, *ref2
;
7895 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7896 ref1
= ref1
->next
, ref2
= ref2
->next
)
7898 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7900 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7909 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7910 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7916 /* Check that an allocate-object appears only once in the statement. */
7918 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7921 for (q
= p
->next
; q
; q
= q
->next
)
7924 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7926 /* This is a potential collision. */
7927 gfc_ref
*pr
= pe
->ref
;
7928 gfc_ref
*qr
= qe
->ref
;
7930 /* Follow the references until
7931 a) They start to differ, in which case there is no error;
7932 you can deallocate a%b and a%c in a single statement
7933 b) Both of them stop, which is an error
7934 c) One of them stops, which is also an error. */
7937 if (pr
== NULL
&& qr
== NULL
)
7939 gfc_error ("Allocate-object at %L also appears at %L",
7940 &pe
->where
, &qe
->where
);
7943 else if (pr
!= NULL
&& qr
== NULL
)
7945 gfc_error ("Allocate-object at %L is subobject of"
7946 " object at %L", &pe
->where
, &qe
->where
);
7949 else if (pr
== NULL
&& qr
!= NULL
)
7951 gfc_error ("Allocate-object at %L is subobject of"
7952 " object at %L", &qe
->where
, &pe
->where
);
7955 /* Here, pr != NULL && qr != NULL */
7956 gcc_assert(pr
->type
== qr
->type
);
7957 if (pr
->type
== REF_ARRAY
)
7959 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7961 gcc_assert (qr
->type
== REF_ARRAY
);
7963 if (pr
->next
&& qr
->next
)
7966 gfc_array_ref
*par
= &(pr
->u
.ar
);
7967 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7969 for (i
=0; i
<par
->dimen
; i
++)
7971 if ((par
->start
[i
] != NULL
7972 || qar
->start
[i
] != NULL
)
7973 && gfc_dep_compare_expr (par
->start
[i
],
7974 qar
->start
[i
]) != 0)
7981 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7994 if (strcmp (fcn
, "ALLOCATE") == 0)
7996 bool arr_alloc_wo_spec
= false;
7998 /* Resolving the expr3 in the loop over all objects to allocate would
7999 execute loop invariant code for each loop item. Therefore do it just
8001 if (code
->expr3
&& code
->expr3
->mold
8002 && code
->expr3
->ts
.type
== BT_DERIVED
)
8004 /* Default initialization via MOLD (non-polymorphic). */
8005 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8008 gfc_resolve_expr (rhs
);
8009 gfc_free_expr (code
->expr3
);
8013 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8014 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8016 if (arr_alloc_wo_spec
&& code
->expr3
)
8018 /* Mark the allocate to have to take the array specification
8020 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8025 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8026 resolve_deallocate_expr (a
->expr
);
8031 /************ SELECT CASE resolution subroutines ************/
8033 /* Callback function for our mergesort variant. Determines interval
8034 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8035 op1 > op2. Assumes we're not dealing with the default case.
8036 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8037 There are nine situations to check. */
8040 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8044 if (op1
->low
== NULL
) /* op1 = (:L) */
8046 /* op2 = (:N), so overlap. */
8048 /* op2 = (M:) or (M:N), L < M */
8049 if (op2
->low
!= NULL
8050 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8053 else if (op1
->high
== NULL
) /* op1 = (K:) */
8055 /* op2 = (M:), so overlap. */
8057 /* op2 = (:N) or (M:N), K > N */
8058 if (op2
->high
!= NULL
8059 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8062 else /* op1 = (K:L) */
8064 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8065 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8067 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8068 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8070 else /* op2 = (M:N) */
8074 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8077 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8086 /* Merge-sort a double linked case list, detecting overlap in the
8087 process. LIST is the head of the double linked case list before it
8088 is sorted. Returns the head of the sorted list if we don't see any
8089 overlap, or NULL otherwise. */
8092 check_case_overlap (gfc_case
*list
)
8094 gfc_case
*p
, *q
, *e
, *tail
;
8095 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8097 /* If the passed list was empty, return immediately. */
8104 /* Loop unconditionally. The only exit from this loop is a return
8105 statement, when we've finished sorting the case list. */
8112 /* Count the number of merges we do in this pass. */
8115 /* Loop while there exists a merge to be done. */
8120 /* Count this merge. */
8123 /* Cut the list in two pieces by stepping INSIZE places
8124 forward in the list, starting from P. */
8127 for (i
= 0; i
< insize
; i
++)
8136 /* Now we have two lists. Merge them! */
8137 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8139 /* See from which the next case to merge comes from. */
8142 /* P is empty so the next case must come from Q. */
8147 else if (qsize
== 0 || q
== NULL
)
8156 cmp
= compare_cases (p
, q
);
8159 /* The whole case range for P is less than the
8167 /* The whole case range for Q is greater than
8168 the case range for P. */
8175 /* The cases overlap, or they are the same
8176 element in the list. Either way, we must
8177 issue an error and get the next case from P. */
8178 /* FIXME: Sort P and Q by line number. */
8179 gfc_error ("CASE label at %L overlaps with CASE "
8180 "label at %L", &p
->where
, &q
->where
);
8188 /* Add the next element to the merged list. */
8197 /* P has now stepped INSIZE places along, and so has Q. So
8198 they're the same. */
8203 /* If we have done only one merge or none at all, we've
8204 finished sorting the cases. */
8213 /* Otherwise repeat, merging lists twice the size. */
8219 /* Check to see if an expression is suitable for use in a CASE statement.
8220 Makes sure that all case expressions are scalar constants of the same
8221 type. Return false if anything is wrong. */
8224 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8226 if (e
== NULL
) return true;
8228 if (e
->ts
.type
!= case_expr
->ts
.type
)
8230 gfc_error ("Expression in CASE statement at %L must be of type %s",
8231 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8235 /* C805 (R808) For a given case-construct, each case-value shall be of
8236 the same type as case-expr. For character type, length differences
8237 are allowed, but the kind type parameters shall be the same. */
8239 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8241 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8242 &e
->where
, case_expr
->ts
.kind
);
8246 /* Convert the case value kind to that of case expression kind,
8249 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8250 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8254 gfc_error ("Expression in CASE statement at %L must be scalar",
8263 /* Given a completely parsed select statement, we:
8265 - Validate all expressions and code within the SELECT.
8266 - Make sure that the selection expression is not of the wrong type.
8267 - Make sure that no case ranges overlap.
8268 - Eliminate unreachable cases and unreachable code resulting from
8269 removing case labels.
8271 The standard does allow unreachable cases, e.g. CASE (5:3). But
8272 they are a hassle for code generation, and to prevent that, we just
8273 cut them out here. This is not necessary for overlapping cases
8274 because they are illegal and we never even try to generate code.
8276 We have the additional caveat that a SELECT construct could have
8277 been a computed GOTO in the source code. Fortunately we can fairly
8278 easily work around that here: The case_expr for a "real" SELECT CASE
8279 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8280 we have to do is make sure that the case_expr is a scalar integer
8284 resolve_select (gfc_code
*code
, bool select_type
)
8287 gfc_expr
*case_expr
;
8288 gfc_case
*cp
, *default_case
, *tail
, *head
;
8289 int seen_unreachable
;
8295 if (code
->expr1
== NULL
)
8297 /* This was actually a computed GOTO statement. */
8298 case_expr
= code
->expr2
;
8299 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8300 gfc_error ("Selection expression in computed GOTO statement "
8301 "at %L must be a scalar integer expression",
8304 /* Further checking is not necessary because this SELECT was built
8305 by the compiler, so it should always be OK. Just move the
8306 case_expr from expr2 to expr so that we can handle computed
8307 GOTOs as normal SELECTs from here on. */
8308 code
->expr1
= code
->expr2
;
8313 case_expr
= code
->expr1
;
8314 type
= case_expr
->ts
.type
;
8317 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8319 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8320 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8322 /* Punt. Going on here just produce more garbage error messages. */
8327 if (!select_type
&& case_expr
->rank
!= 0)
8329 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8330 "expression", &case_expr
->where
);
8336 /* Raise a warning if an INTEGER case value exceeds the range of
8337 the case-expr. Later, all expressions will be promoted to the
8338 largest kind of all case-labels. */
8340 if (type
== BT_INTEGER
)
8341 for (body
= code
->block
; body
; body
= body
->block
)
8342 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8345 && gfc_check_integer_range (cp
->low
->value
.integer
,
8346 case_expr
->ts
.kind
) != ARITH_OK
)
8347 gfc_warning (0, "Expression in CASE statement at %L is "
8348 "not in the range of %s", &cp
->low
->where
,
8349 gfc_typename (&case_expr
->ts
));
8352 && cp
->low
!= cp
->high
8353 && gfc_check_integer_range (cp
->high
->value
.integer
,
8354 case_expr
->ts
.kind
) != ARITH_OK
)
8355 gfc_warning (0, "Expression in CASE statement at %L is "
8356 "not in the range of %s", &cp
->high
->where
,
8357 gfc_typename (&case_expr
->ts
));
8360 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8361 of the SELECT CASE expression and its CASE values. Walk the lists
8362 of case values, and if we find a mismatch, promote case_expr to
8363 the appropriate kind. */
8365 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8367 for (body
= code
->block
; body
; body
= body
->block
)
8369 /* Walk the case label list. */
8370 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8372 /* Intercept the DEFAULT case. It does not have a kind. */
8373 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8376 /* Unreachable case ranges are discarded, so ignore. */
8377 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8378 && cp
->low
!= cp
->high
8379 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8383 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8384 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8386 if (cp
->high
!= NULL
8387 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8388 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8393 /* Assume there is no DEFAULT case. */
8394 default_case
= NULL
;
8399 for (body
= code
->block
; body
; body
= body
->block
)
8401 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8403 seen_unreachable
= 0;
8405 /* Walk the case label list, making sure that all case labels
8407 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8409 /* Count the number of cases in the whole construct. */
8412 /* Intercept the DEFAULT case. */
8413 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8415 if (default_case
!= NULL
)
8417 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8418 "by a second DEFAULT CASE at %L",
8419 &default_case
->where
, &cp
->where
);
8430 /* Deal with single value cases and case ranges. Errors are
8431 issued from the validation function. */
8432 if (!validate_case_label_expr (cp
->low
, case_expr
)
8433 || !validate_case_label_expr (cp
->high
, case_expr
))
8439 if (type
== BT_LOGICAL
8440 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8441 || cp
->low
!= cp
->high
))
8443 gfc_error ("Logical range in CASE statement at %L is not "
8444 "allowed", &cp
->low
->where
);
8449 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8452 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8453 if (value
& seen_logical
)
8455 gfc_error ("Constant logical value in CASE statement "
8456 "is repeated at %L",
8461 seen_logical
|= value
;
8464 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8465 && cp
->low
!= cp
->high
8466 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8468 if (warn_surprising
)
8469 gfc_warning (OPT_Wsurprising
,
8470 "Range specification at %L can never be matched",
8473 cp
->unreachable
= 1;
8474 seen_unreachable
= 1;
8478 /* If the case range can be matched, it can also overlap with
8479 other cases. To make sure it does not, we put it in a
8480 double linked list here. We sort that with a merge sort
8481 later on to detect any overlapping cases. */
8485 head
->right
= head
->left
= NULL
;
8490 tail
->right
->left
= tail
;
8497 /* It there was a failure in the previous case label, give up
8498 for this case label list. Continue with the next block. */
8502 /* See if any case labels that are unreachable have been seen.
8503 If so, we eliminate them. This is a bit of a kludge because
8504 the case lists for a single case statement (label) is a
8505 single forward linked lists. */
8506 if (seen_unreachable
)
8508 /* Advance until the first case in the list is reachable. */
8509 while (body
->ext
.block
.case_list
!= NULL
8510 && body
->ext
.block
.case_list
->unreachable
)
8512 gfc_case
*n
= body
->ext
.block
.case_list
;
8513 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8515 gfc_free_case_list (n
);
8518 /* Strip all other unreachable cases. */
8519 if (body
->ext
.block
.case_list
)
8521 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8523 if (cp
->next
->unreachable
)
8525 gfc_case
*n
= cp
->next
;
8526 cp
->next
= cp
->next
->next
;
8528 gfc_free_case_list (n
);
8535 /* See if there were overlapping cases. If the check returns NULL,
8536 there was overlap. In that case we don't do anything. If head
8537 is non-NULL, we prepend the DEFAULT case. The sorted list can
8538 then used during code generation for SELECT CASE constructs with
8539 a case expression of a CHARACTER type. */
8542 head
= check_case_overlap (head
);
8544 /* Prepend the default_case if it is there. */
8545 if (head
!= NULL
&& default_case
)
8547 default_case
->left
= NULL
;
8548 default_case
->right
= head
;
8549 head
->left
= default_case
;
8553 /* Eliminate dead blocks that may be the result if we've seen
8554 unreachable case labels for a block. */
8555 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8557 if (body
->block
->ext
.block
.case_list
== NULL
)
8559 /* Cut the unreachable block from the code chain. */
8560 gfc_code
*c
= body
->block
;
8561 body
->block
= c
->block
;
8563 /* Kill the dead block, but not the blocks below it. */
8565 gfc_free_statements (c
);
8569 /* More than two cases is legal but insane for logical selects.
8570 Issue a warning for it. */
8571 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8572 gfc_warning (OPT_Wsurprising
,
8573 "Logical SELECT CASE block at %L has more that two cases",
8578 /* Check if a derived type is extensible. */
8581 gfc_type_is_extensible (gfc_symbol
*sym
)
8583 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8584 || (sym
->attr
.is_class
8585 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8590 resolve_types (gfc_namespace
*ns
);
8592 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8593 correct as well as possibly the array-spec. */
8596 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8600 gcc_assert (sym
->assoc
);
8601 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8603 /* If this is for SELECT TYPE, the target may not yet be set. In that
8604 case, return. Resolution will be called later manually again when
8606 target
= sym
->assoc
->target
;
8609 gcc_assert (!sym
->assoc
->dangling
);
8611 if (resolve_target
&& !gfc_resolve_expr (target
))
8614 /* For variable targets, we get some attributes from the target. */
8615 if (target
->expr_type
== EXPR_VARIABLE
)
8619 gcc_assert (target
->symtree
);
8620 tsym
= target
->symtree
->n
.sym
;
8622 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8623 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8625 sym
->attr
.target
= tsym
->attr
.target
8626 || gfc_expr_attr (target
).pointer
;
8627 if (is_subref_array (target
))
8628 sym
->attr
.subref_array_pointer
= 1;
8631 if (target
->expr_type
== EXPR_NULL
)
8633 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8636 else if (target
->ts
.type
== BT_UNKNOWN
)
8638 gfc_error ("Selector at %L has no type", &target
->where
);
8642 /* Get type if this was not already set. Note that it can be
8643 some other type than the target in case this is a SELECT TYPE
8644 selector! So we must not update when the type is already there. */
8645 if (sym
->ts
.type
== BT_UNKNOWN
)
8646 sym
->ts
= target
->ts
;
8648 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8650 /* See if this is a valid association-to-variable. */
8651 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8652 && !gfc_has_vector_subscript (target
));
8654 /* Finally resolve if this is an array or not. */
8655 if (sym
->attr
.dimension
&& target
->rank
== 0)
8657 /* primary.c makes the assumption that a reference to an associate
8658 name followed by a left parenthesis is an array reference. */
8659 if (sym
->ts
.type
!= BT_CHARACTER
)
8660 gfc_error ("Associate-name %qs at %L is used as array",
8661 sym
->name
, &sym
->declared_at
);
8662 sym
->attr
.dimension
= 0;
8667 /* We cannot deal with class selectors that need temporaries. */
8668 if (target
->ts
.type
== BT_CLASS
8669 && gfc_ref_needs_temporary_p (target
->ref
))
8671 gfc_error ("CLASS selector at %L needs a temporary which is not "
8672 "yet implemented", &target
->where
);
8676 if (target
->ts
.type
== BT_CLASS
)
8677 gfc_fix_class_refs (target
);
8679 if (target
->rank
!= 0)
8682 /* The rank may be incorrectly guessed at parsing, therefore make sure
8683 it is corrected now. */
8684 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8687 sym
->as
= gfc_get_array_spec ();
8689 as
->rank
= target
->rank
;
8690 as
->type
= AS_DEFERRED
;
8691 as
->corank
= gfc_get_corank (target
);
8692 sym
->attr
.dimension
= 1;
8693 if (as
->corank
!= 0)
8694 sym
->attr
.codimension
= 1;
8696 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8698 if (!CLASS_DATA (sym
)->as
)
8699 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8700 as
= CLASS_DATA (sym
)->as
;
8701 as
->rank
= target
->rank
;
8702 as
->type
= AS_DEFERRED
;
8703 as
->corank
= gfc_get_corank (target
);
8704 CLASS_DATA (sym
)->attr
.dimension
= 1;
8705 if (as
->corank
!= 0)
8706 CLASS_DATA (sym
)->attr
.codimension
= 1;
8711 /* target's rank is 0, but the type of the sym is still array valued,
8712 which has to be corrected. */
8713 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8716 symbol_attribute attr
;
8717 /* The associated variable's type is still the array type
8718 correct this now. */
8719 gfc_typespec
*ts
= &target
->ts
;
8722 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8727 ts
= &ref
->u
.c
.component
->ts
;
8730 if (ts
->type
== BT_CLASS
)
8731 ts
= &ts
->u
.derived
->components
->ts
;
8737 /* Create a scalar instance of the current class type. Because the
8738 rank of a class array goes into its name, the type has to be
8739 rebuild. The alternative of (re-)setting just the attributes
8740 and as in the current type, destroys the type also in other
8744 sym
->ts
.type
= BT_CLASS
;
8745 attr
= CLASS_DATA (sym
)->attr
;
8747 attr
.associate_var
= 1;
8748 attr
.dimension
= attr
.codimension
= 0;
8749 attr
.class_pointer
= 1;
8750 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8752 /* Make sure the _vptr is set. */
8753 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8754 if (c
->ts
.u
.derived
== NULL
)
8755 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8756 CLASS_DATA (sym
)->attr
.pointer
= 1;
8757 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8758 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8759 gfc_commit_symbol (sym
->ts
.u
.derived
);
8760 /* _vptr now has the _vtab in it, change it to the _vtype. */
8761 if (c
->ts
.u
.derived
->attr
.vtab
)
8762 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8763 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8764 resolve_types (c
->ts
.u
.derived
->ns
);
8768 /* Mark this as an associate variable. */
8769 sym
->attr
.associate_var
= 1;
8771 /* Fix up the type-spec for CHARACTER types. */
8772 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8775 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8777 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8778 && target
->symtree
->n
.sym
->attr
.dummy
8779 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8781 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8782 sym
->ts
.deferred
= 1;
8785 if (!sym
->ts
.u
.cl
->length
8786 && !sym
->ts
.deferred
8787 && target
->expr_type
== EXPR_CONSTANT
)
8789 sym
->ts
.u
.cl
->length
=
8790 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8791 target
->value
.character
.length
);
8793 else if ((!sym
->ts
.u
.cl
->length
8794 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8795 && target
->expr_type
!= EXPR_VARIABLE
)
8797 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8798 sym
->ts
.deferred
= 1;
8800 /* This is reset in trans-stmt.c after the assignment
8801 of the target expression to the associate name. */
8802 sym
->attr
.allocatable
= 1;
8806 /* If the target is a good class object, so is the associate variable. */
8807 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8808 sym
->attr
.class_ok
= 1;
8812 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8813 array reference, where necessary. The symbols are artificial and so
8814 the dimension attribute and arrayspec can also be set. In addition,
8815 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8816 This is corrected here as well.*/
8819 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8820 int rank
, gfc_ref
*ref
)
8822 gfc_ref
*nref
= (*expr1
)->ref
;
8823 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8824 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8825 (*expr1
)->rank
= rank
;
8826 if (sym1
->ts
.type
== BT_CLASS
)
8828 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8829 (*expr1
)->ts
= sym1
->ts
;
8831 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8832 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8833 CLASS_DATA (sym1
)->as
8834 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8838 sym1
->attr
.dimension
= 1;
8839 if (sym1
->as
== NULL
&& sym2
)
8840 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8843 for (; nref
; nref
= nref
->next
)
8844 if (nref
->next
== NULL
)
8847 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8848 nref
->next
= gfc_copy_ref (ref
);
8849 else if (ref
&& !nref
)
8850 (*expr1
)->ref
= gfc_copy_ref (ref
);
8855 build_loc_call (gfc_expr
*sym_expr
)
8858 loc_call
= gfc_get_expr ();
8859 loc_call
->expr_type
= EXPR_FUNCTION
;
8860 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
8861 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8862 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8863 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8864 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8865 loc_call
->ts
.type
= BT_INTEGER
;
8866 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8867 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8868 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8869 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8870 loc_call
->where
= sym_expr
->where
;
8874 /* Resolve a SELECT TYPE statement. */
8877 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8879 gfc_symbol
*selector_type
;
8880 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8881 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8884 char name
[GFC_MAX_SYMBOL_LEN
];
8888 gfc_ref
* ref
= NULL
;
8889 gfc_expr
*selector_expr
= NULL
;
8891 ns
= code
->ext
.block
.ns
;
8894 /* Check for F03:C813. */
8895 if (code
->expr1
->ts
.type
!= BT_CLASS
8896 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8898 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8899 "at %L", &code
->loc
);
8903 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8908 gfc_ref
*ref2
= NULL
;
8909 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
8910 if (ref
->type
== REF_COMPONENT
8911 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
8916 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8917 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
8918 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
8922 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8923 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8924 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8927 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
8928 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
8930 /* F2008: C803 The selector expression must not be coindexed. */
8931 if (gfc_is_coindexed (code
->expr2
))
8933 gfc_error ("Selector at %L must not be coindexed",
8934 &code
->expr2
->where
);
8941 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8943 if (gfc_is_coindexed (code
->expr1
))
8945 gfc_error ("Selector at %L must not be coindexed",
8946 &code
->expr1
->where
);
8951 /* Loop over TYPE IS / CLASS IS cases. */
8952 for (body
= code
->block
; body
; body
= body
->block
)
8954 c
= body
->ext
.block
.case_list
;
8958 /* Check for repeated cases. */
8959 for (tail
= code
->block
; tail
; tail
= tail
->block
)
8961 gfc_case
*d
= tail
->ext
.block
.case_list
;
8965 if (c
->ts
.type
== d
->ts
.type
8966 && ((c
->ts
.type
== BT_DERIVED
8967 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
8968 && !strcmp (c
->ts
.u
.derived
->name
,
8969 d
->ts
.u
.derived
->name
))
8970 || c
->ts
.type
== BT_UNKNOWN
8971 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8972 && c
->ts
.kind
== d
->ts
.kind
)))
8974 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8975 &c
->where
, &d
->where
);
8981 /* Check F03:C815. */
8982 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8983 && !selector_type
->attr
.unlimited_polymorphic
8984 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8986 gfc_error ("Derived type %qs at %L must be extensible",
8987 c
->ts
.u
.derived
->name
, &c
->where
);
8992 /* Check F03:C816. */
8993 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8994 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8995 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8997 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8998 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8999 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9001 gfc_error ("Unexpected intrinsic type %qs at %L",
9002 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9007 /* Check F03:C814. */
9008 if (c
->ts
.type
== BT_CHARACTER
9009 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9011 gfc_error ("The type-spec at %L shall specify that each length "
9012 "type parameter is assumed", &c
->where
);
9017 /* Intercept the DEFAULT case. */
9018 if (c
->ts
.type
== BT_UNKNOWN
)
9020 /* Check F03:C818. */
9023 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9024 "by a second DEFAULT CASE at %L",
9025 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9030 default_case
= body
;
9037 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9038 target if present. If there are any EXIT statements referring to the
9039 SELECT TYPE construct, this is no problem because the gfc_code
9040 reference stays the same and EXIT is equally possible from the BLOCK
9041 it is changed to. */
9042 code
->op
= EXEC_BLOCK
;
9045 gfc_association_list
* assoc
;
9047 assoc
= gfc_get_association_list ();
9048 assoc
->st
= code
->expr1
->symtree
;
9049 assoc
->target
= gfc_copy_expr (code
->expr2
);
9050 assoc
->target
->where
= code
->expr2
->where
;
9051 /* assoc->variable will be set by resolve_assoc_var. */
9053 code
->ext
.block
.assoc
= assoc
;
9054 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9056 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9059 code
->ext
.block
.assoc
= NULL
;
9061 /* Ensure that the selector rank and arrayspec are available to
9062 correct expressions in which they might be missing. */
9063 if (code
->expr2
&& code
->expr2
->rank
)
9065 rank
= code
->expr2
->rank
;
9066 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9067 if (ref
->next
== NULL
)
9069 if (ref
&& ref
->type
== REF_ARRAY
)
9070 ref
= gfc_copy_ref (ref
);
9072 /* Fixup expr1 if necessary. */
9074 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9076 else if (code
->expr1
->rank
)
9078 rank
= code
->expr1
->rank
;
9079 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9080 if (ref
->next
== NULL
)
9082 if (ref
&& ref
->type
== REF_ARRAY
)
9083 ref
= gfc_copy_ref (ref
);
9086 /* Add EXEC_SELECT to switch on type. */
9087 new_st
= gfc_get_code (code
->op
);
9088 new_st
->expr1
= code
->expr1
;
9089 new_st
->expr2
= code
->expr2
;
9090 new_st
->block
= code
->block
;
9091 code
->expr1
= code
->expr2
= NULL
;
9096 ns
->code
->next
= new_st
;
9098 code
->op
= EXEC_SELECT_TYPE
;
9100 /* Use the intrinsic LOC function to generate an integer expression
9101 for the vtable of the selector. Note that the rank of the selector
9102 expression has to be set to zero. */
9103 gfc_add_vptr_component (code
->expr1
);
9104 code
->expr1
->rank
= 0;
9105 code
->expr1
= build_loc_call (code
->expr1
);
9106 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9108 /* Loop over TYPE IS / CLASS IS cases. */
9109 for (body
= code
->block
; body
; body
= body
->block
)
9113 c
= body
->ext
.block
.case_list
;
9115 /* Generate an index integer expression for address of the
9116 TYPE/CLASS vtable and store it in c->low. The hash expression
9117 is stored in c->high and is used to resolve intrinsic cases. */
9118 if (c
->ts
.type
!= BT_UNKNOWN
)
9120 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9122 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9124 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9125 c
->ts
.u
.derived
->hash_value
);
9129 vtab
= gfc_find_vtab (&c
->ts
);
9130 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9131 e
= CLASS_DATA (vtab
)->initializer
;
9132 c
->high
= gfc_copy_expr (e
);
9133 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9136 ts
.kind
= gfc_integer_4_kind
;
9137 ts
.type
= BT_INTEGER
;
9138 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9142 e
= gfc_lval_expr_from_sym (vtab
);
9143 c
->low
= build_loc_call (e
);
9148 /* Associate temporary to selector. This should only be done
9149 when this case is actually true, so build a new ASSOCIATE
9150 that does precisely this here (instead of using the
9153 if (c
->ts
.type
== BT_CLASS
)
9154 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9155 else if (c
->ts
.type
== BT_DERIVED
)
9156 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9157 else if (c
->ts
.type
== BT_CHARACTER
)
9159 HOST_WIDE_INT charlen
= 0;
9160 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9161 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9162 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9163 snprintf (name
, sizeof (name
),
9164 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9165 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9168 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9171 st
= gfc_find_symtree (ns
->sym_root
, name
);
9172 gcc_assert (st
->n
.sym
->assoc
);
9173 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9174 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9175 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9177 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9178 /* Fixup the target expression if necessary. */
9180 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9183 new_st
= gfc_get_code (EXEC_BLOCK
);
9184 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9185 new_st
->ext
.block
.ns
->code
= body
->next
;
9186 body
->next
= new_st
;
9188 /* Chain in the new list only if it is marked as dangling. Otherwise
9189 there is a CASE label overlap and this is already used. Just ignore,
9190 the error is diagnosed elsewhere. */
9191 if (st
->n
.sym
->assoc
->dangling
)
9193 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9194 st
->n
.sym
->assoc
->dangling
= 0;
9197 resolve_assoc_var (st
->n
.sym
, false);
9200 /* Take out CLASS IS cases for separate treatment. */
9202 while (body
&& body
->block
)
9204 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9206 /* Add to class_is list. */
9207 if (class_is
== NULL
)
9209 class_is
= body
->block
;
9214 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9215 tail
->block
= body
->block
;
9218 /* Remove from EXEC_SELECT list. */
9219 body
->block
= body
->block
->block
;
9232 /* Add a default case to hold the CLASS IS cases. */
9233 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9234 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9236 tail
->ext
.block
.case_list
= gfc_get_case ();
9237 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9239 default_case
= tail
;
9242 /* More than one CLASS IS block? */
9243 if (class_is
->block
)
9247 /* Sort CLASS IS blocks by extension level. */
9251 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9254 /* F03:C817 (check for doubles). */
9255 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9256 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9258 gfc_error ("Double CLASS IS block in SELECT TYPE "
9260 &c2
->ext
.block
.case_list
->where
);
9263 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9264 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9267 (*c1
)->block
= c2
->block
;
9277 /* Generate IF chain. */
9278 if_st
= gfc_get_code (EXEC_IF
);
9280 for (body
= class_is
; body
; body
= body
->block
)
9282 new_st
->block
= gfc_get_code (EXEC_IF
);
9283 new_st
= new_st
->block
;
9284 /* Set up IF condition: Call _gfortran_is_extension_of. */
9285 new_st
->expr1
= gfc_get_expr ();
9286 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9287 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9288 new_st
->expr1
->ts
.kind
= 4;
9289 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9290 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9291 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9292 /* Set up arguments. */
9293 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9294 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9295 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9296 new_st
->expr1
->where
= code
->loc
;
9297 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9298 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9299 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9300 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9301 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9302 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9303 new_st
->next
= body
->next
;
9305 if (default_case
->next
)
9307 new_st
->block
= gfc_get_code (EXEC_IF
);
9308 new_st
= new_st
->block
;
9309 new_st
->next
= default_case
->next
;
9312 /* Replace CLASS DEFAULT code by the IF chain. */
9313 default_case
->next
= if_st
;
9316 /* Resolve the internal code. This can not be done earlier because
9317 it requires that the sym->assoc of selectors is set already. */
9318 gfc_current_ns
= ns
;
9319 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9320 gfc_current_ns
= old_ns
;
9327 /* Resolve a transfer statement. This is making sure that:
9328 -- a derived type being transferred has only non-pointer components
9329 -- a derived type being transferred doesn't have private components, unless
9330 it's being transferred from the module where the type was defined
9331 -- we're not trying to transfer a whole assumed size array. */
9334 resolve_transfer (gfc_code
*code
)
9336 gfc_symbol
*sym
, *derived
;
9340 bool formatted
= false;
9341 gfc_dt
*dt
= code
->ext
.dt
;
9342 gfc_symbol
*dtio_sub
= NULL
;
9346 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9347 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9348 exp
= exp
->value
.op
.op1
;
9350 if (exp
&& exp
->expr_type
== EXPR_NULL
9353 gfc_error ("Invalid context for NULL () intrinsic at %L",
9358 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9359 && exp
->expr_type
!= EXPR_FUNCTION
9360 && exp
->expr_type
!= EXPR_STRUCTURE
))
9363 /* If we are reading, the variable will be changed. Note that
9364 code->ext.dt may be NULL if the TRANSFER is related to
9365 an INQUIRE statement -- but in this case, we are not reading, either. */
9366 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9367 && !gfc_check_vardef_context (exp
, false, false, false,
9371 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9372 || exp
->expr_type
== EXPR_FUNCTION
9373 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9375 /* Go to actual component transferred. */
9376 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9377 if (ref
->type
== REF_COMPONENT
)
9378 ts
= &ref
->u
.c
.component
->ts
;
9380 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9381 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9383 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
9384 derived
= ts
->u
.derived
;
9386 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
9388 /* Determine when to use the formatted DTIO procedure. */
9389 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9392 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9393 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9394 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9396 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9399 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9400 /* Check to see if this is a nested DTIO call, with the
9401 dummy as the io-list object. */
9402 if (sym
&& sym
== dtio_sub
&& sym
->formal
9403 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9404 && exp
->ref
== NULL
)
9406 if (!sym
->attr
.recursive
)
9408 gfc_error ("DTIO %s procedure at %L must be recursive",
9409 sym
->name
, &sym
->declared_at
);
9416 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9418 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9419 "it is processed by a defined input/output procedure",
9424 if (ts
->type
== BT_DERIVED
)
9426 /* Check that transferred derived type doesn't contain POINTER
9427 components unless it is processed by a defined input/output
9429 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9431 gfc_error ("Data transfer element at %L cannot have POINTER "
9432 "components unless it is processed by a defined "
9433 "input/output procedure", &code
->loc
);
9438 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9440 gfc_error ("Data transfer element at %L cannot have "
9441 "procedure pointer components", &code
->loc
);
9445 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9447 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9448 "components unless it is processed by a defined "
9449 "input/output procedure", &code
->loc
);
9453 /* C_PTR and C_FUNPTR have private components which means they can not
9454 be printed. However, if -std=gnu and not -pedantic, allow
9455 the component to be printed to help debugging. */
9456 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9458 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9459 "cannot have PRIVATE components", &code
->loc
))
9462 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9464 gfc_error ("Data transfer element at %L cannot have "
9465 "PRIVATE components unless it is processed by "
9466 "a defined input/output procedure", &code
->loc
);
9471 if (exp
->expr_type
== EXPR_STRUCTURE
)
9474 sym
= exp
->symtree
->n
.sym
;
9476 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9477 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9479 gfc_error ("Data transfer element at %L cannot be a full reference to "
9480 "an assumed-size array", &code
->loc
);
9484 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9485 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9489 /*********** Toplevel code resolution subroutines ***********/
9491 /* Find the set of labels that are reachable from this block. We also
9492 record the last statement in each block. */
9495 find_reachable_labels (gfc_code
*block
)
9502 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9504 /* Collect labels in this block. We don't keep those corresponding
9505 to END {IF|SELECT}, these are checked in resolve_branch by going
9506 up through the code_stack. */
9507 for (c
= block
; c
; c
= c
->next
)
9509 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9510 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9513 /* Merge with labels from parent block. */
9516 gcc_assert (cs_base
->prev
->reachable_labels
);
9517 bitmap_ior_into (cs_base
->reachable_labels
,
9518 cs_base
->prev
->reachable_labels
);
9524 resolve_lock_unlock_event (gfc_code
*code
)
9526 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9527 && code
->expr1
->value
.function
.isym
9528 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9529 remove_caf_get_intrinsic (code
->expr1
);
9531 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9532 && (code
->expr1
->ts
.type
!= BT_DERIVED
9533 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9534 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9535 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9536 || code
->expr1
->rank
!= 0
9537 || (!gfc_is_coarray (code
->expr1
) &&
9538 !gfc_is_coindexed (code
->expr1
))))
9539 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9540 &code
->expr1
->where
);
9541 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9542 && (code
->expr1
->ts
.type
!= BT_DERIVED
9543 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9544 || code
->expr1
->ts
.u
.derived
->from_intmod
9545 != INTMOD_ISO_FORTRAN_ENV
9546 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9547 != ISOFORTRAN_EVENT_TYPE
9548 || code
->expr1
->rank
!= 0))
9549 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9550 &code
->expr1
->where
);
9551 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9552 && !gfc_is_coindexed (code
->expr1
))
9553 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9554 &code
->expr1
->where
);
9555 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9556 gfc_error ("Event variable argument at %L must be a coarray but not "
9557 "coindexed", &code
->expr1
->where
);
9561 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9562 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9563 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9564 &code
->expr2
->where
);
9567 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9568 _("STAT variable")))
9573 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9574 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9575 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9576 &code
->expr3
->where
);
9579 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9580 _("ERRMSG variable")))
9583 /* Check for LOCK the ACQUIRED_LOCK. */
9584 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9585 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9586 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9587 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9588 "variable", &code
->expr4
->where
);
9590 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9591 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9592 _("ACQUIRED_LOCK variable")))
9595 /* Check for EVENT WAIT the UNTIL_COUNT. */
9596 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9598 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9599 || code
->expr4
->rank
!= 0)
9600 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9601 "expression", &code
->expr4
->where
);
9607 resolve_critical (gfc_code
*code
)
9609 gfc_symtree
*symtree
;
9610 gfc_symbol
*lock_type
;
9611 char name
[GFC_MAX_SYMBOL_LEN
];
9612 static int serial
= 0;
9614 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9617 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9618 GFC_PREFIX ("lock_type"));
9620 lock_type
= symtree
->n
.sym
;
9623 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9626 lock_type
= symtree
->n
.sym
;
9627 lock_type
->attr
.flavor
= FL_DERIVED
;
9628 lock_type
->attr
.zero_comp
= 1;
9629 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9630 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9633 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9634 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9637 code
->resolved_sym
= symtree
->n
.sym
;
9638 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9639 symtree
->n
.sym
->attr
.referenced
= 1;
9640 symtree
->n
.sym
->attr
.artificial
= 1;
9641 symtree
->n
.sym
->attr
.codimension
= 1;
9642 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9643 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9644 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9645 symtree
->n
.sym
->as
->corank
= 1;
9646 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9647 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9648 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9650 gfc_commit_symbols();
9655 resolve_sync (gfc_code
*code
)
9657 /* Check imageset. The * case matches expr1 == NULL. */
9660 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9661 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9662 "INTEGER expression", &code
->expr1
->where
);
9663 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9664 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9665 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9666 &code
->expr1
->where
);
9667 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9668 && gfc_simplify_expr (code
->expr1
, 0))
9670 gfc_constructor
*cons
;
9671 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9672 for (; cons
; cons
= gfc_constructor_next (cons
))
9673 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9674 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9675 gfc_error ("Imageset argument at %L must between 1 and "
9676 "num_images()", &cons
->expr
->where
);
9681 gfc_resolve_expr (code
->expr2
);
9683 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9684 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9685 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9686 &code
->expr2
->where
);
9689 gfc_resolve_expr (code
->expr3
);
9691 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9692 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9693 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9694 &code
->expr3
->where
);
9698 /* Given a branch to a label, see if the branch is conforming.
9699 The code node describes where the branch is located. */
9702 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9709 /* Step one: is this a valid branching target? */
9711 if (label
->defined
== ST_LABEL_UNKNOWN
)
9713 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9718 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9720 gfc_error ("Statement at %L is not a valid branch target statement "
9721 "for the branch statement at %L", &label
->where
, &code
->loc
);
9725 /* Step two: make sure this branch is not a branch to itself ;-) */
9727 if (code
->here
== label
)
9730 "Branch at %L may result in an infinite loop", &code
->loc
);
9734 /* Step three: See if the label is in the same block as the
9735 branching statement. The hard work has been done by setting up
9736 the bitmap reachable_labels. */
9738 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9740 /* Check now whether there is a CRITICAL construct; if so, check
9741 whether the label is still visible outside of the CRITICAL block,
9742 which is invalid. */
9743 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9745 if (stack
->current
->op
== EXEC_CRITICAL
9746 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9747 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9748 "label at %L", &code
->loc
, &label
->where
);
9749 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9750 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9751 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9752 "for label at %L", &code
->loc
, &label
->where
);
9758 /* Step four: If we haven't found the label in the bitmap, it may
9759 still be the label of the END of the enclosing block, in which
9760 case we find it by going up the code_stack. */
9762 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9764 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9766 if (stack
->current
->op
== EXEC_CRITICAL
)
9768 /* Note: A label at END CRITICAL does not leave the CRITICAL
9769 construct as END CRITICAL is still part of it. */
9770 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9771 " at %L", &code
->loc
, &label
->where
);
9774 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9776 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9777 "label at %L", &code
->loc
, &label
->where
);
9784 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9788 /* The label is not in an enclosing block, so illegal. This was
9789 allowed in Fortran 66, so we allow it as extension. No
9790 further checks are necessary in this case. */
9791 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9792 "as the GOTO statement at %L", &label
->where
,
9798 /* Check whether EXPR1 has the same shape as EXPR2. */
9801 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9803 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9804 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9805 bool result
= false;
9808 /* Compare the rank. */
9809 if (expr1
->rank
!= expr2
->rank
)
9812 /* Compare the size of each dimension. */
9813 for (i
=0; i
<expr1
->rank
; i
++)
9815 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9818 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9821 if (mpz_cmp (shape
[i
], shape2
[i
]))
9825 /* When either of the two expression is an assumed size array, we
9826 ignore the comparison of dimension sizes. */
9831 gfc_clear_shape (shape
, i
);
9832 gfc_clear_shape (shape2
, i
);
9837 /* Check whether a WHERE assignment target or a WHERE mask expression
9838 has the same shape as the outmost WHERE mask expression. */
9841 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9847 cblock
= code
->block
;
9849 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9850 In case of nested WHERE, only the outmost one is stored. */
9851 if (mask
== NULL
) /* outmost WHERE */
9853 else /* inner WHERE */
9860 /* Check if the mask-expr has a consistent shape with the
9861 outmost WHERE mask-expr. */
9862 if (!resolve_where_shape (cblock
->expr1
, e
))
9863 gfc_error ("WHERE mask at %L has inconsistent shape",
9864 &cblock
->expr1
->where
);
9867 /* the assignment statement of a WHERE statement, or the first
9868 statement in where-body-construct of a WHERE construct */
9869 cnext
= cblock
->next
;
9874 /* WHERE assignment statement */
9877 /* Check shape consistent for WHERE assignment target. */
9878 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9879 gfc_error ("WHERE assignment target at %L has "
9880 "inconsistent shape", &cnext
->expr1
->where
);
9884 case EXEC_ASSIGN_CALL
:
9885 resolve_call (cnext
);
9886 if (!cnext
->resolved_sym
->attr
.elemental
)
9887 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9888 &cnext
->ext
.actual
->expr
->where
);
9891 /* WHERE or WHERE construct is part of a where-body-construct */
9893 resolve_where (cnext
, e
);
9897 gfc_error ("Unsupported statement inside WHERE at %L",
9900 /* the next statement within the same where-body-construct */
9901 cnext
= cnext
->next
;
9903 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9904 cblock
= cblock
->block
;
9909 /* Resolve assignment in FORALL construct.
9910 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9911 FORALL index variables. */
9914 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9918 for (n
= 0; n
< nvar
; n
++)
9920 gfc_symbol
*forall_index
;
9922 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9924 /* Check whether the assignment target is one of the FORALL index
9926 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9927 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9928 gfc_error ("Assignment to a FORALL index variable at %L",
9929 &code
->expr1
->where
);
9932 /* If one of the FORALL index variables doesn't appear in the
9933 assignment variable, then there could be a many-to-one
9934 assignment. Emit a warning rather than an error because the
9935 mask could be resolving this problem. */
9936 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9937 gfc_warning (0, "The FORALL with index %qs is not used on the "
9938 "left side of the assignment at %L and so might "
9939 "cause multiple assignment to this object",
9940 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9946 /* Resolve WHERE statement in FORALL construct. */
9949 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9950 gfc_expr
**var_expr
)
9955 cblock
= code
->block
;
9958 /* the assignment statement of a WHERE statement, or the first
9959 statement in where-body-construct of a WHERE construct */
9960 cnext
= cblock
->next
;
9965 /* WHERE assignment statement */
9967 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9970 /* WHERE operator assignment statement */
9971 case EXEC_ASSIGN_CALL
:
9972 resolve_call (cnext
);
9973 if (!cnext
->resolved_sym
->attr
.elemental
)
9974 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9975 &cnext
->ext
.actual
->expr
->where
);
9978 /* WHERE or WHERE construct is part of a where-body-construct */
9980 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9984 gfc_error ("Unsupported statement inside WHERE at %L",
9987 /* the next statement within the same where-body-construct */
9988 cnext
= cnext
->next
;
9990 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9991 cblock
= cblock
->block
;
9996 /* Traverse the FORALL body to check whether the following errors exist:
9997 1. For assignment, check if a many-to-one assignment happens.
9998 2. For WHERE statement, check the WHERE body to see if there is any
9999 many-to-one assignment. */
10002 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10006 c
= code
->block
->next
;
10012 case EXEC_POINTER_ASSIGN
:
10013 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10016 case EXEC_ASSIGN_CALL
:
10020 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10021 there is no need to handle it here. */
10025 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10030 /* The next statement in the FORALL body. */
10036 /* Counts the number of iterators needed inside a forall construct, including
10037 nested forall constructs. This is used to allocate the needed memory
10038 in gfc_resolve_forall. */
10041 gfc_count_forall_iterators (gfc_code
*code
)
10043 int max_iters
, sub_iters
, current_iters
;
10044 gfc_forall_iterator
*fa
;
10046 gcc_assert(code
->op
== EXEC_FORALL
);
10050 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10053 code
= code
->block
->next
;
10057 if (code
->op
== EXEC_FORALL
)
10059 sub_iters
= gfc_count_forall_iterators (code
);
10060 if (sub_iters
> max_iters
)
10061 max_iters
= sub_iters
;
10066 return current_iters
+ max_iters
;
10070 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10071 gfc_resolve_forall_body to resolve the FORALL body. */
10074 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10076 static gfc_expr
**var_expr
;
10077 static int total_var
= 0;
10078 static int nvar
= 0;
10079 int i
, old_nvar
, tmp
;
10080 gfc_forall_iterator
*fa
;
10084 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10087 /* Start to resolve a FORALL construct */
10088 if (forall_save
== 0)
10090 /* Count the total number of FORALL indices in the nested FORALL
10091 construct in order to allocate the VAR_EXPR with proper size. */
10092 total_var
= gfc_count_forall_iterators (code
);
10094 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10095 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10098 /* The information about FORALL iterator, including FORALL indices start, end
10099 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10100 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10102 /* Fortran 20008: C738 (R753). */
10103 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10105 gfc_error ("FORALL index-name at %L must be a scalar variable "
10106 "of type integer", &fa
->var
->where
);
10110 /* Check if any outer FORALL index name is the same as the current
10112 for (i
= 0; i
< nvar
; i
++)
10114 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10115 gfc_error ("An outer FORALL construct already has an index "
10116 "with this name %L", &fa
->var
->where
);
10119 /* Record the current FORALL index. */
10120 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10124 /* No memory leak. */
10125 gcc_assert (nvar
<= total_var
);
10128 /* Resolve the FORALL body. */
10129 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10131 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10132 gfc_resolve_blocks (code
->block
, ns
);
10136 /* Free only the VAR_EXPRs allocated in this frame. */
10137 for (i
= nvar
; i
< tmp
; i
++)
10138 gfc_free_expr (var_expr
[i
]);
10142 /* We are in the outermost FORALL construct. */
10143 gcc_assert (forall_save
== 0);
10145 /* VAR_EXPR is not needed any more. */
10152 /* Resolve a BLOCK construct statement. */
10155 resolve_block_construct (gfc_code
* code
)
10157 /* Resolve the BLOCK's namespace. */
10158 gfc_resolve (code
->ext
.block
.ns
);
10160 /* For an ASSOCIATE block, the associations (and their targets) are already
10161 resolved during resolve_symbol. */
10165 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10169 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10173 for (; b
; b
= b
->block
)
10175 t
= gfc_resolve_expr (b
->expr1
);
10176 if (!gfc_resolve_expr (b
->expr2
))
10182 if (t
&& b
->expr1
!= NULL
10183 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10184 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10190 && b
->expr1
!= NULL
10191 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10192 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10197 resolve_branch (b
->label1
, b
);
10201 resolve_block_construct (b
);
10205 case EXEC_SELECT_TYPE
:
10208 case EXEC_DO_WHILE
:
10209 case EXEC_DO_CONCURRENT
:
10210 case EXEC_CRITICAL
:
10213 case EXEC_IOLENGTH
:
10217 case EXEC_OMP_ATOMIC
:
10218 case EXEC_OACC_ATOMIC
:
10220 gfc_omp_atomic_op aop
10221 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10223 /* Verify this before calling gfc_resolve_code, which might
10225 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10226 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10227 && b
->next
->next
== NULL
)
10228 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10229 && b
->next
->next
!= NULL
10230 && b
->next
->next
->op
== EXEC_ASSIGN
10231 && b
->next
->next
->next
== NULL
));
10235 case EXEC_OACC_PARALLEL_LOOP
:
10236 case EXEC_OACC_PARALLEL
:
10237 case EXEC_OACC_KERNELS_LOOP
:
10238 case EXEC_OACC_KERNELS
:
10239 case EXEC_OACC_DATA
:
10240 case EXEC_OACC_HOST_DATA
:
10241 case EXEC_OACC_LOOP
:
10242 case EXEC_OACC_UPDATE
:
10243 case EXEC_OACC_WAIT
:
10244 case EXEC_OACC_CACHE
:
10245 case EXEC_OACC_ENTER_DATA
:
10246 case EXEC_OACC_EXIT_DATA
:
10247 case EXEC_OACC_ROUTINE
:
10248 case EXEC_OMP_CRITICAL
:
10249 case EXEC_OMP_DISTRIBUTE
:
10250 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10251 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10252 case EXEC_OMP_DISTRIBUTE_SIMD
:
10254 case EXEC_OMP_DO_SIMD
:
10255 case EXEC_OMP_MASTER
:
10256 case EXEC_OMP_ORDERED
:
10257 case EXEC_OMP_PARALLEL
:
10258 case EXEC_OMP_PARALLEL_DO
:
10259 case EXEC_OMP_PARALLEL_DO_SIMD
:
10260 case EXEC_OMP_PARALLEL_SECTIONS
:
10261 case EXEC_OMP_PARALLEL_WORKSHARE
:
10262 case EXEC_OMP_SECTIONS
:
10263 case EXEC_OMP_SIMD
:
10264 case EXEC_OMP_SINGLE
:
10265 case EXEC_OMP_TARGET
:
10266 case EXEC_OMP_TARGET_DATA
:
10267 case EXEC_OMP_TARGET_ENTER_DATA
:
10268 case EXEC_OMP_TARGET_EXIT_DATA
:
10269 case EXEC_OMP_TARGET_PARALLEL
:
10270 case EXEC_OMP_TARGET_PARALLEL_DO
:
10271 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10272 case EXEC_OMP_TARGET_SIMD
:
10273 case EXEC_OMP_TARGET_TEAMS
:
10274 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10275 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10276 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10277 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10278 case EXEC_OMP_TARGET_UPDATE
:
10279 case EXEC_OMP_TASK
:
10280 case EXEC_OMP_TASKGROUP
:
10281 case EXEC_OMP_TASKLOOP
:
10282 case EXEC_OMP_TASKLOOP_SIMD
:
10283 case EXEC_OMP_TASKWAIT
:
10284 case EXEC_OMP_TASKYIELD
:
10285 case EXEC_OMP_TEAMS
:
10286 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10287 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10288 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10289 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10290 case EXEC_OMP_WORKSHARE
:
10294 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10297 gfc_resolve_code (b
->next
, ns
);
10302 /* Does everything to resolve an ordinary assignment. Returns true
10303 if this is an interface assignment. */
10305 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10312 symbol_attribute attr
;
10314 if (gfc_extend_assign (code
, ns
))
10318 if (code
->op
== EXEC_ASSIGN_CALL
)
10320 lhs
= code
->ext
.actual
->expr
;
10321 rhsptr
= &code
->ext
.actual
->next
->expr
;
10325 gfc_actual_arglist
* args
;
10326 gfc_typebound_proc
* tbp
;
10328 gcc_assert (code
->op
== EXEC_COMPCALL
);
10330 args
= code
->expr1
->value
.compcall
.actual
;
10332 rhsptr
= &args
->next
->expr
;
10334 tbp
= code
->expr1
->value
.compcall
.tbp
;
10335 gcc_assert (!tbp
->is_generic
);
10338 /* Make a temporary rhs when there is a default initializer
10339 and rhs is the same symbol as the lhs. */
10340 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10341 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10342 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10343 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10344 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10353 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10354 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10358 /* Handle the case of a BOZ literal on the RHS. */
10359 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10362 if (warn_surprising
)
10363 gfc_warning (OPT_Wsurprising
,
10364 "BOZ literal at %L is bitwise transferred "
10365 "non-integer symbol %qs", &code
->loc
,
10366 lhs
->symtree
->n
.sym
->name
);
10368 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10370 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10372 if (rc
== ARITH_UNDERFLOW
)
10373 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10374 ". This check can be disabled with the option "
10375 "%<-fno-range-check%>", &rhs
->where
);
10376 else if (rc
== ARITH_OVERFLOW
)
10377 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10378 ". This check can be disabled with the option "
10379 "%<-fno-range-check%>", &rhs
->where
);
10380 else if (rc
== ARITH_NAN
)
10381 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10382 ". This check can be disabled with the option "
10383 "%<-fno-range-check%>", &rhs
->where
);
10388 if (lhs
->ts
.type
== BT_CHARACTER
10389 && warn_character_truncation
)
10391 HOST_WIDE_INT llen
= 0, rlen
= 0;
10392 if (lhs
->ts
.u
.cl
!= NULL
10393 && lhs
->ts
.u
.cl
->length
!= NULL
10394 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10395 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10397 if (rhs
->expr_type
== EXPR_CONSTANT
)
10398 rlen
= rhs
->value
.character
.length
;
10400 else if (rhs
->ts
.u
.cl
!= NULL
10401 && rhs
->ts
.u
.cl
->length
!= NULL
10402 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10403 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10405 if (rlen
&& llen
&& rlen
> llen
)
10406 gfc_warning_now (OPT_Wcharacter_truncation
,
10407 "CHARACTER expression will be truncated "
10408 "in assignment (%ld/%ld) at %L",
10409 (long) llen
, (long) rlen
, &code
->loc
);
10412 /* Ensure that a vector index expression for the lvalue is evaluated
10413 to a temporary if the lvalue symbol is referenced in it. */
10416 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10417 if (ref
->type
== REF_ARRAY
)
10419 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10420 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10421 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10422 ref
->u
.ar
.start
[n
]))
10424 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10428 if (gfc_pure (NULL
))
10430 if (lhs
->ts
.type
== BT_DERIVED
10431 && lhs
->expr_type
== EXPR_VARIABLE
10432 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10433 && rhs
->expr_type
== EXPR_VARIABLE
10434 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10435 || gfc_is_coindexed (rhs
)))
10437 /* F2008, C1283. */
10438 if (gfc_is_coindexed (rhs
))
10439 gfc_error ("Coindexed expression at %L is assigned to "
10440 "a derived type variable with a POINTER "
10441 "component in a PURE procedure",
10444 gfc_error ("The impure variable at %L is assigned to "
10445 "a derived type variable with a POINTER "
10446 "component in a PURE procedure (12.6)",
10451 /* Fortran 2008, C1283. */
10452 if (gfc_is_coindexed (lhs
))
10454 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10455 "procedure", &rhs
->where
);
10460 if (gfc_implicit_pure (NULL
))
10462 if (lhs
->expr_type
== EXPR_VARIABLE
10463 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10464 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10465 gfc_unset_implicit_pure (NULL
);
10467 if (lhs
->ts
.type
== BT_DERIVED
10468 && lhs
->expr_type
== EXPR_VARIABLE
10469 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10470 && rhs
->expr_type
== EXPR_VARIABLE
10471 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10472 || gfc_is_coindexed (rhs
)))
10473 gfc_unset_implicit_pure (NULL
);
10475 /* Fortran 2008, C1283. */
10476 if (gfc_is_coindexed (lhs
))
10477 gfc_unset_implicit_pure (NULL
);
10480 /* F2008, 7.2.1.2. */
10481 attr
= gfc_expr_attr (lhs
);
10482 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10484 if (attr
.codimension
)
10486 gfc_error ("Assignment to polymorphic coarray at %L is not "
10487 "permitted", &lhs
->where
);
10490 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10491 "polymorphic variable at %L", &lhs
->where
))
10493 if (!flag_realloc_lhs
)
10495 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10496 "requires %<-frealloc-lhs%>", &lhs
->where
);
10500 else if (lhs
->ts
.type
== BT_CLASS
)
10502 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10503 "assignment at %L - check that there is a matching specific "
10504 "subroutine for '=' operator", &lhs
->where
);
10508 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10510 /* F2008, Section 7.2.1.2. */
10511 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10513 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10514 "component in assignment at %L", &lhs
->where
);
10518 /* Assign the 'data' of a class object to a derived type. */
10519 if (lhs
->ts
.type
== BT_DERIVED
10520 && rhs
->ts
.type
== BT_CLASS
10521 && rhs
->expr_type
!= EXPR_ARRAY
)
10522 gfc_add_data_component (rhs
);
10524 /* Make sure there is a vtable and, in particular, a _copy for the
10526 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10527 gfc_find_vtab (&rhs
->ts
);
10529 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10531 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10532 && code
->expr2
->value
.function
.isym
10533 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10534 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10535 && !gfc_expr_attr (rhs
).allocatable
10536 && !gfc_has_vector_subscript (rhs
)));
10538 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10540 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10541 Additionally, insert this code when the RHS is a CAF as we then use the
10542 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10543 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10544 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10546 if (caf_convert_to_send
)
10548 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10549 && code
->expr2
->value
.function
.isym
10550 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10551 remove_caf_get_intrinsic (code
->expr2
);
10552 code
->op
= EXEC_CALL
;
10553 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10554 code
->resolved_sym
= code
->symtree
->n
.sym
;
10555 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10556 code
->resolved_sym
->attr
.intrinsic
= 1;
10557 code
->resolved_sym
->attr
.subroutine
= 1;
10558 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10559 gfc_commit_symbol (code
->resolved_sym
);
10560 code
->ext
.actual
= gfc_get_actual_arglist ();
10561 code
->ext
.actual
->expr
= lhs
;
10562 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10563 code
->ext
.actual
->next
->expr
= rhs
;
10564 code
->expr1
= NULL
;
10565 code
->expr2
= NULL
;
10572 /* Add a component reference onto an expression. */
10575 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10580 ref
= &((*ref
)->next
);
10581 *ref
= gfc_get_ref ();
10582 (*ref
)->type
= REF_COMPONENT
;
10583 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10584 (*ref
)->u
.c
.component
= c
;
10587 /* Add a full array ref, as necessary. */
10590 gfc_add_full_array_ref (e
, c
->as
);
10591 e
->rank
= c
->as
->rank
;
10596 /* Build an assignment. Keep the argument 'op' for future use, so that
10597 pointer assignments can be made. */
10600 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10601 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10603 gfc_code
*this_code
;
10605 this_code
= gfc_get_code (op
);
10606 this_code
->next
= NULL
;
10607 this_code
->expr1
= gfc_copy_expr (expr1
);
10608 this_code
->expr2
= gfc_copy_expr (expr2
);
10609 this_code
->loc
= loc
;
10610 if (comp1
&& comp2
)
10612 add_comp_ref (this_code
->expr1
, comp1
);
10613 add_comp_ref (this_code
->expr2
, comp2
);
10620 /* Makes a temporary variable expression based on the characteristics of
10621 a given variable expression. */
10624 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10626 static int serial
= 0;
10627 char name
[GFC_MAX_SYMBOL_LEN
];
10629 gfc_array_spec
*as
;
10630 gfc_array_ref
*aref
;
10633 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10634 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10635 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10641 /* Obtain the arrayspec for the temporary. */
10642 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10643 && e
->expr_type
!= EXPR_FUNCTION
10644 && e
->expr_type
!= EXPR_OP
)
10646 aref
= gfc_find_array_ref (e
);
10647 if (e
->expr_type
== EXPR_VARIABLE
10648 && e
->symtree
->n
.sym
->as
== aref
->as
)
10652 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10653 if (ref
->type
== REF_COMPONENT
10654 && ref
->u
.c
.component
->as
== aref
->as
)
10662 /* Add the attributes and the arrayspec to the temporary. */
10663 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10664 tmp
->n
.sym
->attr
.function
= 0;
10665 tmp
->n
.sym
->attr
.result
= 0;
10666 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10667 tmp
->n
.sym
->attr
.dummy
= 0;
10668 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10672 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10675 if (as
->type
== AS_DEFERRED
)
10676 tmp
->n
.sym
->attr
.allocatable
= 1;
10678 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10679 || e
->expr_type
== EXPR_FUNCTION
10680 || e
->expr_type
== EXPR_OP
))
10682 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10683 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10684 tmp
->n
.sym
->as
->rank
= e
->rank
;
10685 tmp
->n
.sym
->attr
.allocatable
= 1;
10686 tmp
->n
.sym
->attr
.dimension
= 1;
10689 tmp
->n
.sym
->attr
.dimension
= 0;
10691 gfc_set_sym_referenced (tmp
->n
.sym
);
10692 gfc_commit_symbol (tmp
->n
.sym
);
10693 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10695 /* Should the lhs be a section, use its array ref for the
10696 temporary expression. */
10697 if (aref
&& aref
->type
!= AR_FULL
)
10699 gfc_free_ref_list (e
->ref
);
10700 e
->ref
= gfc_copy_ref (ref
);
10706 /* Add one line of code to the code chain, making sure that 'head' and
10707 'tail' are appropriately updated. */
10710 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10712 gcc_assert (this_code
);
10714 *head
= *tail
= *this_code
;
10716 *tail
= gfc_append_code (*tail
, *this_code
);
10721 /* Counts the potential number of part array references that would
10722 result from resolution of typebound defined assignments. */
10725 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10728 int c_depth
= 0, t_depth
;
10730 for (c
= derived
->components
; c
; c
= c
->next
)
10732 if ((!gfc_bt_struct (c
->ts
.type
)
10734 || c
->attr
.allocatable
10735 || c
->attr
.proc_pointer_comp
10736 || c
->attr
.class_pointer
10737 || c
->attr
.proc_pointer
)
10738 && !c
->attr
.defined_assign_comp
)
10741 if (c
->as
&& c_depth
== 0)
10744 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10745 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10750 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10752 return depth
+ c_depth
;
10756 /* Implement 7.2.1.3 of the F08 standard:
10757 "An intrinsic assignment where the variable is of derived type is
10758 performed as if each component of the variable were assigned from the
10759 corresponding component of expr using pointer assignment (7.2.2) for
10760 each pointer component, defined assignment for each nonpointer
10761 nonallocatable component of a type that has a type-bound defined
10762 assignment consistent with the component, intrinsic assignment for
10763 each other nonpointer nonallocatable component, ..."
10765 The pointer assignments are taken care of by the intrinsic
10766 assignment of the structure itself. This function recursively adds
10767 defined assignments where required. The recursion is accomplished
10768 by calling gfc_resolve_code.
10770 When the lhs in a defined assignment has intent INOUT, we need a
10771 temporary for the lhs. In pseudo-code:
10773 ! Only call function lhs once.
10774 if (lhs is not a constant or an variable)
10777 ! Do the intrinsic assignment
10779 ! Now do the defined assignments
10780 do over components with typebound defined assignment [%cmp]
10781 #if one component's assignment procedure is INOUT
10783 #if expr2 non-variable
10789 t1%cmp {defined=} expr2%cmp
10795 expr1%cmp {defined=} expr2%cmp
10799 /* The temporary assignments have to be put on top of the additional
10800 code to avoid the result being changed by the intrinsic assignment.
10802 static int component_assignment_level
= 0;
10803 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10806 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10808 gfc_component
*comp1
, *comp2
;
10809 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10811 int error_count
, depth
;
10813 gfc_get_errors (NULL
, &error_count
);
10815 /* Filter out continuing processing after an error. */
10817 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10818 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10821 /* TODO: Handle more than one part array reference in assignments. */
10822 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10823 (*code
)->expr1
->rank
? 1 : 0);
10826 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10827 "done because multiple part array references would "
10828 "occur in intermediate expressions.", &(*code
)->loc
);
10832 component_assignment_level
++;
10834 /* Create a temporary so that functions get called only once. */
10835 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10836 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10838 gfc_expr
*tmp_expr
;
10840 /* Assign the rhs to the temporary. */
10841 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10842 this_code
= build_assignment (EXEC_ASSIGN
,
10843 tmp_expr
, (*code
)->expr2
,
10844 NULL
, NULL
, (*code
)->loc
);
10845 /* Add the code and substitute the rhs expression. */
10846 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10847 gfc_free_expr ((*code
)->expr2
);
10848 (*code
)->expr2
= tmp_expr
;
10851 /* Do the intrinsic assignment. This is not needed if the lhs is one
10852 of the temporaries generated here, since the intrinsic assignment
10853 to the final result already does this. */
10854 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10856 this_code
= build_assignment (EXEC_ASSIGN
,
10857 (*code
)->expr1
, (*code
)->expr2
,
10858 NULL
, NULL
, (*code
)->loc
);
10859 add_code_to_chain (&this_code
, &head
, &tail
);
10862 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10863 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10866 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10868 bool inout
= false;
10870 /* The intrinsic assignment does the right thing for pointers
10871 of all kinds and allocatable components. */
10872 if (!gfc_bt_struct (comp1
->ts
.type
)
10873 || comp1
->attr
.pointer
10874 || comp1
->attr
.allocatable
10875 || comp1
->attr
.proc_pointer_comp
10876 || comp1
->attr
.class_pointer
10877 || comp1
->attr
.proc_pointer
)
10880 /* Make an assigment for this component. */
10881 this_code
= build_assignment (EXEC_ASSIGN
,
10882 (*code
)->expr1
, (*code
)->expr2
,
10883 comp1
, comp2
, (*code
)->loc
);
10885 /* Convert the assignment if there is a defined assignment for
10886 this type. Otherwise, using the call from gfc_resolve_code,
10887 recurse into its components. */
10888 gfc_resolve_code (this_code
, ns
);
10890 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10892 gfc_formal_arglist
*dummy_args
;
10894 /* Check that there is a typebound defined assignment. If not,
10895 then this must be a module defined assignment. We cannot
10896 use the defined_assign_comp attribute here because it must
10897 be this derived type that has the defined assignment and not
10899 if (!(comp1
->ts
.u
.derived
->f2k_derived
10900 && comp1
->ts
.u
.derived
->f2k_derived
10901 ->tb_op
[INTRINSIC_ASSIGN
]))
10903 gfc_free_statements (this_code
);
10908 /* If the first argument of the subroutine has intent INOUT
10909 a temporary must be generated and used instead. */
10910 rsym
= this_code
->resolved_sym
;
10911 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10913 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10915 gfc_code
*temp_code
;
10918 /* Build the temporary required for the assignment and put
10919 it at the head of the generated code. */
10922 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10923 temp_code
= build_assignment (EXEC_ASSIGN
,
10924 t1
, (*code
)->expr1
,
10925 NULL
, NULL
, (*code
)->loc
);
10927 /* For allocatable LHS, check whether it is allocated. Note
10928 that allocatable components with defined assignment are
10929 not yet support. See PR 57696. */
10930 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10934 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10935 block
= gfc_get_code (EXEC_IF
);
10936 block
->block
= gfc_get_code (EXEC_IF
);
10937 block
->block
->expr1
10938 = gfc_build_intrinsic_call (ns
,
10939 GFC_ISYM_ALLOCATED
, "allocated",
10940 (*code
)->loc
, 1, e
);
10941 block
->block
->next
= temp_code
;
10944 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10947 /* Replace the first actual arg with the component of the
10949 gfc_free_expr (this_code
->ext
.actual
->expr
);
10950 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10951 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10953 /* If the LHS variable is allocatable and wasn't allocated and
10954 the temporary is allocatable, pointer assign the address of
10955 the freshly allocated LHS to the temporary. */
10956 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10957 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10962 cond
= gfc_get_expr ();
10963 cond
->ts
.type
= BT_LOGICAL
;
10964 cond
->ts
.kind
= gfc_default_logical_kind
;
10965 cond
->expr_type
= EXPR_OP
;
10966 cond
->where
= (*code
)->loc
;
10967 cond
->value
.op
.op
= INTRINSIC_NOT
;
10968 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10969 GFC_ISYM_ALLOCATED
, "allocated",
10970 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10971 block
= gfc_get_code (EXEC_IF
);
10972 block
->block
= gfc_get_code (EXEC_IF
);
10973 block
->block
->expr1
= cond
;
10974 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10975 t1
, (*code
)->expr1
,
10976 NULL
, NULL
, (*code
)->loc
);
10977 add_code_to_chain (&block
, &head
, &tail
);
10981 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10983 /* Don't add intrinsic assignments since they are already
10984 effected by the intrinsic assignment of the structure. */
10985 gfc_free_statements (this_code
);
10990 add_code_to_chain (&this_code
, &head
, &tail
);
10994 /* Transfer the value to the final result. */
10995 this_code
= build_assignment (EXEC_ASSIGN
,
10996 (*code
)->expr1
, t1
,
10997 comp1
, comp2
, (*code
)->loc
);
10998 add_code_to_chain (&this_code
, &head
, &tail
);
11002 /* Put the temporary assignments at the top of the generated code. */
11003 if (tmp_head
&& component_assignment_level
== 1)
11005 gfc_append_code (tmp_head
, head
);
11007 tmp_head
= tmp_tail
= NULL
;
11010 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11011 // not accidentally deallocated. Hence, nullify t1.
11012 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11013 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11019 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11020 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11021 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11022 block
= gfc_get_code (EXEC_IF
);
11023 block
->block
= gfc_get_code (EXEC_IF
);
11024 block
->block
->expr1
= cond
;
11025 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11026 t1
, gfc_get_null_expr (&(*code
)->loc
),
11027 NULL
, NULL
, (*code
)->loc
);
11028 gfc_append_code (tail
, block
);
11032 /* Now attach the remaining code chain to the input code. Step on
11033 to the end of the new code since resolution is complete. */
11034 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11035 tail
->next
= (*code
)->next
;
11036 /* Overwrite 'code' because this would place the intrinsic assignment
11037 before the temporary for the lhs is created. */
11038 gfc_free_expr ((*code
)->expr1
);
11039 gfc_free_expr ((*code
)->expr2
);
11045 component_assignment_level
--;
11049 /* F2008: Pointer function assignments are of the form:
11050 ptr_fcn (args) = expr
11051 This function breaks these assignments into two statements:
11052 temporary_pointer => ptr_fcn(args)
11053 temporary_pointer = expr */
11056 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11058 gfc_expr
*tmp_ptr_expr
;
11059 gfc_code
*this_code
;
11060 gfc_component
*comp
;
11063 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11066 /* Even if standard does not support this feature, continue to build
11067 the two statements to avoid upsetting frontend_passes.c. */
11068 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11069 "%L", &(*code
)->loc
);
11071 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11074 s
= comp
->ts
.interface
;
11076 s
= (*code
)->expr1
->symtree
->n
.sym
;
11078 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11080 gfc_error ("The function result on the lhs of the assignment at "
11081 "%L must have the pointer attribute.",
11082 &(*code
)->expr1
->where
);
11083 (*code
)->op
= EXEC_NOP
;
11087 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11089 /* get_temp_from_expression is set up for ordinary assignments. To that
11090 end, where array bounds are not known, arrays are made allocatable.
11091 Change the temporary to a pointer here. */
11092 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11093 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11094 tmp_ptr_expr
->where
= (*code
)->loc
;
11096 this_code
= build_assignment (EXEC_ASSIGN
,
11097 tmp_ptr_expr
, (*code
)->expr2
,
11098 NULL
, NULL
, (*code
)->loc
);
11099 this_code
->next
= (*code
)->next
;
11100 (*code
)->next
= this_code
;
11101 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11102 (*code
)->expr2
= (*code
)->expr1
;
11103 (*code
)->expr1
= tmp_ptr_expr
;
11109 /* Deferred character length assignments from an operator expression
11110 require a temporary because the character length of the lhs can
11111 change in the course of the assignment. */
11114 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11116 gfc_expr
*tmp_expr
;
11117 gfc_code
*this_code
;
11119 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11120 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11121 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11124 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11127 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11128 tmp_expr
->where
= (*code
)->loc
;
11130 /* A new charlen is required to ensure that the variable string
11131 length is different to that of the original lhs. */
11132 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11133 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11134 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11135 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11137 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11139 this_code
= build_assignment (EXEC_ASSIGN
,
11141 gfc_copy_expr (tmp_expr
),
11142 NULL
, NULL
, (*code
)->loc
);
11144 (*code
)->expr1
= tmp_expr
;
11146 this_code
->next
= (*code
)->next
;
11147 (*code
)->next
= this_code
;
11153 /* Given a block of code, recursively resolve everything pointed to by this
11157 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11159 int omp_workshare_save
;
11160 int forall_save
, do_concurrent_save
;
11164 frame
.prev
= cs_base
;
11168 find_reachable_labels (code
);
11170 for (; code
; code
= code
->next
)
11172 frame
.current
= code
;
11173 forall_save
= forall_flag
;
11174 do_concurrent_save
= gfc_do_concurrent_flag
;
11176 if (code
->op
== EXEC_FORALL
)
11179 gfc_resolve_forall (code
, ns
, forall_save
);
11182 else if (code
->block
)
11184 omp_workshare_save
= -1;
11187 case EXEC_OACC_PARALLEL_LOOP
:
11188 case EXEC_OACC_PARALLEL
:
11189 case EXEC_OACC_KERNELS_LOOP
:
11190 case EXEC_OACC_KERNELS
:
11191 case EXEC_OACC_DATA
:
11192 case EXEC_OACC_HOST_DATA
:
11193 case EXEC_OACC_LOOP
:
11194 gfc_resolve_oacc_blocks (code
, ns
);
11196 case EXEC_OMP_PARALLEL_WORKSHARE
:
11197 omp_workshare_save
= omp_workshare_flag
;
11198 omp_workshare_flag
= 1;
11199 gfc_resolve_omp_parallel_blocks (code
, ns
);
11201 case EXEC_OMP_PARALLEL
:
11202 case EXEC_OMP_PARALLEL_DO
:
11203 case EXEC_OMP_PARALLEL_DO_SIMD
:
11204 case EXEC_OMP_PARALLEL_SECTIONS
:
11205 case EXEC_OMP_TARGET_PARALLEL
:
11206 case EXEC_OMP_TARGET_PARALLEL_DO
:
11207 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11208 case EXEC_OMP_TARGET_TEAMS
:
11209 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11210 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11211 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11212 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11213 case EXEC_OMP_TASK
:
11214 case EXEC_OMP_TASKLOOP
:
11215 case EXEC_OMP_TASKLOOP_SIMD
:
11216 case EXEC_OMP_TEAMS
:
11217 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11218 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11219 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11220 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11221 omp_workshare_save
= omp_workshare_flag
;
11222 omp_workshare_flag
= 0;
11223 gfc_resolve_omp_parallel_blocks (code
, ns
);
11225 case EXEC_OMP_DISTRIBUTE
:
11226 case EXEC_OMP_DISTRIBUTE_SIMD
:
11228 case EXEC_OMP_DO_SIMD
:
11229 case EXEC_OMP_SIMD
:
11230 case EXEC_OMP_TARGET_SIMD
:
11231 gfc_resolve_omp_do_blocks (code
, ns
);
11233 case EXEC_SELECT_TYPE
:
11234 /* Blocks are handled in resolve_select_type because we have
11235 to transform the SELECT TYPE into ASSOCIATE first. */
11237 case EXEC_DO_CONCURRENT
:
11238 gfc_do_concurrent_flag
= 1;
11239 gfc_resolve_blocks (code
->block
, ns
);
11240 gfc_do_concurrent_flag
= 2;
11242 case EXEC_OMP_WORKSHARE
:
11243 omp_workshare_save
= omp_workshare_flag
;
11244 omp_workshare_flag
= 1;
11247 gfc_resolve_blocks (code
->block
, ns
);
11251 if (omp_workshare_save
!= -1)
11252 omp_workshare_flag
= omp_workshare_save
;
11256 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11257 t
= gfc_resolve_expr (code
->expr1
);
11258 forall_flag
= forall_save
;
11259 gfc_do_concurrent_flag
= do_concurrent_save
;
11261 if (!gfc_resolve_expr (code
->expr2
))
11264 if (code
->op
== EXEC_ALLOCATE
11265 && !gfc_resolve_expr (code
->expr3
))
11271 case EXEC_END_BLOCK
:
11272 case EXEC_END_NESTED_BLOCK
:
11276 case EXEC_ERROR_STOP
:
11278 case EXEC_CONTINUE
:
11280 case EXEC_ASSIGN_CALL
:
11283 case EXEC_CRITICAL
:
11284 resolve_critical (code
);
11287 case EXEC_SYNC_ALL
:
11288 case EXEC_SYNC_IMAGES
:
11289 case EXEC_SYNC_MEMORY
:
11290 resolve_sync (code
);
11295 case EXEC_EVENT_POST
:
11296 case EXEC_EVENT_WAIT
:
11297 resolve_lock_unlock_event (code
);
11300 case EXEC_FAIL_IMAGE
:
11301 case EXEC_FORM_TEAM
:
11302 case EXEC_CHANGE_TEAM
:
11303 case EXEC_END_TEAM
:
11304 case EXEC_SYNC_TEAM
:
11308 /* Keep track of which entry we are up to. */
11309 current_entry_id
= code
->ext
.entry
->id
;
11313 resolve_where (code
, NULL
);
11317 if (code
->expr1
!= NULL
)
11319 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11320 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11321 "INTEGER variable", &code
->expr1
->where
);
11322 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11323 gfc_error ("Variable %qs has not been assigned a target "
11324 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11325 &code
->expr1
->where
);
11328 resolve_branch (code
->label1
, code
);
11332 if (code
->expr1
!= NULL
11333 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11334 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11335 "INTEGER return specifier", &code
->expr1
->where
);
11338 case EXEC_INIT_ASSIGN
:
11339 case EXEC_END_PROCEDURE
:
11346 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11348 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11349 && code
->expr1
->value
.function
.isym
11350 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11351 remove_caf_get_intrinsic (code
->expr1
);
11353 /* If this is a pointer function in an lvalue variable context,
11354 the new code will have to be resolved afresh. This is also the
11355 case with an error, where the code is transformed into NOP to
11356 prevent ICEs downstream. */
11357 if (resolve_ptr_fcn_assign (&code
, ns
)
11358 || code
->op
== EXEC_NOP
)
11361 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11365 if (resolve_ordinary_assign (code
, ns
))
11367 if (code
->op
== EXEC_COMPCALL
)
11373 /* Check for dependencies in deferred character length array
11374 assignments and generate a temporary, if necessary. */
11375 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11378 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11379 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11380 && code
->expr1
->ts
.u
.derived
11381 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11382 generate_component_assignments (&code
, ns
);
11386 case EXEC_LABEL_ASSIGN
:
11387 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11388 gfc_error ("Label %d referenced at %L is never defined",
11389 code
->label1
->value
, &code
->label1
->where
);
11391 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11392 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11393 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11394 != gfc_default_integer_kind
11395 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11396 gfc_error ("ASSIGN statement at %L requires a scalar "
11397 "default INTEGER variable", &code
->expr1
->where
);
11400 case EXEC_POINTER_ASSIGN
:
11407 /* This is both a variable definition and pointer assignment
11408 context, so check both of them. For rank remapping, a final
11409 array ref may be present on the LHS and fool gfc_expr_attr
11410 used in gfc_check_vardef_context. Remove it. */
11411 e
= remove_last_array_ref (code
->expr1
);
11412 t
= gfc_check_vardef_context (e
, true, false, false,
11413 _("pointer assignment"));
11415 t
= gfc_check_vardef_context (e
, false, false, false,
11416 _("pointer assignment"));
11421 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
11423 /* Assigning a class object always is a regular assign. */
11424 if (code
->expr2
->ts
.type
== BT_CLASS
11425 && code
->expr1
->ts
.type
== BT_CLASS
11426 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11427 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11428 && code
->expr2
->expr_type
== EXPR_VARIABLE
11429 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11431 code
->op
= EXEC_ASSIGN
;
11435 case EXEC_ARITHMETIC_IF
:
11437 gfc_expr
*e
= code
->expr1
;
11439 gfc_resolve_expr (e
);
11440 if (e
->expr_type
== EXPR_NULL
)
11441 gfc_error ("Invalid NULL at %L", &e
->where
);
11443 if (t
&& (e
->rank
> 0
11444 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11445 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11446 "REAL or INTEGER expression", &e
->where
);
11448 resolve_branch (code
->label1
, code
);
11449 resolve_branch (code
->label2
, code
);
11450 resolve_branch (code
->label3
, code
);
11455 if (t
&& code
->expr1
!= NULL
11456 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11457 || code
->expr1
->rank
!= 0))
11458 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11459 &code
->expr1
->where
);
11464 resolve_call (code
);
11467 case EXEC_COMPCALL
:
11469 resolve_typebound_subroutine (code
);
11472 case EXEC_CALL_PPC
:
11473 resolve_ppc_call (code
);
11477 /* Select is complicated. Also, a SELECT construct could be
11478 a transformed computed GOTO. */
11479 resolve_select (code
, false);
11482 case EXEC_SELECT_TYPE
:
11483 resolve_select_type (code
, ns
);
11487 resolve_block_construct (code
);
11491 if (code
->ext
.iterator
!= NULL
)
11493 gfc_iterator
*iter
= code
->ext
.iterator
;
11494 if (gfc_resolve_iterator (iter
, true, false))
11495 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11500 case EXEC_DO_WHILE
:
11501 if (code
->expr1
== NULL
)
11502 gfc_internal_error ("gfc_resolve_code(): No expression on "
11505 && (code
->expr1
->rank
!= 0
11506 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11507 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11508 "a scalar LOGICAL expression", &code
->expr1
->where
);
11511 case EXEC_ALLOCATE
:
11513 resolve_allocate_deallocate (code
, "ALLOCATE");
11517 case EXEC_DEALLOCATE
:
11519 resolve_allocate_deallocate (code
, "DEALLOCATE");
11524 if (!gfc_resolve_open (code
->ext
.open
))
11527 resolve_branch (code
->ext
.open
->err
, code
);
11531 if (!gfc_resolve_close (code
->ext
.close
))
11534 resolve_branch (code
->ext
.close
->err
, code
);
11537 case EXEC_BACKSPACE
:
11541 if (!gfc_resolve_filepos (code
->ext
.filepos
))
11544 resolve_branch (code
->ext
.filepos
->err
, code
);
11548 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11551 resolve_branch (code
->ext
.inquire
->err
, code
);
11554 case EXEC_IOLENGTH
:
11555 gcc_assert (code
->ext
.inquire
!= NULL
);
11556 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11559 resolve_branch (code
->ext
.inquire
->err
, code
);
11563 if (!gfc_resolve_wait (code
->ext
.wait
))
11566 resolve_branch (code
->ext
.wait
->err
, code
);
11567 resolve_branch (code
->ext
.wait
->end
, code
);
11568 resolve_branch (code
->ext
.wait
->eor
, code
);
11573 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11576 resolve_branch (code
->ext
.dt
->err
, code
);
11577 resolve_branch (code
->ext
.dt
->end
, code
);
11578 resolve_branch (code
->ext
.dt
->eor
, code
);
11581 case EXEC_TRANSFER
:
11582 resolve_transfer (code
);
11585 case EXEC_DO_CONCURRENT
:
11587 resolve_forall_iterators (code
->ext
.forall_iterator
);
11589 if (code
->expr1
!= NULL
11590 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11591 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11592 "expression", &code
->expr1
->where
);
11595 case EXEC_OACC_PARALLEL_LOOP
:
11596 case EXEC_OACC_PARALLEL
:
11597 case EXEC_OACC_KERNELS_LOOP
:
11598 case EXEC_OACC_KERNELS
:
11599 case EXEC_OACC_DATA
:
11600 case EXEC_OACC_HOST_DATA
:
11601 case EXEC_OACC_LOOP
:
11602 case EXEC_OACC_UPDATE
:
11603 case EXEC_OACC_WAIT
:
11604 case EXEC_OACC_CACHE
:
11605 case EXEC_OACC_ENTER_DATA
:
11606 case EXEC_OACC_EXIT_DATA
:
11607 case EXEC_OACC_ATOMIC
:
11608 case EXEC_OACC_DECLARE
:
11609 gfc_resolve_oacc_directive (code
, ns
);
11612 case EXEC_OMP_ATOMIC
:
11613 case EXEC_OMP_BARRIER
:
11614 case EXEC_OMP_CANCEL
:
11615 case EXEC_OMP_CANCELLATION_POINT
:
11616 case EXEC_OMP_CRITICAL
:
11617 case EXEC_OMP_FLUSH
:
11618 case EXEC_OMP_DISTRIBUTE
:
11619 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11620 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11621 case EXEC_OMP_DISTRIBUTE_SIMD
:
11623 case EXEC_OMP_DO_SIMD
:
11624 case EXEC_OMP_MASTER
:
11625 case EXEC_OMP_ORDERED
:
11626 case EXEC_OMP_SECTIONS
:
11627 case EXEC_OMP_SIMD
:
11628 case EXEC_OMP_SINGLE
:
11629 case EXEC_OMP_TARGET
:
11630 case EXEC_OMP_TARGET_DATA
:
11631 case EXEC_OMP_TARGET_ENTER_DATA
:
11632 case EXEC_OMP_TARGET_EXIT_DATA
:
11633 case EXEC_OMP_TARGET_PARALLEL
:
11634 case EXEC_OMP_TARGET_PARALLEL_DO
:
11635 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11636 case EXEC_OMP_TARGET_SIMD
:
11637 case EXEC_OMP_TARGET_TEAMS
:
11638 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11640 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11641 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11642 case EXEC_OMP_TARGET_UPDATE
:
11643 case EXEC_OMP_TASK
:
11644 case EXEC_OMP_TASKGROUP
:
11645 case EXEC_OMP_TASKLOOP
:
11646 case EXEC_OMP_TASKLOOP_SIMD
:
11647 case EXEC_OMP_TASKWAIT
:
11648 case EXEC_OMP_TASKYIELD
:
11649 case EXEC_OMP_TEAMS
:
11650 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11651 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11652 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11653 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11654 case EXEC_OMP_WORKSHARE
:
11655 gfc_resolve_omp_directive (code
, ns
);
11658 case EXEC_OMP_PARALLEL
:
11659 case EXEC_OMP_PARALLEL_DO
:
11660 case EXEC_OMP_PARALLEL_DO_SIMD
:
11661 case EXEC_OMP_PARALLEL_SECTIONS
:
11662 case EXEC_OMP_PARALLEL_WORKSHARE
:
11663 omp_workshare_save
= omp_workshare_flag
;
11664 omp_workshare_flag
= 0;
11665 gfc_resolve_omp_directive (code
, ns
);
11666 omp_workshare_flag
= omp_workshare_save
;
11670 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11674 cs_base
= frame
.prev
;
11678 /* Resolve initial values and make sure they are compatible with
11682 resolve_values (gfc_symbol
*sym
)
11686 if (sym
->value
== NULL
)
11689 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11690 t
= resolve_structure_cons (sym
->value
, 1);
11692 t
= gfc_resolve_expr (sym
->value
);
11697 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11701 /* Verify any BIND(C) derived types in the namespace so we can report errors
11702 for them once, rather than for each variable declared of that type. */
11705 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11707 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11708 && derived_sym
->attr
.is_bind_c
== 1)
11709 verify_bind_c_derived_type (derived_sym
);
11715 /* Check the interfaces of DTIO procedures associated with derived
11716 type 'sym'. These procedures can either have typebound bindings or
11717 can appear in DTIO generic interfaces. */
11720 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11722 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11725 gfc_check_dtio_interfaces (sym
);
11730 /* Verify that any binding labels used in a given namespace do not collide
11731 with the names or binding labels of any global symbols. Multiple INTERFACE
11732 for the same procedure are permitted. */
11735 gfc_verify_binding_labels (gfc_symbol
*sym
)
11738 const char *module
;
11740 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11741 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11744 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11747 module
= sym
->module
;
11748 else if (sym
->ns
&& sym
->ns
->proc_name
11749 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11750 module
= sym
->ns
->proc_name
->name
;
11751 else if (sym
->ns
&& sym
->ns
->parent
11752 && sym
->ns
&& sym
->ns
->parent
->proc_name
11753 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11754 module
= sym
->ns
->parent
->proc_name
->name
;
11760 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11763 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11764 gsym
->where
= sym
->declared_at
;
11765 gsym
->sym_name
= sym
->name
;
11766 gsym
->binding_label
= sym
->binding_label
;
11767 gsym
->ns
= sym
->ns
;
11768 gsym
->mod_name
= module
;
11769 if (sym
->attr
.function
)
11770 gsym
->type
= GSYM_FUNCTION
;
11771 else if (sym
->attr
.subroutine
)
11772 gsym
->type
= GSYM_SUBROUTINE
;
11773 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11774 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11778 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11780 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11781 "identifier as entity at %L", sym
->name
,
11782 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11783 /* Clear the binding label to prevent checking multiple times. */
11784 sym
->binding_label
= NULL
;
11787 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11788 && (strcmp (module
, gsym
->mod_name
) != 0
11789 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11791 /* This can only happen if the variable is defined in a module - if it
11792 isn't the same module, reject it. */
11793 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11794 "uses the same global identifier as entity at %L from module %qs",
11795 sym
->name
, module
, sym
->binding_label
,
11796 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11797 sym
->binding_label
= NULL
;
11799 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11800 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11801 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11802 && sym
!= gsym
->ns
->proc_name
11803 && (module
!= gsym
->mod_name
11804 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11805 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11807 /* Print an error if the procedure is defined multiple times; we have to
11808 exclude references to the same procedure via module association or
11809 multiple checks for the same procedure. */
11810 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11811 "global identifier as entity at %L", sym
->name
,
11812 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11813 sym
->binding_label
= NULL
;
11818 /* Resolve an index expression. */
11821 resolve_index_expr (gfc_expr
*e
)
11823 if (!gfc_resolve_expr (e
))
11826 if (!gfc_simplify_expr (e
, 0))
11829 if (!gfc_specification_expr (e
))
11836 /* Resolve a charlen structure. */
11839 resolve_charlen (gfc_charlen
*cl
)
11842 bool saved_specification_expr
;
11848 saved_specification_expr
= specification_expr
;
11849 specification_expr
= true;
11851 if (cl
->length_from_typespec
)
11853 if (!gfc_resolve_expr (cl
->length
))
11855 specification_expr
= saved_specification_expr
;
11859 if (!gfc_simplify_expr (cl
->length
, 0))
11861 specification_expr
= saved_specification_expr
;
11865 /* cl->length has been resolved. It should have an integer type. */
11866 if (cl
->length
->ts
.type
!= BT_INTEGER
)
11868 gfc_error ("Scalar INTEGER expression expected at %L",
11869 &cl
->length
->where
);
11875 if (!resolve_index_expr (cl
->length
))
11877 specification_expr
= saved_specification_expr
;
11882 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11883 a negative value, the length of character entities declared is zero. */
11884 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11885 && mpz_sgn (cl
->length
->value
.integer
) < 0)
11886 gfc_replace_expr (cl
->length
,
11887 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
11889 /* Check that the character length is not too large. */
11890 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11891 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11892 && cl
->length
->ts
.type
== BT_INTEGER
11893 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11895 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11896 specification_expr
= saved_specification_expr
;
11900 specification_expr
= saved_specification_expr
;
11905 /* Test for non-constant shape arrays. */
11908 is_non_constant_shape_array (gfc_symbol
*sym
)
11914 not_constant
= false;
11915 if (sym
->as
!= NULL
)
11917 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11918 has not been simplified; parameter array references. Do the
11919 simplification now. */
11920 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11922 e
= sym
->as
->lower
[i
];
11923 if (e
&& (!resolve_index_expr(e
)
11924 || !gfc_is_constant_expr (e
)))
11925 not_constant
= true;
11926 e
= sym
->as
->upper
[i
];
11927 if (e
&& (!resolve_index_expr(e
)
11928 || !gfc_is_constant_expr (e
)))
11929 not_constant
= true;
11932 return not_constant
;
11935 /* Given a symbol and an initialization expression, add code to initialize
11936 the symbol to the function entry. */
11938 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11942 gfc_namespace
*ns
= sym
->ns
;
11944 /* Search for the function namespace if this is a contained
11945 function without an explicit result. */
11946 if (sym
->attr
.function
&& sym
== sym
->result
11947 && sym
->name
!= sym
->ns
->proc_name
->name
)
11949 ns
= ns
->contained
;
11950 for (;ns
; ns
= ns
->sibling
)
11951 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11957 gfc_free_expr (init
);
11961 /* Build an l-value expression for the result. */
11962 lval
= gfc_lval_expr_from_sym (sym
);
11964 /* Add the code at scope entry. */
11965 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11966 init_st
->next
= ns
->code
;
11967 ns
->code
= init_st
;
11969 /* Assign the default initializer to the l-value. */
11970 init_st
->loc
= sym
->declared_at
;
11971 init_st
->expr1
= lval
;
11972 init_st
->expr2
= init
;
11976 /* Whether or not we can generate a default initializer for a symbol. */
11979 can_generate_init (gfc_symbol
*sym
)
11981 symbol_attribute
*a
;
11986 /* These symbols should never have a default initialization. */
11991 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11992 && (CLASS_DATA (sym
)->attr
.class_pointer
11993 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11994 || a
->in_equivalence
12001 || (!a
->referenced
&& !a
->result
)
12002 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12003 || (a
->function
&& sym
!= sym
->result
)
12008 /* Assign the default initializer to a derived type variable or result. */
12011 apply_default_init (gfc_symbol
*sym
)
12013 gfc_expr
*init
= NULL
;
12015 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12018 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12019 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12021 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12024 build_init_assign (sym
, init
);
12025 sym
->attr
.referenced
= 1;
12029 /* Build an initializer for a local. Returns null if the symbol should not have
12030 a default initialization. */
12033 build_default_init_expr (gfc_symbol
*sym
)
12035 /* These symbols should never have a default initialization. */
12036 if (sym
->attr
.allocatable
12037 || sym
->attr
.external
12039 || sym
->attr
.pointer
12040 || sym
->attr
.in_equivalence
12041 || sym
->attr
.in_common
12044 || sym
->attr
.cray_pointee
12045 || sym
->attr
.cray_pointer
12049 /* Get the appropriate init expression. */
12050 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12053 /* Add an initialization expression to a local variable. */
12055 apply_default_init_local (gfc_symbol
*sym
)
12057 gfc_expr
*init
= NULL
;
12059 /* The symbol should be a variable or a function return value. */
12060 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12061 || (sym
->attr
.function
&& sym
->result
!= sym
))
12064 /* Try to build the initializer expression. If we can't initialize
12065 this symbol, then init will be NULL. */
12066 init
= build_default_init_expr (sym
);
12070 /* For saved variables, we don't want to add an initializer at function
12071 entry, so we just add a static initializer. Note that automatic variables
12072 are stack allocated even with -fno-automatic; we have also to exclude
12073 result variable, which are also nonstatic. */
12074 if (!sym
->attr
.automatic
12075 && (sym
->attr
.save
|| sym
->ns
->save_all
12076 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12077 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12078 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12080 /* Don't clobber an existing initializer! */
12081 gcc_assert (sym
->value
== NULL
);
12086 build_init_assign (sym
, init
);
12090 /* Resolution of common features of flavors variable and procedure. */
12093 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12095 gfc_array_spec
*as
;
12097 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12098 as
= CLASS_DATA (sym
)->as
;
12102 /* Constraints on deferred shape variable. */
12103 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12105 bool pointer
, allocatable
, dimension
;
12107 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12109 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12110 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12111 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12115 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12116 allocatable
= sym
->attr
.allocatable
;
12117 dimension
= sym
->attr
.dimension
;
12122 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12124 gfc_error ("Allocatable array %qs at %L must have a deferred "
12125 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12128 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12129 "%qs at %L may not be ALLOCATABLE",
12130 sym
->name
, &sym
->declared_at
))
12134 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12136 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12137 "assumed rank", sym
->name
, &sym
->declared_at
);
12143 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12144 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12146 gfc_error ("Array %qs at %L cannot have a deferred shape",
12147 sym
->name
, &sym
->declared_at
);
12152 /* Constraints on polymorphic variables. */
12153 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12156 if (sym
->attr
.class_ok
12157 && !sym
->attr
.select_type_temporary
12158 && !UNLIMITED_POLY (sym
)
12159 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12161 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12162 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12163 &sym
->declared_at
);
12168 /* Assume that use associated symbols were checked in the module ns.
12169 Class-variables that are associate-names are also something special
12170 and excepted from the test. */
12171 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12173 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12174 "or pointer", sym
->name
, &sym
->declared_at
);
12183 /* Additional checks for symbols with flavor variable and derived
12184 type. To be called from resolve_fl_variable. */
12187 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12189 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12191 /* Check to see if a derived type is blocked from being host
12192 associated by the presence of another class I symbol in the same
12193 namespace. 14.6.1.3 of the standard and the discussion on
12194 comp.lang.fortran. */
12195 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12196 && !sym
->ts
.u
.derived
->attr
.use_assoc
12197 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12200 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12201 if (s
&& s
->attr
.generic
)
12202 s
= gfc_find_dt_in_generic (s
);
12203 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12205 gfc_error ("The type %qs cannot be host associated at %L "
12206 "because it is blocked by an incompatible object "
12207 "of the same name declared at %L",
12208 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12214 /* 4th constraint in section 11.3: "If an object of a type for which
12215 component-initialization is specified (R429) appears in the
12216 specification-part of a module and does not have the ALLOCATABLE
12217 or POINTER attribute, the object shall have the SAVE attribute."
12219 The check for initializers is performed with
12220 gfc_has_default_initializer because gfc_default_initializer generates
12221 a hidden default for allocatable components. */
12222 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12223 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12224 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12225 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12226 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12227 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12228 "%qs at %L, needed due to the default "
12229 "initialization", sym
->name
, &sym
->declared_at
))
12232 /* Assign default initializer. */
12233 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12234 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12235 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12241 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12242 except in the declaration of an entity or component that has the POINTER
12243 or ALLOCATABLE attribute. */
12246 deferred_requirements (gfc_symbol
*sym
)
12248 if (sym
->ts
.deferred
12249 && !(sym
->attr
.pointer
12250 || sym
->attr
.allocatable
12251 || sym
->attr
.associate_var
12252 || sym
->attr
.omp_udr_artificial_var
))
12254 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12255 "requires either the POINTER or ALLOCATABLE attribute",
12256 sym
->name
, &sym
->declared_at
);
12263 /* Resolve symbols with flavor variable. */
12266 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12268 int no_init_flag
, automatic_flag
;
12270 const char *auto_save_msg
;
12271 bool saved_specification_expr
;
12273 auto_save_msg
= "Automatic object %qs at %L cannot have the "
12276 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12279 /* Set this flag to check that variables are parameters of all entries.
12280 This check is effected by the call to gfc_resolve_expr through
12281 is_non_constant_shape_array. */
12282 saved_specification_expr
= specification_expr
;
12283 specification_expr
= true;
12285 if (sym
->ns
->proc_name
12286 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12287 || sym
->ns
->proc_name
->attr
.is_main_program
)
12288 && !sym
->attr
.use_assoc
12289 && !sym
->attr
.allocatable
12290 && !sym
->attr
.pointer
12291 && is_non_constant_shape_array (sym
))
12293 /* F08:C541. The shape of an array defined in a main program or module
12294 * needs to be constant. */
12295 gfc_error ("The module or main program array %qs at %L must "
12296 "have constant shape", sym
->name
, &sym
->declared_at
);
12297 specification_expr
= saved_specification_expr
;
12301 /* Constraints on deferred type parameter. */
12302 if (!deferred_requirements (sym
))
12305 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12307 /* Make sure that character string variables with assumed length are
12308 dummy arguments. */
12309 e
= sym
->ts
.u
.cl
->length
;
12310 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12311 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12312 && !sym
->attr
.omp_udr_artificial_var
)
12314 gfc_error ("Entity with assumed character length at %L must be a "
12315 "dummy argument or a PARAMETER", &sym
->declared_at
);
12316 specification_expr
= saved_specification_expr
;
12320 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12322 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12323 specification_expr
= saved_specification_expr
;
12327 if (!gfc_is_constant_expr (e
)
12328 && !(e
->expr_type
== EXPR_VARIABLE
12329 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12331 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12332 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12333 || sym
->ns
->proc_name
->attr
.is_main_program
))
12335 gfc_error ("%qs at %L must have constant character length "
12336 "in this context", sym
->name
, &sym
->declared_at
);
12337 specification_expr
= saved_specification_expr
;
12340 if (sym
->attr
.in_common
)
12342 gfc_error ("COMMON variable %qs at %L must have constant "
12343 "character length", sym
->name
, &sym
->declared_at
);
12344 specification_expr
= saved_specification_expr
;
12350 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12351 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12353 /* Determine if the symbol may not have an initializer. */
12354 no_init_flag
= automatic_flag
= 0;
12355 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12356 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12358 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12359 && is_non_constant_shape_array (sym
))
12361 no_init_flag
= automatic_flag
= 1;
12363 /* Also, they must not have the SAVE attribute.
12364 SAVE_IMPLICIT is checked below. */
12365 if (sym
->as
&& sym
->attr
.codimension
)
12367 int corank
= sym
->as
->corank
;
12368 sym
->as
->corank
= 0;
12369 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12370 sym
->as
->corank
= corank
;
12372 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12374 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12375 specification_expr
= saved_specification_expr
;
12380 /* Ensure that any initializer is simplified. */
12382 gfc_simplify_expr (sym
->value
, 1);
12384 /* Reject illegal initializers. */
12385 if (!sym
->mark
&& sym
->value
)
12387 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12388 && CLASS_DATA (sym
)->attr
.allocatable
))
12389 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12390 sym
->name
, &sym
->declared_at
);
12391 else if (sym
->attr
.external
)
12392 gfc_error ("External %qs at %L cannot have an initializer",
12393 sym
->name
, &sym
->declared_at
);
12394 else if (sym
->attr
.dummy
12395 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12396 gfc_error ("Dummy %qs at %L cannot have an initializer",
12397 sym
->name
, &sym
->declared_at
);
12398 else if (sym
->attr
.intrinsic
)
12399 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12400 sym
->name
, &sym
->declared_at
);
12401 else if (sym
->attr
.result
)
12402 gfc_error ("Function result %qs at %L cannot have an initializer",
12403 sym
->name
, &sym
->declared_at
);
12404 else if (automatic_flag
)
12405 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12406 sym
->name
, &sym
->declared_at
);
12408 goto no_init_error
;
12409 specification_expr
= saved_specification_expr
;
12414 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12416 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12417 specification_expr
= saved_specification_expr
;
12421 specification_expr
= saved_specification_expr
;
12426 /* Compare the dummy characteristics of a module procedure interface
12427 declaration with the corresponding declaration in a submodule. */
12428 static gfc_formal_arglist
*new_formal
;
12429 static char errmsg
[200];
12432 compare_fsyms (gfc_symbol
*sym
)
12436 if (sym
== NULL
|| new_formal
== NULL
)
12439 fsym
= new_formal
->sym
;
12444 if (strcmp (sym
->name
, fsym
->name
) == 0)
12446 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12447 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12452 /* Resolve a procedure. */
12455 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12457 gfc_formal_arglist
*arg
;
12459 if (sym
->attr
.function
12460 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12463 if (sym
->ts
.type
== BT_CHARACTER
)
12465 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12467 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12468 && !resolve_charlen (cl
))
12471 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12472 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12474 gfc_error ("Character-valued statement function %qs at %L must "
12475 "have constant length", sym
->name
, &sym
->declared_at
);
12480 /* Ensure that derived type for are not of a private type. Internal
12481 module procedures are excluded by 2.2.3.3 - i.e., they are not
12482 externally accessible and can access all the objects accessible in
12484 if (!(sym
->ns
->parent
12485 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12486 && gfc_check_symbol_access (sym
))
12488 gfc_interface
*iface
;
12490 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12493 && arg
->sym
->ts
.type
== BT_DERIVED
12494 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12495 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12496 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12497 "and cannot be a dummy argument"
12498 " of %qs, which is PUBLIC at %L",
12499 arg
->sym
->name
, sym
->name
,
12500 &sym
->declared_at
))
12502 /* Stop this message from recurring. */
12503 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12508 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12509 PRIVATE to the containing module. */
12510 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12512 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12515 && arg
->sym
->ts
.type
== BT_DERIVED
12516 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12517 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12518 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12519 "PUBLIC interface %qs at %L "
12520 "takes dummy arguments of %qs which "
12521 "is PRIVATE", iface
->sym
->name
,
12522 sym
->name
, &iface
->sym
->declared_at
,
12523 gfc_typename(&arg
->sym
->ts
)))
12525 /* Stop this message from recurring. */
12526 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12533 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12534 && !sym
->attr
.proc_pointer
)
12536 gfc_error ("Function %qs at %L cannot have an initializer",
12537 sym
->name
, &sym
->declared_at
);
12541 /* An external symbol may not have an initializer because it is taken to be
12542 a procedure. Exception: Procedure Pointers. */
12543 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12545 gfc_error ("External object %qs at %L may not have an initializer",
12546 sym
->name
, &sym
->declared_at
);
12550 /* An elemental function is required to return a scalar 12.7.1 */
12551 if (sym
->attr
.elemental
&& sym
->attr
.function
12552 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12554 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12555 "result", sym
->name
, &sym
->declared_at
);
12556 /* Reset so that the error only occurs once. */
12557 sym
->attr
.elemental
= 0;
12561 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12562 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12564 gfc_error ("Statement function %qs at %L may not have pointer or "
12565 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12569 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12570 char-len-param shall not be array-valued, pointer-valued, recursive
12571 or pure. ....snip... A character value of * may only be used in the
12572 following ways: (i) Dummy arg of procedure - dummy associates with
12573 actual length; (ii) To declare a named constant; or (iii) External
12574 function - but length must be declared in calling scoping unit. */
12575 if (sym
->attr
.function
12576 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12577 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12579 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12580 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12582 if (sym
->as
&& sym
->as
->rank
)
12583 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12584 "array-valued", sym
->name
, &sym
->declared_at
);
12586 if (sym
->attr
.pointer
)
12587 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12588 "pointer-valued", sym
->name
, &sym
->declared_at
);
12590 if (sym
->attr
.pure
)
12591 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12592 "pure", sym
->name
, &sym
->declared_at
);
12594 if (sym
->attr
.recursive
)
12595 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12596 "recursive", sym
->name
, &sym
->declared_at
);
12601 /* Appendix B.2 of the standard. Contained functions give an
12602 error anyway. Deferred character length is an F2003 feature.
12603 Don't warn on intrinsic conversion functions, which start
12604 with two underscores. */
12605 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12606 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12607 gfc_notify_std (GFC_STD_F95_OBS
,
12608 "CHARACTER(*) function %qs at %L",
12609 sym
->name
, &sym
->declared_at
);
12612 /* F2008, C1218. */
12613 if (sym
->attr
.elemental
)
12615 if (sym
->attr
.proc_pointer
)
12617 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12618 sym
->name
, &sym
->declared_at
);
12621 if (sym
->attr
.dummy
)
12623 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12624 sym
->name
, &sym
->declared_at
);
12629 /* F2018, C15100: "The result of an elemental function shall be scalar,
12630 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12631 pointer is tested and caught elsewhere. */
12632 if (sym
->attr
.elemental
&& sym
->result
12633 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12635 gfc_error ("Function result variable %qs at %L of elemental "
12636 "function %qs shall not have an ALLOCATABLE or POINTER "
12637 "attribute", sym
->result
->name
,
12638 &sym
->result
->declared_at
, sym
->name
);
12642 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12644 gfc_formal_arglist
*curr_arg
;
12645 int has_non_interop_arg
= 0;
12647 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12648 sym
->common_block
))
12650 /* Clear these to prevent looking at them again if there was an
12652 sym
->attr
.is_bind_c
= 0;
12653 sym
->attr
.is_c_interop
= 0;
12654 sym
->ts
.is_c_interop
= 0;
12658 /* So far, no errors have been found. */
12659 sym
->attr
.is_c_interop
= 1;
12660 sym
->ts
.is_c_interop
= 1;
12663 curr_arg
= gfc_sym_get_dummy_args (sym
);
12664 while (curr_arg
!= NULL
)
12666 /* Skip implicitly typed dummy args here. */
12667 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12668 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12669 /* If something is found to fail, record the fact so we
12670 can mark the symbol for the procedure as not being
12671 BIND(C) to try and prevent multiple errors being
12673 has_non_interop_arg
= 1;
12675 curr_arg
= curr_arg
->next
;
12678 /* See if any of the arguments were not interoperable and if so, clear
12679 the procedure symbol to prevent duplicate error messages. */
12680 if (has_non_interop_arg
!= 0)
12682 sym
->attr
.is_c_interop
= 0;
12683 sym
->ts
.is_c_interop
= 0;
12684 sym
->attr
.is_bind_c
= 0;
12688 if (!sym
->attr
.proc_pointer
)
12690 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12692 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12693 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12696 if (sym
->attr
.intent
)
12698 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12699 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12702 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12704 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12705 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12708 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12709 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12710 || sym
->attr
.contained
))
12712 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12713 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12716 if (strcmp ("ppr@", sym
->name
) == 0)
12718 gfc_error ("Procedure pointer result %qs at %L "
12719 "is missing the pointer attribute",
12720 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12725 /* Assume that a procedure whose body is not known has references
12726 to external arrays. */
12727 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12728 sym
->attr
.array_outer_dependency
= 1;
12730 /* Compare the characteristics of a module procedure with the
12731 interface declaration. Ideally this would be done with
12732 gfc_compare_interfaces but, at present, the formal interface
12733 cannot be copied to the ts.interface. */
12734 if (sym
->attr
.module_procedure
12735 && sym
->attr
.if_source
== IFSRC_DECL
)
12738 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12740 char *submodule_name
;
12741 strcpy (name
, sym
->ns
->proc_name
->name
);
12742 module_name
= strtok (name
, ".");
12743 submodule_name
= strtok (NULL
, ".");
12745 iface
= sym
->tlink
;
12748 /* Make sure that the result uses the correct charlen for deferred
12750 if (iface
&& sym
->result
12751 && iface
->ts
.type
== BT_CHARACTER
12752 && iface
->ts
.deferred
)
12753 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12758 /* Check the procedure characteristics. */
12759 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12761 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12762 "PROCEDURE at %L and its interface in %s",
12763 &sym
->declared_at
, module_name
);
12767 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12769 gfc_error ("Mismatch in PURE attribute between MODULE "
12770 "PROCEDURE at %L and its interface in %s",
12771 &sym
->declared_at
, module_name
);
12775 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12777 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12778 "PROCEDURE at %L and its interface in %s",
12779 &sym
->declared_at
, module_name
);
12783 /* Check the result characteristics. */
12784 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12786 gfc_error ("%s between the MODULE PROCEDURE declaration "
12787 "in MODULE %qs and the declaration at %L in "
12789 errmsg
, module_name
, &sym
->declared_at
,
12790 submodule_name
? submodule_name
: module_name
);
12795 /* Check the characteristics of the formal arguments. */
12796 if (sym
->formal
&& sym
->formal_ns
)
12798 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12801 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12809 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12810 been defined and we now know their defined arguments, check that they fulfill
12811 the requirements of the standard for procedures used as finalizers. */
12814 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12816 gfc_finalizer
* list
;
12817 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12818 bool result
= true;
12819 bool seen_scalar
= false;
12822 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12825 gfc_resolve_finalizers (parent
, finalizable
);
12827 /* Ensure that derived-type components have a their finalizers resolved. */
12828 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12829 for (c
= derived
->components
; c
; c
= c
->next
)
12830 if (c
->ts
.type
== BT_DERIVED
12831 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12833 bool has_final2
= false;
12834 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12835 return false; /* Error. */
12836 has_final
= has_final
|| has_final2
;
12838 /* Return early if not finalizable. */
12842 *finalizable
= false;
12846 /* Walk over the list of finalizer-procedures, check them, and if any one
12847 does not fit in with the standard's definition, print an error and remove
12848 it from the list. */
12849 prev_link
= &derived
->f2k_derived
->finalizers
;
12850 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12852 gfc_formal_arglist
*dummy_args
;
12857 /* Skip this finalizer if we already resolved it. */
12858 if (list
->proc_tree
)
12860 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12861 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
12862 seen_scalar
= true;
12863 prev_link
= &(list
->next
);
12867 /* Check this exists and is a SUBROUTINE. */
12868 if (!list
->proc_sym
->attr
.subroutine
)
12870 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12871 list
->proc_sym
->name
, &list
->where
);
12875 /* We should have exactly one argument. */
12876 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12877 if (!dummy_args
|| dummy_args
->next
)
12879 gfc_error ("FINAL procedure at %L must have exactly one argument",
12883 arg
= dummy_args
->sym
;
12885 /* This argument must be of our type. */
12886 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12888 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12889 &arg
->declared_at
, derived
->name
);
12893 /* It must neither be a pointer nor allocatable nor optional. */
12894 if (arg
->attr
.pointer
)
12896 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12897 &arg
->declared_at
);
12900 if (arg
->attr
.allocatable
)
12902 gfc_error ("Argument of FINAL procedure at %L must not be"
12903 " ALLOCATABLE", &arg
->declared_at
);
12906 if (arg
->attr
.optional
)
12908 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12909 &arg
->declared_at
);
12913 /* It must not be INTENT(OUT). */
12914 if (arg
->attr
.intent
== INTENT_OUT
)
12916 gfc_error ("Argument of FINAL procedure at %L must not be"
12917 " INTENT(OUT)", &arg
->declared_at
);
12921 /* Warn if the procedure is non-scalar and not assumed shape. */
12922 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12923 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12924 gfc_warning (OPT_Wsurprising
,
12925 "Non-scalar FINAL procedure at %L should have assumed"
12926 " shape argument", &arg
->declared_at
);
12928 /* Check that it does not match in kind and rank with a FINAL procedure
12929 defined earlier. To really loop over the *earlier* declarations,
12930 we need to walk the tail of the list as new ones were pushed at the
12932 /* TODO: Handle kind parameters once they are implemented. */
12933 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12934 for (i
= list
->next
; i
; i
= i
->next
)
12936 gfc_formal_arglist
*dummy_args
;
12938 /* Argument list might be empty; that is an error signalled earlier,
12939 but we nevertheless continued resolving. */
12940 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12943 gfc_symbol
* i_arg
= dummy_args
->sym
;
12944 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12945 if (i_rank
== my_rank
)
12947 gfc_error ("FINAL procedure %qs declared at %L has the same"
12948 " rank (%d) as %qs",
12949 list
->proc_sym
->name
, &list
->where
, my_rank
,
12950 i
->proc_sym
->name
);
12956 /* Is this the/a scalar finalizer procedure? */
12958 seen_scalar
= true;
12960 /* Find the symtree for this procedure. */
12961 gcc_assert (!list
->proc_tree
);
12962 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12964 prev_link
= &list
->next
;
12967 /* Remove wrong nodes immediately from the list so we don't risk any
12968 troubles in the future when they might fail later expectations. */
12971 *prev_link
= list
->next
;
12972 gfc_free_finalizer (i
);
12976 if (result
== false)
12979 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12980 were nodes in the list, must have been for arrays. It is surely a good
12981 idea to have a scalar version there if there's something to finalize. */
12982 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
12983 gfc_warning (OPT_Wsurprising
,
12984 "Only array FINAL procedures declared for derived type %qs"
12985 " defined at %L, suggest also scalar one",
12986 derived
->name
, &derived
->declared_at
);
12988 vtab
= gfc_find_derived_vtab (derived
);
12989 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12990 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12993 *finalizable
= true;
12999 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13002 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13003 const char* generic_name
, locus where
)
13005 gfc_symbol
*sym1
, *sym2
;
13006 const char *pass1
, *pass2
;
13007 gfc_formal_arglist
*dummy_args
;
13009 gcc_assert (t1
->specific
&& t2
->specific
);
13010 gcc_assert (!t1
->specific
->is_generic
);
13011 gcc_assert (!t2
->specific
->is_generic
);
13012 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13014 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13015 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13020 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13021 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13022 || sym1
->attr
.function
!= sym2
->attr
.function
)
13024 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
13025 " GENERIC %qs at %L",
13026 sym1
->name
, sym2
->name
, generic_name
, &where
);
13030 /* Determine PASS arguments. */
13031 if (t1
->specific
->nopass
)
13033 else if (t1
->specific
->pass_arg
)
13034 pass1
= t1
->specific
->pass_arg
;
13037 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13039 pass1
= dummy_args
->sym
->name
;
13043 if (t2
->specific
->nopass
)
13045 else if (t2
->specific
->pass_arg
)
13046 pass2
= t2
->specific
->pass_arg
;
13049 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13051 pass2
= dummy_args
->sym
->name
;
13056 /* Compare the interfaces. */
13057 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13058 NULL
, 0, pass1
, pass2
))
13060 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13061 sym1
->name
, sym2
->name
, generic_name
, &where
);
13069 /* Worker function for resolving a generic procedure binding; this is used to
13070 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13072 The difference between those cases is finding possible inherited bindings
13073 that are overridden, as one has to look for them in tb_sym_root,
13074 tb_uop_root or tb_op, respectively. Thus the caller must already find
13075 the super-type and set p->overridden correctly. */
13078 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13079 gfc_typebound_proc
* p
, const char* name
)
13081 gfc_tbp_generic
* target
;
13082 gfc_symtree
* first_target
;
13083 gfc_symtree
* inherited
;
13085 gcc_assert (p
&& p
->is_generic
);
13087 /* Try to find the specific bindings for the symtrees in our target-list. */
13088 gcc_assert (p
->u
.generic
);
13089 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13090 if (!target
->specific
)
13092 gfc_typebound_proc
* overridden_tbp
;
13093 gfc_tbp_generic
* g
;
13094 const char* target_name
;
13096 target_name
= target
->specific_st
->name
;
13098 /* Defined for this type directly. */
13099 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13101 target
->specific
= target
->specific_st
->n
.tb
;
13102 goto specific_found
;
13105 /* Look for an inherited specific binding. */
13108 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13113 gcc_assert (inherited
->n
.tb
);
13114 target
->specific
= inherited
->n
.tb
;
13115 goto specific_found
;
13119 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13120 " at %L", target_name
, name
, &p
->where
);
13123 /* Once we've found the specific binding, check it is not ambiguous with
13124 other specifics already found or inherited for the same GENERIC. */
13126 gcc_assert (target
->specific
);
13128 /* This must really be a specific binding! */
13129 if (target
->specific
->is_generic
)
13131 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13132 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13136 /* Check those already resolved on this type directly. */
13137 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13138 if (g
!= target
&& g
->specific
13139 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13142 /* Check for ambiguity with inherited specific targets. */
13143 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13144 overridden_tbp
= overridden_tbp
->overridden
)
13145 if (overridden_tbp
->is_generic
)
13147 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13149 gcc_assert (g
->specific
);
13150 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13156 /* If we attempt to "overwrite" a specific binding, this is an error. */
13157 if (p
->overridden
&& !p
->overridden
->is_generic
)
13159 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
13160 " the same name", name
, &p
->where
);
13164 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13165 all must have the same attributes here. */
13166 first_target
= p
->u
.generic
->specific
->u
.specific
;
13167 gcc_assert (first_target
);
13168 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13169 p
->function
= first_target
->n
.sym
->attr
.function
;
13175 /* Resolve a GENERIC procedure binding for a derived type. */
13178 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13180 gfc_symbol
* super_type
;
13182 /* Find the overridden binding if any. */
13183 st
->n
.tb
->overridden
= NULL
;
13184 super_type
= gfc_get_derived_super_type (derived
);
13187 gfc_symtree
* overridden
;
13188 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13191 if (overridden
&& overridden
->n
.tb
)
13192 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13195 /* Resolve using worker function. */
13196 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13200 /* Retrieve the target-procedure of an operator binding and do some checks in
13201 common for intrinsic and user-defined type-bound operators. */
13204 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13206 gfc_symbol
* target_proc
;
13208 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13209 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13210 gcc_assert (target_proc
);
13212 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13213 if (target
->specific
->nopass
)
13215 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
13219 return target_proc
;
13223 /* Resolve a type-bound intrinsic operator. */
13226 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13227 gfc_typebound_proc
* p
)
13229 gfc_symbol
* super_type
;
13230 gfc_tbp_generic
* target
;
13232 /* If there's already an error here, do nothing (but don't fail again). */
13236 /* Operators should always be GENERIC bindings. */
13237 gcc_assert (p
->is_generic
);
13239 /* Look for an overridden binding. */
13240 super_type
= gfc_get_derived_super_type (derived
);
13241 if (super_type
&& super_type
->f2k_derived
)
13242 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13245 p
->overridden
= NULL
;
13247 /* Resolve general GENERIC properties using worker function. */
13248 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13251 /* Check the targets to be procedures of correct interface. */
13252 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13254 gfc_symbol
* target_proc
;
13256 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13260 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13263 /* Add target to non-typebound operator list. */
13264 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13265 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13267 gfc_interface
*head
, *intr
;
13269 /* Preempt 'gfc_check_new_interface' for submodules, where the
13270 mechanism for handling module procedures winds up resolving
13271 operator interfaces twice and would otherwise cause an error. */
13272 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13273 if (intr
->sym
== target_proc
13274 && target_proc
->attr
.used_in_submodule
)
13277 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13278 target_proc
, p
->where
))
13280 head
= derived
->ns
->op
[op
];
13281 intr
= gfc_get_interface ();
13282 intr
->sym
= target_proc
;
13283 intr
->where
= p
->where
;
13285 derived
->ns
->op
[op
] = intr
;
13297 /* Resolve a type-bound user operator (tree-walker callback). */
13299 static gfc_symbol
* resolve_bindings_derived
;
13300 static bool resolve_bindings_result
;
13302 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13305 resolve_typebound_user_op (gfc_symtree
* stree
)
13307 gfc_symbol
* super_type
;
13308 gfc_tbp_generic
* target
;
13310 gcc_assert (stree
&& stree
->n
.tb
);
13312 if (stree
->n
.tb
->error
)
13315 /* Operators should always be GENERIC bindings. */
13316 gcc_assert (stree
->n
.tb
->is_generic
);
13318 /* Find overridden procedure, if any. */
13319 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13320 if (super_type
&& super_type
->f2k_derived
)
13322 gfc_symtree
* overridden
;
13323 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13324 stree
->name
, true, NULL
);
13326 if (overridden
&& overridden
->n
.tb
)
13327 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13330 stree
->n
.tb
->overridden
= NULL
;
13332 /* Resolve basically using worker function. */
13333 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13336 /* Check the targets to be functions of correct interface. */
13337 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13339 gfc_symbol
* target_proc
;
13341 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13345 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13352 resolve_bindings_result
= false;
13353 stree
->n
.tb
->error
= 1;
13357 /* Resolve the type-bound procedures for a derived type. */
13360 resolve_typebound_procedure (gfc_symtree
* stree
)
13364 gfc_symbol
* me_arg
;
13365 gfc_symbol
* super_type
;
13366 gfc_component
* comp
;
13368 gcc_assert (stree
);
13370 /* Undefined specific symbol from GENERIC target definition. */
13374 if (stree
->n
.tb
->error
)
13377 /* If this is a GENERIC binding, use that routine. */
13378 if (stree
->n
.tb
->is_generic
)
13380 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13385 /* Get the target-procedure to check it. */
13386 gcc_assert (!stree
->n
.tb
->is_generic
);
13387 gcc_assert (stree
->n
.tb
->u
.specific
);
13388 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13389 where
= stree
->n
.tb
->where
;
13391 /* Default access should already be resolved from the parser. */
13392 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13394 if (stree
->n
.tb
->deferred
)
13396 if (!check_proc_interface (proc
, &where
))
13401 /* Check for F08:C465. */
13402 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13403 || (proc
->attr
.proc
!= PROC_MODULE
13404 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13405 || proc
->attr
.abstract
)
13407 gfc_error ("%qs must be a module procedure or an external procedure with"
13408 " an explicit interface at %L", proc
->name
, &where
);
13413 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13414 stree
->n
.tb
->function
= proc
->attr
.function
;
13416 /* Find the super-type of the current derived type. We could do this once and
13417 store in a global if speed is needed, but as long as not I believe this is
13418 more readable and clearer. */
13419 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13421 /* If PASS, resolve and check arguments if not already resolved / loaded
13422 from a .mod file. */
13423 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13425 gfc_formal_arglist
*dummy_args
;
13427 dummy_args
= gfc_sym_get_dummy_args (proc
);
13428 if (stree
->n
.tb
->pass_arg
)
13430 gfc_formal_arglist
*i
;
13432 /* If an explicit passing argument name is given, walk the arg-list
13433 and look for it. */
13436 stree
->n
.tb
->pass_arg_num
= 1;
13437 for (i
= dummy_args
; i
; i
= i
->next
)
13439 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13444 ++stree
->n
.tb
->pass_arg_num
;
13449 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13451 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13452 stree
->n
.tb
->pass_arg
);
13458 /* Otherwise, take the first one; there should in fact be at least
13460 stree
->n
.tb
->pass_arg_num
= 1;
13463 gfc_error ("Procedure %qs with PASS at %L must have at"
13464 " least one argument", proc
->name
, &where
);
13467 me_arg
= dummy_args
->sym
;
13470 /* Now check that the argument-type matches and the passed-object
13471 dummy argument is generally fine. */
13473 gcc_assert (me_arg
);
13475 if (me_arg
->ts
.type
!= BT_CLASS
)
13477 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13478 " at %L", proc
->name
, &where
);
13482 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13483 != resolve_bindings_derived
)
13485 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13486 " the derived-type %qs", me_arg
->name
, proc
->name
,
13487 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13491 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13492 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13494 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13495 " scalar", proc
->name
, &where
);
13498 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13500 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13501 " be ALLOCATABLE", proc
->name
, &where
);
13504 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13506 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13507 " be POINTER", proc
->name
, &where
);
13512 /* If we are extending some type, check that we don't override a procedure
13513 flagged NON_OVERRIDABLE. */
13514 stree
->n
.tb
->overridden
= NULL
;
13517 gfc_symtree
* overridden
;
13518 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13519 stree
->name
, true, NULL
);
13523 if (overridden
->n
.tb
)
13524 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13526 if (!gfc_check_typebound_override (stree
, overridden
))
13531 /* See if there's a name collision with a component directly in this type. */
13532 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13533 if (!strcmp (comp
->name
, stree
->name
))
13535 gfc_error ("Procedure %qs at %L has the same name as a component of"
13537 stree
->name
, &where
, resolve_bindings_derived
->name
);
13541 /* Try to find a name collision with an inherited component. */
13542 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13545 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13546 " component of %qs",
13547 stree
->name
, &where
, resolve_bindings_derived
->name
);
13551 stree
->n
.tb
->error
= 0;
13555 resolve_bindings_result
= false;
13556 stree
->n
.tb
->error
= 1;
13561 resolve_typebound_procedures (gfc_symbol
* derived
)
13564 gfc_symbol
* super_type
;
13566 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13569 super_type
= gfc_get_derived_super_type (derived
);
13571 resolve_symbol (super_type
);
13573 resolve_bindings_derived
= derived
;
13574 resolve_bindings_result
= true;
13576 if (derived
->f2k_derived
->tb_sym_root
)
13577 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13578 &resolve_typebound_procedure
);
13580 if (derived
->f2k_derived
->tb_uop_root
)
13581 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13582 &resolve_typebound_user_op
);
13584 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13586 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13587 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13588 (gfc_intrinsic_op
)op
, p
))
13589 resolve_bindings_result
= false;
13592 return resolve_bindings_result
;
13596 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13597 to give all identical derived types the same backend_decl. */
13599 add_dt_to_dt_list (gfc_symbol
*derived
)
13601 if (!derived
->dt_next
)
13603 if (gfc_derived_types
)
13605 derived
->dt_next
= gfc_derived_types
->dt_next
;
13606 gfc_derived_types
->dt_next
= derived
;
13610 derived
->dt_next
= derived
;
13612 gfc_derived_types
= derived
;
13617 /* Ensure that a derived-type is really not abstract, meaning that every
13618 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13621 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13626 if (!ensure_not_abstract_walker (sub
, st
->left
))
13628 if (!ensure_not_abstract_walker (sub
, st
->right
))
13631 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13633 gfc_symtree
* overriding
;
13634 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13637 gcc_assert (overriding
->n
.tb
);
13638 if (overriding
->n
.tb
->deferred
)
13640 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13641 " %qs is DEFERRED and not overridden",
13642 sub
->name
, &sub
->declared_at
, st
->name
);
13651 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13653 /* The algorithm used here is to recursively travel up the ancestry of sub
13654 and for each ancestor-type, check all bindings. If any of them is
13655 DEFERRED, look it up starting from sub and see if the found (overriding)
13656 binding is not DEFERRED.
13657 This is not the most efficient way to do this, but it should be ok and is
13658 clearer than something sophisticated. */
13660 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13662 if (!ancestor
->attr
.abstract
)
13665 /* Walk bindings of this ancestor. */
13666 if (ancestor
->f2k_derived
)
13669 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13674 /* Find next ancestor type and recurse on it. */
13675 ancestor
= gfc_get_derived_super_type (ancestor
);
13677 return ensure_not_abstract (sub
, ancestor
);
13683 /* This check for typebound defined assignments is done recursively
13684 since the order in which derived types are resolved is not always in
13685 order of the declarations. */
13688 check_defined_assignments (gfc_symbol
*derived
)
13692 for (c
= derived
->components
; c
; c
= c
->next
)
13694 if (!gfc_bt_struct (c
->ts
.type
)
13696 || c
->attr
.allocatable
13697 || c
->attr
.proc_pointer_comp
13698 || c
->attr
.class_pointer
13699 || c
->attr
.proc_pointer
)
13702 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13703 || (c
->ts
.u
.derived
->f2k_derived
13704 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13706 derived
->attr
.defined_assign_comp
= 1;
13710 check_defined_assignments (c
->ts
.u
.derived
);
13711 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13713 derived
->attr
.defined_assign_comp
= 1;
13720 /* Resolve a single component of a derived type or structure. */
13723 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13725 gfc_symbol
*super_type
;
13727 if (c
->attr
.artificial
)
13730 /* Do not allow vtype components to be resolved in nameless namespaces
13731 such as block data because the procedure pointers will cause ICEs
13732 and vtables are not needed in these contexts. */
13733 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13734 && sym
->ns
->proc_name
== NULL
)
13738 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13739 && c
->attr
.codimension
13740 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13742 gfc_error ("Coarray component %qs at %L must be allocatable with "
13743 "deferred shape", c
->name
, &c
->loc
);
13748 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13749 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13751 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13752 "shall not be a coarray", c
->name
, &c
->loc
);
13757 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13758 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13759 || c
->attr
.allocatable
))
13761 gfc_error ("Component %qs at %L with coarray component "
13762 "shall be a nonpointer, nonallocatable scalar",
13768 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13770 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13771 "is not an array pointer", c
->name
, &c
->loc
);
13775 /* F2003, 15.2.1 - length has to be one. */
13776 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13777 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
13778 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
13779 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
13781 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13786 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13788 gfc_symbol
*ifc
= c
->ts
.interface
;
13790 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13796 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13798 /* Resolve interface and copy attributes. */
13799 if (ifc
->formal
&& !ifc
->formal_ns
)
13800 resolve_symbol (ifc
);
13801 if (ifc
->attr
.intrinsic
)
13802 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13806 c
->ts
= ifc
->result
->ts
;
13807 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13808 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13809 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13810 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13811 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13816 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13817 c
->attr
.pointer
= ifc
->attr
.pointer
;
13818 c
->attr
.dimension
= ifc
->attr
.dimension
;
13819 c
->as
= gfc_copy_array_spec (ifc
->as
);
13820 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13822 c
->ts
.interface
= ifc
;
13823 c
->attr
.function
= ifc
->attr
.function
;
13824 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13826 c
->attr
.pure
= ifc
->attr
.pure
;
13827 c
->attr
.elemental
= ifc
->attr
.elemental
;
13828 c
->attr
.recursive
= ifc
->attr
.recursive
;
13829 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13830 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13831 /* Copy char length. */
13832 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13834 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13835 if (cl
->length
&& !cl
->resolved
13836 && !gfc_resolve_expr (cl
->length
))
13845 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13847 /* Since PPCs are not implicitly typed, a PPC without an explicit
13848 interface must be a subroutine. */
13849 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13852 /* Procedure pointer components: Check PASS arg. */
13853 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13854 && !sym
->attr
.vtype
)
13856 gfc_symbol
* me_arg
;
13858 if (c
->tb
->pass_arg
)
13860 gfc_formal_arglist
* i
;
13862 /* If an explicit passing argument name is given, walk the arg-list
13863 and look for it. */
13866 c
->tb
->pass_arg_num
= 1;
13867 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13869 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13874 c
->tb
->pass_arg_num
++;
13879 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13880 "at %L has no argument %qs", c
->name
,
13881 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13888 /* Otherwise, take the first one; there should in fact be at least
13890 c
->tb
->pass_arg_num
= 1;
13891 if (!c
->ts
.interface
->formal
)
13893 gfc_error ("Procedure pointer component %qs with PASS at %L "
13894 "must have at least one argument",
13899 me_arg
= c
->ts
.interface
->formal
->sym
;
13902 /* Now check that the argument-type matches. */
13903 gcc_assert (me_arg
);
13904 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13905 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13906 || (me_arg
->ts
.type
== BT_CLASS
13907 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13909 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13910 " the derived type %qs", me_arg
->name
, c
->name
,
13911 me_arg
->name
, &c
->loc
, sym
->name
);
13916 /* Check for F03:C453. */
13917 if (CLASS_DATA (me_arg
)->attr
.dimension
)
13919 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13920 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13926 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13928 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13929 "may not have the POINTER attribute", me_arg
->name
,
13930 c
->name
, me_arg
->name
, &c
->loc
);
13935 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13937 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13938 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13939 me_arg
->name
, &c
->loc
);
13944 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13946 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13947 " at %L", c
->name
, &c
->loc
);
13953 /* Check type-spec if this is not the parent-type component. */
13954 if (((sym
->attr
.is_class
13955 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13956 || c
!= sym
->components
->ts
.u
.derived
->components
))
13957 || (!sym
->attr
.is_class
13958 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13959 && !sym
->attr
.vtype
13960 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13963 super_type
= gfc_get_derived_super_type (sym
);
13965 /* If this type is an extension, set the accessibility of the parent
13968 && ((sym
->attr
.is_class
13969 && c
== sym
->components
->ts
.u
.derived
->components
)
13970 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13971 && strcmp (super_type
->name
, c
->name
) == 0)
13972 c
->attr
.access
= super_type
->attr
.access
;
13974 /* If this type is an extension, see if this component has the same name
13975 as an inherited type-bound procedure. */
13976 if (super_type
&& !sym
->attr
.is_class
13977 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13979 gfc_error ("Component %qs of %qs at %L has the same name as an"
13980 " inherited type-bound procedure",
13981 c
->name
, sym
->name
, &c
->loc
);
13985 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13986 && !c
->ts
.deferred
)
13988 if (c
->ts
.u
.cl
->length
== NULL
13989 || (!resolve_charlen(c
->ts
.u
.cl
))
13990 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13992 gfc_error ("Character length of component %qs needs to "
13993 "be a constant specification expression at %L",
13995 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14000 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14001 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14003 gfc_error ("Character component %qs of %qs at %L with deferred "
14004 "length must be a POINTER or ALLOCATABLE",
14005 c
->name
, sym
->name
, &c
->loc
);
14009 /* Add the hidden deferred length field. */
14010 if (c
->ts
.type
== BT_CHARACTER
14011 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14012 && !c
->attr
.function
14013 && !sym
->attr
.is_class
)
14015 char name
[GFC_MAX_SYMBOL_LEN
+9];
14016 gfc_component
*strlen
;
14017 sprintf (name
, "_%s_length", c
->name
);
14018 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14019 if (strlen
== NULL
)
14021 if (!gfc_add_component (sym
, name
, &strlen
))
14023 strlen
->ts
.type
= BT_INTEGER
;
14024 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14025 strlen
->attr
.access
= ACCESS_PRIVATE
;
14026 strlen
->attr
.artificial
= 1;
14030 if (c
->ts
.type
== BT_DERIVED
14031 && sym
->component_access
!= ACCESS_PRIVATE
14032 && gfc_check_symbol_access (sym
)
14033 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14034 && !c
->ts
.u
.derived
->attr
.use_assoc
14035 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14036 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14037 "PRIVATE type and cannot be a component of "
14038 "%qs, which is PUBLIC at %L", c
->name
,
14039 sym
->name
, &sym
->declared_at
))
14042 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14044 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14045 "type %s", c
->name
, &c
->loc
, sym
->name
);
14049 if (sym
->attr
.sequence
)
14051 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14053 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14054 "not have the SEQUENCE attribute",
14055 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14060 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14061 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14062 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14063 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14064 CLASS_DATA (c
)->ts
.u
.derived
14065 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14067 /* If an allocatable component derived type is of the same type as
14068 the enclosing derived type, we need a vtable generating so that
14069 the __deallocate procedure is created. */
14070 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14071 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14072 gfc_find_vtab (&c
->ts
);
14074 /* Ensure that all the derived type components are put on the
14075 derived type list; even in formal namespaces, where derived type
14076 pointer components might not have been declared. */
14077 if (c
->ts
.type
== BT_DERIVED
14079 && c
->ts
.u
.derived
->components
14081 && sym
!= c
->ts
.u
.derived
)
14082 add_dt_to_dt_list (c
->ts
.u
.derived
);
14084 if (!gfc_resolve_array_spec (c
->as
,
14085 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14086 || c
->attr
.allocatable
)))
14089 if (c
->initializer
&& !sym
->attr
.vtype
14090 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14091 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14098 /* Be nice about the locus for a structure expression - show the locus of the
14099 first non-null sub-expression if we can. */
14102 cons_where (gfc_expr
*struct_expr
)
14104 gfc_constructor
*cons
;
14106 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14108 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14109 for (; cons
; cons
= gfc_constructor_next (cons
))
14111 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14112 return &cons
->expr
->where
;
14115 return &struct_expr
->where
;
14118 /* Resolve the components of a structure type. Much less work than derived
14122 resolve_fl_struct (gfc_symbol
*sym
)
14125 gfc_expr
*init
= NULL
;
14128 /* Make sure UNIONs do not have overlapping initializers. */
14129 if (sym
->attr
.flavor
== FL_UNION
)
14131 for (c
= sym
->components
; c
; c
= c
->next
)
14133 if (init
&& c
->initializer
)
14135 gfc_error ("Conflicting initializers in union at %L and %L",
14136 cons_where (init
), cons_where (c
->initializer
));
14137 gfc_free_expr (c
->initializer
);
14138 c
->initializer
= NULL
;
14141 init
= c
->initializer
;
14146 for (c
= sym
->components
; c
; c
= c
->next
)
14147 if (!resolve_component (c
, sym
))
14153 if (sym
->components
)
14154 add_dt_to_dt_list (sym
);
14160 /* Resolve the components of a derived type. This does not have to wait until
14161 resolution stage, but can be done as soon as the dt declaration has been
14165 resolve_fl_derived0 (gfc_symbol
*sym
)
14167 gfc_symbol
* super_type
;
14169 gfc_formal_arglist
*f
;
14172 if (sym
->attr
.unlimited_polymorphic
)
14175 super_type
= gfc_get_derived_super_type (sym
);
14178 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14180 gfc_error ("As extending type %qs at %L has a coarray component, "
14181 "parent type %qs shall also have one", sym
->name
,
14182 &sym
->declared_at
, super_type
->name
);
14186 /* Ensure the extended type gets resolved before we do. */
14187 if (super_type
&& !resolve_fl_derived0 (super_type
))
14190 /* An ABSTRACT type must be extensible. */
14191 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14193 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14194 sym
->name
, &sym
->declared_at
);
14198 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14202 for ( ; c
!= NULL
; c
= c
->next
)
14203 if (!resolve_component (c
, sym
))
14209 /* Now add the caf token field, where needed. */
14210 if (flag_coarray
!= GFC_FCOARRAY_NONE
14211 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14213 for (c
= sym
->components
; c
; c
= c
->next
)
14214 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14215 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14217 char name
[GFC_MAX_SYMBOL_LEN
+9];
14218 gfc_component
*token
;
14219 sprintf (name
, "_caf_%s", c
->name
);
14220 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14223 if (!gfc_add_component (sym
, name
, &token
))
14225 token
->ts
.type
= BT_VOID
;
14226 token
->ts
.kind
= gfc_default_integer_kind
;
14227 token
->attr
.access
= ACCESS_PRIVATE
;
14228 token
->attr
.artificial
= 1;
14229 token
->attr
.caf_token
= 1;
14234 check_defined_assignments (sym
);
14236 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14237 sym
->attr
.defined_assign_comp
14238 = super_type
->attr
.defined_assign_comp
;
14240 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14241 all DEFERRED bindings are overridden. */
14242 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14243 && !sym
->attr
.is_class
14244 && !ensure_not_abstract (sym
, super_type
))
14247 /* Check that there is a component for every PDT parameter. */
14248 if (sym
->attr
.pdt_template
)
14250 for (f
= sym
->formal
; f
; f
= f
->next
)
14254 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14257 gfc_error ("Parameterized type %qs does not have a component "
14258 "corresponding to parameter %qs at %L", sym
->name
,
14259 f
->sym
->name
, &sym
->declared_at
);
14265 /* Add derived type to the derived type list. */
14266 add_dt_to_dt_list (sym
);
14272 /* The following procedure does the full resolution of a derived type,
14273 including resolution of all type-bound procedures (if present). In contrast
14274 to 'resolve_fl_derived0' this can only be done after the module has been
14275 parsed completely. */
14278 resolve_fl_derived (gfc_symbol
*sym
)
14280 gfc_symbol
*gen_dt
= NULL
;
14282 if (sym
->attr
.unlimited_polymorphic
)
14285 if (!sym
->attr
.is_class
)
14286 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14287 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14288 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14289 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14290 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14291 "%qs at %L being the same name as derived "
14292 "type at %L", sym
->name
,
14293 gen_dt
->generic
->sym
== sym
14294 ? gen_dt
->generic
->next
->sym
->name
14295 : gen_dt
->generic
->sym
->name
,
14296 gen_dt
->generic
->sym
== sym
14297 ? &gen_dt
->generic
->next
->sym
->declared_at
14298 : &gen_dt
->generic
->sym
->declared_at
,
14299 &sym
->declared_at
))
14302 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14304 gfc_error ("Derived type %qs at %L has not been declared",
14305 sym
->name
, &sym
->declared_at
);
14309 /* Resolve the finalizer procedures. */
14310 if (!gfc_resolve_finalizers (sym
, NULL
))
14313 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14315 /* Fix up incomplete CLASS symbols. */
14316 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14317 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14319 /* Nothing more to do for unlimited polymorphic entities. */
14320 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14322 else if (vptr
->ts
.u
.derived
== NULL
)
14324 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14326 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14327 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14332 if (!resolve_fl_derived0 (sym
))
14335 /* Resolve the type-bound procedures. */
14336 if (!resolve_typebound_procedures (sym
))
14339 /* Generate module vtables subject to their accessibility and their not
14340 being vtables or pdt templates. If this is not done class declarations
14341 in external procedures wind up with their own version and so SELECT TYPE
14342 fails because the vptrs do not have the same address. */
14343 if (gfc_option
.allow_std
& GFC_STD_F2003
14344 && sym
->ns
->proc_name
14345 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14346 && sym
->attr
.access
!= ACCESS_PRIVATE
14347 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14349 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14350 gfc_set_sym_referenced (vtab
);
14358 resolve_fl_namelist (gfc_symbol
*sym
)
14363 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14365 /* Check again, the check in match only works if NAMELIST comes
14367 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14369 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14370 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14374 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14375 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14376 "with assumed shape in namelist %qs at %L",
14377 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14380 if (is_non_constant_shape_array (nl
->sym
)
14381 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14382 "with nonconstant shape in namelist %qs at %L",
14383 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14386 if (nl
->sym
->ts
.type
== BT_CHARACTER
14387 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14388 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14389 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14390 "nonconstant character length in "
14391 "namelist %qs at %L", nl
->sym
->name
,
14392 sym
->name
, &sym
->declared_at
))
14397 /* Reject PRIVATE objects in a PUBLIC namelist. */
14398 if (gfc_check_symbol_access (sym
))
14400 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14402 if (!nl
->sym
->attr
.use_assoc
14403 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14404 && !gfc_check_symbol_access (nl
->sym
))
14406 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14407 "cannot be member of PUBLIC namelist %qs at %L",
14408 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14412 if (nl
->sym
->ts
.type
== BT_DERIVED
14413 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14414 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14416 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14417 "namelist %qs at %L with ALLOCATABLE "
14418 "or POINTER components", nl
->sym
->name
,
14419 sym
->name
, &sym
->declared_at
))
14424 /* Types with private components that came here by USE-association. */
14425 if (nl
->sym
->ts
.type
== BT_DERIVED
14426 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14428 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14429 "components and cannot be member of namelist %qs at %L",
14430 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14434 /* Types with private components that are defined in the same module. */
14435 if (nl
->sym
->ts
.type
== BT_DERIVED
14436 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14437 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14439 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14440 "cannot be a member of PUBLIC namelist %qs at %L",
14441 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14448 /* 14.1.2 A module or internal procedure represent local entities
14449 of the same type as a namelist member and so are not allowed. */
14450 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14452 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14455 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14456 if ((nl
->sym
== sym
->ns
->proc_name
)
14458 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14463 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14464 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14466 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14467 "attribute in %qs at %L", nlsym
->name
,
14468 &sym
->declared_at
);
14475 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14476 nl
->sym
->attr
.asynchronous
= 1;
14483 resolve_fl_parameter (gfc_symbol
*sym
)
14485 /* A parameter array's shape needs to be constant. */
14486 if (sym
->as
!= NULL
14487 && (sym
->as
->type
== AS_DEFERRED
14488 || is_non_constant_shape_array (sym
)))
14490 gfc_error ("Parameter array %qs at %L cannot be automatic "
14491 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14495 /* Constraints on deferred type parameter. */
14496 if (!deferred_requirements (sym
))
14499 /* Make sure a parameter that has been implicitly typed still
14500 matches the implicit type, since PARAMETER statements can precede
14501 IMPLICIT statements. */
14502 if (sym
->attr
.implicit_type
14503 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14506 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14507 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14511 /* Make sure the types of derived parameters are consistent. This
14512 type checking is deferred until resolution because the type may
14513 refer to a derived type from the host. */
14514 if (sym
->ts
.type
== BT_DERIVED
14515 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14517 gfc_error ("Incompatible derived type in PARAMETER at %L",
14518 &sym
->value
->where
);
14522 /* F03:C509,C514. */
14523 if (sym
->ts
.type
== BT_CLASS
)
14525 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14526 sym
->name
, &sym
->declared_at
);
14534 /* Called by resolve_symbol to check PDTs. */
14537 resolve_pdt (gfc_symbol
* sym
)
14539 gfc_symbol
*derived
= NULL
;
14540 gfc_actual_arglist
*param
;
14542 bool const_len_exprs
= true;
14543 bool assumed_len_exprs
= false;
14544 symbol_attribute
*attr
;
14546 if (sym
->ts
.type
== BT_DERIVED
)
14548 derived
= sym
->ts
.u
.derived
;
14549 attr
= &(sym
->attr
);
14551 else if (sym
->ts
.type
== BT_CLASS
)
14553 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14554 attr
= &(CLASS_DATA (sym
)->attr
);
14557 gcc_unreachable ();
14559 gcc_assert (derived
->attr
.pdt_type
);
14561 for (param
= sym
->param_list
; param
; param
= param
->next
)
14563 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14565 if (c
->attr
.pdt_kind
)
14568 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14569 && c
->attr
.pdt_len
)
14570 const_len_exprs
= false;
14571 else if (param
->spec_type
== SPEC_ASSUMED
)
14572 assumed_len_exprs
= true;
14574 if (param
->spec_type
== SPEC_DEFERRED
14575 && !attr
->allocatable
&& !attr
->pointer
)
14576 gfc_error ("The object %qs at %L has a deferred LEN "
14577 "parameter %qs and is neither allocatable "
14578 "nor a pointer", sym
->name
, &sym
->declared_at
,
14583 if (!const_len_exprs
14584 && (sym
->ns
->proc_name
->attr
.is_main_program
14585 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14586 || sym
->attr
.save
!= SAVE_NONE
))
14587 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14588 "SAVE attribute or be a variable declared in the "
14589 "main program, a module or a submodule(F08/C513)",
14590 sym
->name
, &sym
->declared_at
);
14592 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14593 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14594 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14595 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14596 sym
->name
, &sym
->declared_at
);
14600 /* Do anything necessary to resolve a symbol. Right now, we just
14601 assume that an otherwise unknown symbol is a variable. This sort
14602 of thing commonly happens for symbols in module. */
14605 resolve_symbol (gfc_symbol
*sym
)
14607 int check_constant
, mp_flag
;
14608 gfc_symtree
*symtree
;
14609 gfc_symtree
*this_symtree
;
14612 symbol_attribute class_attr
;
14613 gfc_array_spec
*as
;
14614 bool saved_specification_expr
;
14620 /* No symbol will ever have union type; only components can be unions.
14621 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14622 (just like derived type declaration symbols have flavor FL_DERIVED). */
14623 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14625 /* Coarrayed polymorphic objects with allocatable or pointer components are
14626 yet unsupported for -fcoarray=lib. */
14627 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14628 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14629 && CLASS_DATA (sym
)->attr
.codimension
14630 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14631 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14633 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14634 "type coarrays at %L are unsupported", &sym
->declared_at
);
14638 if (sym
->attr
.artificial
)
14641 if (sym
->attr
.unlimited_polymorphic
)
14644 if (sym
->attr
.flavor
== FL_UNKNOWN
14645 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14646 && !sym
->attr
.generic
&& !sym
->attr
.external
14647 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14648 && sym
->ts
.type
== BT_UNKNOWN
))
14651 /* If we find that a flavorless symbol is an interface in one of the
14652 parent namespaces, find its symtree in this namespace, free the
14653 symbol and set the symtree to point to the interface symbol. */
14654 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14656 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14657 if (symtree
&& (symtree
->n
.sym
->generic
||
14658 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14659 && sym
->ns
->construct_entities
)))
14661 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14663 if (this_symtree
->n
.sym
== sym
)
14665 symtree
->n
.sym
->refs
++;
14666 gfc_release_symbol (sym
);
14667 this_symtree
->n
.sym
= symtree
->n
.sym
;
14673 /* Otherwise give it a flavor according to such attributes as
14675 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14676 && sym
->attr
.intrinsic
== 0)
14677 sym
->attr
.flavor
= FL_VARIABLE
;
14678 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14680 sym
->attr
.flavor
= FL_PROCEDURE
;
14681 if (sym
->attr
.dimension
)
14682 sym
->attr
.function
= 1;
14686 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14687 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14689 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14690 && !resolve_procedure_interface (sym
))
14693 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14694 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14696 if (sym
->attr
.external
)
14697 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14698 "at %L", &sym
->declared_at
);
14700 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14701 "at %L", &sym
->declared_at
);
14706 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14709 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14710 && !resolve_fl_struct (sym
))
14713 /* Symbols that are module procedures with results (functions) have
14714 the types and array specification copied for type checking in
14715 procedures that call them, as well as for saving to a module
14716 file. These symbols can't stand the scrutiny that their results
14718 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14720 /* Make sure that the intrinsic is consistent with its internal
14721 representation. This needs to be done before assigning a default
14722 type to avoid spurious warnings. */
14723 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14724 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14727 /* Resolve associate names. */
14729 resolve_assoc_var (sym
, true);
14731 /* Assign default type to symbols that need one and don't have one. */
14732 if (sym
->ts
.type
== BT_UNKNOWN
)
14734 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14736 gfc_set_default_type (sym
, 1, NULL
);
14739 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14740 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14741 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14742 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14744 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14746 /* The specific case of an external procedure should emit an error
14747 in the case that there is no implicit type. */
14750 if (!sym
->attr
.mixed_entry_master
)
14751 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14755 /* Result may be in another namespace. */
14756 resolve_symbol (sym
->result
);
14758 if (!sym
->result
->attr
.proc_pointer
)
14760 sym
->ts
= sym
->result
->ts
;
14761 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14762 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14763 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14764 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14765 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14770 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14772 bool saved_specification_expr
= specification_expr
;
14773 specification_expr
= true;
14774 gfc_resolve_array_spec (sym
->result
->as
, false);
14775 specification_expr
= saved_specification_expr
;
14778 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14780 as
= CLASS_DATA (sym
)->as
;
14781 class_attr
= CLASS_DATA (sym
)->attr
;
14782 class_attr
.pointer
= class_attr
.class_pointer
;
14786 class_attr
= sym
->attr
;
14791 if (sym
->attr
.contiguous
14792 && (!class_attr
.dimension
14793 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14794 && !class_attr
.pointer
)))
14796 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14797 "array pointer or an assumed-shape or assumed-rank array",
14798 sym
->name
, &sym
->declared_at
);
14802 /* Assumed size arrays and assumed shape arrays must be dummy
14803 arguments. Array-spec's of implied-shape should have been resolved to
14804 AS_EXPLICIT already. */
14808 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14809 specification expression. */
14810 if (as
->type
== AS_IMPLIED_SHAPE
)
14813 for (i
=0; i
<as
->rank
; i
++)
14815 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
14817 gfc_error ("Bad specification for assumed size array at %L",
14818 &as
->lower
[i
]->where
);
14825 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14826 || as
->type
== AS_ASSUMED_SHAPE
)
14827 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14829 if (as
->type
== AS_ASSUMED_SIZE
)
14830 gfc_error ("Assumed size array at %L must be a dummy argument",
14831 &sym
->declared_at
);
14833 gfc_error ("Assumed shape array at %L must be a dummy argument",
14834 &sym
->declared_at
);
14837 /* TS 29113, C535a. */
14838 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14839 && !sym
->attr
.select_type_temporary
)
14841 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14842 &sym
->declared_at
);
14845 if (as
->type
== AS_ASSUMED_RANK
14846 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14848 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14849 "CODIMENSION attribute", &sym
->declared_at
);
14854 /* Make sure symbols with known intent or optional are really dummy
14855 variable. Because of ENTRY statement, this has to be deferred
14856 until resolution time. */
14858 if (!sym
->attr
.dummy
14859 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14861 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14865 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14867 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14868 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14872 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14874 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14875 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14877 gfc_error ("Character dummy variable %qs at %L with VALUE "
14878 "attribute must have constant length",
14879 sym
->name
, &sym
->declared_at
);
14883 if (sym
->ts
.is_c_interop
14884 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14886 gfc_error ("C interoperable character dummy variable %qs at %L "
14887 "with VALUE attribute must have length one",
14888 sym
->name
, &sym
->declared_at
);
14893 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14894 && sym
->ts
.u
.derived
->attr
.generic
)
14896 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14897 if (!sym
->ts
.u
.derived
)
14899 gfc_error ("The derived type %qs at %L is of type %qs, "
14900 "which has not been defined", sym
->name
,
14901 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14902 sym
->ts
.type
= BT_UNKNOWN
;
14907 /* Use the same constraints as TYPE(*), except for the type check
14908 and that only scalars and assumed-size arrays are permitted. */
14909 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14911 if (!sym
->attr
.dummy
)
14913 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14914 "a dummy argument", sym
->name
, &sym
->declared_at
);
14918 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14919 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14920 && sym
->ts
.type
!= BT_COMPLEX
)
14922 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14923 "of type TYPE(*) or of an numeric intrinsic type",
14924 sym
->name
, &sym
->declared_at
);
14928 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14929 || sym
->attr
.pointer
|| sym
->attr
.value
)
14931 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14932 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14933 "attribute", sym
->name
, &sym
->declared_at
);
14937 if (sym
->attr
.intent
== INTENT_OUT
)
14939 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14940 "have the INTENT(OUT) attribute",
14941 sym
->name
, &sym
->declared_at
);
14944 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14946 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14947 "either be a scalar or an assumed-size array",
14948 sym
->name
, &sym
->declared_at
);
14952 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14953 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14955 sym
->ts
.type
= BT_ASSUMED
;
14956 sym
->as
= gfc_get_array_spec ();
14957 sym
->as
->type
= AS_ASSUMED_SIZE
;
14959 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14961 else if (sym
->ts
.type
== BT_ASSUMED
)
14963 /* TS 29113, C407a. */
14964 if (!sym
->attr
.dummy
)
14966 gfc_error ("Assumed type of variable %s at %L is only permitted "
14967 "for dummy variables", sym
->name
, &sym
->declared_at
);
14970 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14971 || sym
->attr
.pointer
|| sym
->attr
.value
)
14973 gfc_error ("Assumed-type variable %s at %L may not have the "
14974 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14975 sym
->name
, &sym
->declared_at
);
14978 if (sym
->attr
.intent
== INTENT_OUT
)
14980 gfc_error ("Assumed-type variable %s at %L may not have the "
14981 "INTENT(OUT) attribute",
14982 sym
->name
, &sym
->declared_at
);
14985 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14987 gfc_error ("Assumed-type variable %s at %L shall not be an "
14988 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14993 /* If the symbol is marked as bind(c), that it is declared at module level
14994 scope and verify its type and kind. Do not do the latter for symbols
14995 that are implicitly typed because that is handled in
14996 gfc_set_default_type. Handle dummy arguments and procedure definitions
14997 separately. Also, anything that is use associated is not handled here
14998 but instead is handled in the module it is declared in. Finally, derived
14999 type definitions are allowed to be BIND(C) since that only implies that
15000 they're interoperable, and they are checked fully for interoperability
15001 when a variable is declared of that type. */
15002 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15003 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15004 && sym
->attr
.flavor
!= FL_DERIVED
)
15008 /* First, make sure the variable is declared at the
15009 module-level scope (J3/04-007, Section 15.3). */
15010 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15011 sym
->attr
.in_common
== 0)
15013 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15014 "is neither a COMMON block nor declared at the "
15015 "module level scope", sym
->name
, &(sym
->declared_at
));
15018 else if (sym
->ts
.type
== BT_CHARACTER
15019 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15020 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15021 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15023 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15024 sym
->name
, &sym
->declared_at
);
15027 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15029 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15031 else if (sym
->attr
.implicit_type
== 0)
15033 /* If type() declaration, we need to verify that the components
15034 of the given type are all C interoperable, etc. */
15035 if (sym
->ts
.type
== BT_DERIVED
&&
15036 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15038 /* Make sure the user marked the derived type as BIND(C). If
15039 not, call the verify routine. This could print an error
15040 for the derived type more than once if multiple variables
15041 of that type are declared. */
15042 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15043 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15047 /* Verify the variable itself as C interoperable if it
15048 is BIND(C). It is not possible for this to succeed if
15049 the verify_bind_c_derived_type failed, so don't have to handle
15050 any error returned by verify_bind_c_derived_type. */
15051 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15052 sym
->common_block
);
15057 /* clear the is_bind_c flag to prevent reporting errors more than
15058 once if something failed. */
15059 sym
->attr
.is_bind_c
= 0;
15064 /* If a derived type symbol has reached this point, without its
15065 type being declared, we have an error. Notice that most
15066 conditions that produce undefined derived types have already
15067 been dealt with. However, the likes of:
15068 implicit type(t) (t) ..... call foo (t) will get us here if
15069 the type is not declared in the scope of the implicit
15070 statement. Change the type to BT_UNKNOWN, both because it is so
15071 and to prevent an ICE. */
15072 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15073 && sym
->ts
.u
.derived
->components
== NULL
15074 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15076 gfc_error ("The derived type %qs at %L is of type %qs, "
15077 "which has not been defined", sym
->name
,
15078 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15079 sym
->ts
.type
= BT_UNKNOWN
;
15083 /* Make sure that the derived type has been resolved and that the
15084 derived type is visible in the symbol's namespace, if it is a
15085 module function and is not PRIVATE. */
15086 if (sym
->ts
.type
== BT_DERIVED
15087 && sym
->ts
.u
.derived
->attr
.use_assoc
15088 && sym
->ns
->proc_name
15089 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15090 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15093 /* Unless the derived-type declaration is use associated, Fortran 95
15094 does not allow public entries of private derived types.
15095 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15096 161 in 95-006r3. */
15097 if (sym
->ts
.type
== BT_DERIVED
15098 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15099 && !sym
->ts
.u
.derived
->attr
.use_assoc
15100 && gfc_check_symbol_access (sym
)
15101 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15102 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15103 "derived type %qs",
15104 (sym
->attr
.flavor
== FL_PARAMETER
)
15105 ? "parameter" : "variable",
15106 sym
->name
, &sym
->declared_at
,
15107 sym
->ts
.u
.derived
->name
))
15110 /* F2008, C1302. */
15111 if (sym
->ts
.type
== BT_DERIVED
15112 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15113 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15114 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15115 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15117 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15118 "type LOCK_TYPE must be a coarray", sym
->name
,
15119 &sym
->declared_at
);
15123 /* TS18508, C702/C703. */
15124 if (sym
->ts
.type
== BT_DERIVED
15125 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15126 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15127 || sym
->ts
.u
.derived
->attr
.event_comp
)
15128 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15130 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15131 "type EVENT_TYPE must be a coarray", sym
->name
,
15132 &sym
->declared_at
);
15136 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15137 default initialization is defined (5.1.2.4.4). */
15138 if (sym
->ts
.type
== BT_DERIVED
15140 && sym
->attr
.intent
== INTENT_OUT
15142 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15144 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15146 if (c
->initializer
)
15148 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15149 "ASSUMED SIZE and so cannot have a default initializer",
15150 sym
->name
, &sym
->declared_at
);
15157 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15158 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15160 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15161 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15166 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15167 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15169 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15170 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15175 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15176 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15177 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15178 || class_attr
.codimension
)
15179 && (sym
->attr
.result
|| sym
->result
== sym
))
15181 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15182 "a coarray component", sym
->name
, &sym
->declared_at
);
15187 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15188 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15190 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15191 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15196 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15197 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15198 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15199 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15200 || class_attr
.allocatable
))
15202 gfc_error ("Variable %qs at %L with coarray component shall be a "
15203 "nonpointer, nonallocatable scalar, which is not a coarray",
15204 sym
->name
, &sym
->declared_at
);
15208 /* F2008, C526. The function-result case was handled above. */
15209 if (class_attr
.codimension
15210 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15211 || sym
->attr
.select_type_temporary
15212 || sym
->attr
.associate_var
15213 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15214 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15215 || sym
->ns
->proc_name
->attr
.is_main_program
15216 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15218 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15219 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15223 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15224 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15226 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15227 "deferred shape", sym
->name
, &sym
->declared_at
);
15230 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15231 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15233 gfc_error ("Allocatable coarray variable %qs at %L must have "
15234 "deferred shape", sym
->name
, &sym
->declared_at
);
15239 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15240 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15241 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15242 || (class_attr
.codimension
&& class_attr
.allocatable
))
15243 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15245 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15246 "allocatable coarray or have coarray components",
15247 sym
->name
, &sym
->declared_at
);
15251 if (class_attr
.codimension
&& sym
->attr
.dummy
15252 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15254 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15255 "procedure %qs", sym
->name
, &sym
->declared_at
,
15256 sym
->ns
->proc_name
->name
);
15260 if (sym
->ts
.type
== BT_LOGICAL
15261 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15262 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15263 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15266 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15267 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15269 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15270 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15271 "%L with non-C_Bool kind in BIND(C) procedure "
15272 "%qs", sym
->name
, &sym
->declared_at
,
15273 sym
->ns
->proc_name
->name
))
15275 else if (!gfc_logical_kinds
[i
].c_bool
15276 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15277 "%qs at %L with non-C_Bool kind in "
15278 "BIND(C) procedure %qs", sym
->name
,
15280 sym
->attr
.function
? sym
->name
15281 : sym
->ns
->proc_name
->name
))
15285 switch (sym
->attr
.flavor
)
15288 if (!resolve_fl_variable (sym
, mp_flag
))
15293 if (sym
->formal
&& !sym
->formal_ns
)
15295 /* Check that none of the arguments are a namelist. */
15296 gfc_formal_arglist
*formal
= sym
->formal
;
15298 for (; formal
; formal
= formal
->next
)
15299 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15301 gfc_error ("Namelist %qs can not be an argument to "
15302 "subroutine or function at %L",
15303 formal
->sym
->name
, &sym
->declared_at
);
15308 if (!resolve_fl_procedure (sym
, mp_flag
))
15313 if (!resolve_fl_namelist (sym
))
15318 if (!resolve_fl_parameter (sym
))
15326 /* Resolve array specifier. Check as well some constraints
15327 on COMMON blocks. */
15329 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15331 /* Set the formal_arg_flag so that check_conflict will not throw
15332 an error for host associated variables in the specification
15333 expression for an array_valued function. */
15334 if (sym
->attr
.function
&& sym
->as
)
15335 formal_arg_flag
= true;
15337 saved_specification_expr
= specification_expr
;
15338 specification_expr
= true;
15339 gfc_resolve_array_spec (sym
->as
, check_constant
);
15340 specification_expr
= saved_specification_expr
;
15342 formal_arg_flag
= false;
15344 /* Resolve formal namespaces. */
15345 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15346 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15347 gfc_resolve (sym
->formal_ns
);
15349 /* Make sure the formal namespace is present. */
15350 if (sym
->formal
&& !sym
->formal_ns
)
15352 gfc_formal_arglist
*formal
= sym
->formal
;
15353 while (formal
&& !formal
->sym
)
15354 formal
= formal
->next
;
15358 sym
->formal_ns
= formal
->sym
->ns
;
15359 if (sym
->ns
!= formal
->sym
->ns
)
15360 sym
->formal_ns
->refs
++;
15364 /* Check threadprivate restrictions. */
15365 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15366 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15367 && (!sym
->attr
.in_common
15368 && sym
->module
== NULL
15369 && (sym
->ns
->proc_name
== NULL
15370 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15371 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15373 /* Check omp declare target restrictions. */
15374 if (sym
->attr
.omp_declare_target
15375 && sym
->attr
.flavor
== FL_VARIABLE
15377 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15378 && (!sym
->attr
.in_common
15379 && sym
->module
== NULL
15380 && (sym
->ns
->proc_name
== NULL
15381 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15382 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15383 sym
->name
, &sym
->declared_at
);
15385 /* If we have come this far we can apply default-initializers, as
15386 described in 14.7.5, to those variables that have not already
15387 been assigned one. */
15388 if (sym
->ts
.type
== BT_DERIVED
15390 && !sym
->attr
.allocatable
15391 && !sym
->attr
.alloc_comp
)
15393 symbol_attribute
*a
= &sym
->attr
;
15395 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15396 && !a
->in_common
&& !a
->use_assoc
15398 && !((a
->function
|| a
->result
)
15400 || sym
->ts
.u
.derived
->attr
.alloc_comp
15401 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15402 && !(a
->function
&& sym
!= sym
->result
))
15403 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15404 apply_default_init (sym
);
15405 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15406 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15407 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15408 /* Mark the result symbol to be referenced, when it has allocatable
15410 sym
->result
->attr
.referenced
= 1;
15413 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15414 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15415 && !CLASS_DATA (sym
)->attr
.class_pointer
15416 && !CLASS_DATA (sym
)->attr
.allocatable
)
15417 apply_default_init (sym
);
15419 /* If this symbol has a type-spec, check it. */
15420 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15421 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15422 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15425 if (sym
->param_list
)
15430 /************* Resolve DATA statements *************/
15434 gfc_data_value
*vnode
;
15440 /* Advance the values structure to point to the next value in the data list. */
15443 next_data_value (void)
15445 while (mpz_cmp_ui (values
.left
, 0) == 0)
15448 if (values
.vnode
->next
== NULL
)
15451 values
.vnode
= values
.vnode
->next
;
15452 mpz_set (values
.left
, values
.vnode
->repeat
);
15460 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15466 ar_type mark
= AR_UNKNOWN
;
15468 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15474 if (!gfc_resolve_expr (var
->expr
))
15478 mpz_init_set_si (offset
, 0);
15481 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15482 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15483 e
= e
->value
.function
.actual
->expr
;
15485 if (e
->expr_type
!= EXPR_VARIABLE
)
15486 gfc_internal_error ("check_data_variable(): Bad expression");
15488 sym
= e
->symtree
->n
.sym
;
15490 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15492 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15493 sym
->name
, &sym
->declared_at
);
15496 if (e
->ref
== NULL
&& sym
->as
)
15498 gfc_error ("DATA array %qs at %L must be specified in a previous"
15499 " declaration", sym
->name
, where
);
15503 has_pointer
= sym
->attr
.pointer
;
15505 if (gfc_is_coindexed (e
))
15507 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15512 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15514 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15518 && ref
->type
== REF_ARRAY
15519 && ref
->u
.ar
.type
!= AR_FULL
)
15521 gfc_error ("DATA element %qs at %L is a pointer and so must "
15522 "be a full array", sym
->name
, where
);
15527 if (e
->rank
== 0 || has_pointer
)
15529 mpz_init_set_ui (size
, 1);
15536 /* Find the array section reference. */
15537 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15539 if (ref
->type
!= REF_ARRAY
)
15541 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15547 /* Set marks according to the reference pattern. */
15548 switch (ref
->u
.ar
.type
)
15556 /* Get the start position of array section. */
15557 gfc_get_section_index (ar
, section_index
, &offset
);
15562 gcc_unreachable ();
15565 if (!gfc_array_size (e
, &size
))
15567 gfc_error ("Nonconstant array section at %L in DATA statement",
15569 mpz_clear (offset
);
15576 while (mpz_cmp_ui (size
, 0) > 0)
15578 if (!next_data_value ())
15580 gfc_error ("DATA statement at %L has more variables than values",
15586 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15590 /* If we have more than one element left in the repeat count,
15591 and we have more than one element left in the target variable,
15592 then create a range assignment. */
15593 /* FIXME: Only done for full arrays for now, since array sections
15595 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15596 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15600 if (mpz_cmp (size
, values
.left
) >= 0)
15602 mpz_init_set (range
, values
.left
);
15603 mpz_sub (size
, size
, values
.left
);
15604 mpz_set_ui (values
.left
, 0);
15608 mpz_init_set (range
, size
);
15609 mpz_sub (values
.left
, values
.left
, size
);
15610 mpz_set_ui (size
, 0);
15613 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15616 mpz_add (offset
, offset
, range
);
15623 /* Assign initial value to symbol. */
15626 mpz_sub_ui (values
.left
, values
.left
, 1);
15627 mpz_sub_ui (size
, size
, 1);
15629 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15634 if (mark
== AR_FULL
)
15635 mpz_add_ui (offset
, offset
, 1);
15637 /* Modify the array section indexes and recalculate the offset
15638 for next element. */
15639 else if (mark
== AR_SECTION
)
15640 gfc_advance_section (section_index
, ar
, &offset
);
15644 if (mark
== AR_SECTION
)
15646 for (i
= 0; i
< ar
->dimen
; i
++)
15647 mpz_clear (section_index
[i
]);
15651 mpz_clear (offset
);
15657 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15659 /* Iterate over a list of elements in a DATA statement. */
15662 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15665 iterator_stack frame
;
15666 gfc_expr
*e
, *start
, *end
, *step
;
15667 bool retval
= true;
15669 mpz_init (frame
.value
);
15672 start
= gfc_copy_expr (var
->iter
.start
);
15673 end
= gfc_copy_expr (var
->iter
.end
);
15674 step
= gfc_copy_expr (var
->iter
.step
);
15676 if (!gfc_simplify_expr (start
, 1)
15677 || start
->expr_type
!= EXPR_CONSTANT
)
15679 gfc_error ("start of implied-do loop at %L could not be "
15680 "simplified to a constant value", &start
->where
);
15684 if (!gfc_simplify_expr (end
, 1)
15685 || end
->expr_type
!= EXPR_CONSTANT
)
15687 gfc_error ("end of implied-do loop at %L could not be "
15688 "simplified to a constant value", &start
->where
);
15692 if (!gfc_simplify_expr (step
, 1)
15693 || step
->expr_type
!= EXPR_CONSTANT
)
15695 gfc_error ("step of implied-do loop at %L could not be "
15696 "simplified to a constant value", &start
->where
);
15701 mpz_set (trip
, end
->value
.integer
);
15702 mpz_sub (trip
, trip
, start
->value
.integer
);
15703 mpz_add (trip
, trip
, step
->value
.integer
);
15705 mpz_div (trip
, trip
, step
->value
.integer
);
15707 mpz_set (frame
.value
, start
->value
.integer
);
15709 frame
.prev
= iter_stack
;
15710 frame
.variable
= var
->iter
.var
->symtree
;
15711 iter_stack
= &frame
;
15713 while (mpz_cmp_ui (trip
, 0) > 0)
15715 if (!traverse_data_var (var
->list
, where
))
15721 e
= gfc_copy_expr (var
->expr
);
15722 if (!gfc_simplify_expr (e
, 1))
15729 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15731 mpz_sub_ui (trip
, trip
, 1);
15735 mpz_clear (frame
.value
);
15738 gfc_free_expr (start
);
15739 gfc_free_expr (end
);
15740 gfc_free_expr (step
);
15742 iter_stack
= frame
.prev
;
15747 /* Type resolve variables in the variable list of a DATA statement. */
15750 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15754 for (; var
; var
= var
->next
)
15756 if (var
->expr
== NULL
)
15757 t
= traverse_data_list (var
, where
);
15759 t
= check_data_variable (var
, where
);
15769 /* Resolve the expressions and iterators associated with a data statement.
15770 This is separate from the assignment checking because data lists should
15771 only be resolved once. */
15774 resolve_data_variables (gfc_data_variable
*d
)
15776 for (; d
; d
= d
->next
)
15778 if (d
->list
== NULL
)
15780 if (!gfc_resolve_expr (d
->expr
))
15785 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15788 if (!resolve_data_variables (d
->list
))
15797 /* Resolve a single DATA statement. We implement this by storing a pointer to
15798 the value list into static variables, and then recursively traversing the
15799 variables list, expanding iterators and such. */
15802 resolve_data (gfc_data
*d
)
15805 if (!resolve_data_variables (d
->var
))
15808 values
.vnode
= d
->value
;
15809 if (d
->value
== NULL
)
15810 mpz_set_ui (values
.left
, 0);
15812 mpz_set (values
.left
, d
->value
->repeat
);
15814 if (!traverse_data_var (d
->var
, &d
->where
))
15817 /* At this point, we better not have any values left. */
15819 if (next_data_value ())
15820 gfc_error ("DATA statement at %L has more values than variables",
15825 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15826 accessed by host or use association, is a dummy argument to a pure function,
15827 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15828 is storage associated with any such variable, shall not be used in the
15829 following contexts: (clients of this function). */
15831 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15832 procedure. Returns zero if assignment is OK, nonzero if there is a
15835 gfc_impure_variable (gfc_symbol
*sym
)
15840 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15843 /* Check if the symbol's ns is inside the pure procedure. */
15844 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15848 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15852 proc
= sym
->ns
->proc_name
;
15853 if (sym
->attr
.dummy
15854 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15855 || proc
->attr
.function
))
15858 /* TODO: Sort out what can be storage associated, if anything, and include
15859 it here. In principle equivalences should be scanned but it does not
15860 seem to be possible to storage associate an impure variable this way. */
15865 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15866 current namespace is inside a pure procedure. */
15869 gfc_pure (gfc_symbol
*sym
)
15871 symbol_attribute attr
;
15876 /* Check if the current namespace or one of its parents
15877 belongs to a pure procedure. */
15878 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15880 sym
= ns
->proc_name
;
15884 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15892 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15896 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15897 checks if the current namespace is implicitly pure. Note that this
15898 function returns false for a PURE procedure. */
15901 gfc_implicit_pure (gfc_symbol
*sym
)
15907 /* Check if the current procedure is implicit_pure. Walk up
15908 the procedure list until we find a procedure. */
15909 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15911 sym
= ns
->proc_name
;
15915 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15920 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15921 && !sym
->attr
.pure
;
15926 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15932 /* Check if the current procedure is implicit_pure. Walk up
15933 the procedure list until we find a procedure. */
15934 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15936 sym
= ns
->proc_name
;
15940 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15945 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15946 sym
->attr
.implicit_pure
= 0;
15948 sym
->attr
.pure
= 0;
15952 /* Test whether the current procedure is elemental or not. */
15955 gfc_elemental (gfc_symbol
*sym
)
15957 symbol_attribute attr
;
15960 sym
= gfc_current_ns
->proc_name
;
15965 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15969 /* Warn about unused labels. */
15972 warn_unused_fortran_label (gfc_st_label
*label
)
15977 warn_unused_fortran_label (label
->left
);
15979 if (label
->defined
== ST_LABEL_UNKNOWN
)
15982 switch (label
->referenced
)
15984 case ST_LABEL_UNKNOWN
:
15985 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
15986 label
->value
, &label
->where
);
15989 case ST_LABEL_BAD_TARGET
:
15990 gfc_warning (OPT_Wunused_label
,
15991 "Label %d at %L defined but cannot be used",
15992 label
->value
, &label
->where
);
15999 warn_unused_fortran_label (label
->right
);
16003 /* Returns the sequence type of a symbol or sequence. */
16006 sequence_type (gfc_typespec ts
)
16015 if (ts
.u
.derived
->components
== NULL
)
16016 return SEQ_NONDEFAULT
;
16018 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16019 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16020 if (sequence_type (c
->ts
) != result
)
16026 if (ts
.kind
!= gfc_default_character_kind
)
16027 return SEQ_NONDEFAULT
;
16029 return SEQ_CHARACTER
;
16032 if (ts
.kind
!= gfc_default_integer_kind
)
16033 return SEQ_NONDEFAULT
;
16035 return SEQ_NUMERIC
;
16038 if (!(ts
.kind
== gfc_default_real_kind
16039 || ts
.kind
== gfc_default_double_kind
))
16040 return SEQ_NONDEFAULT
;
16042 return SEQ_NUMERIC
;
16045 if (ts
.kind
!= gfc_default_complex_kind
)
16046 return SEQ_NONDEFAULT
;
16048 return SEQ_NUMERIC
;
16051 if (ts
.kind
!= gfc_default_logical_kind
)
16052 return SEQ_NONDEFAULT
;
16054 return SEQ_NUMERIC
;
16057 return SEQ_NONDEFAULT
;
16062 /* Resolve derived type EQUIVALENCE object. */
16065 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16067 gfc_component
*c
= derived
->components
;
16072 /* Shall not be an object of nonsequence derived type. */
16073 if (!derived
->attr
.sequence
)
16075 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16076 "attribute to be an EQUIVALENCE object", sym
->name
,
16081 /* Shall not have allocatable components. */
16082 if (derived
->attr
.alloc_comp
)
16084 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16085 "components to be an EQUIVALENCE object",sym
->name
,
16090 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16092 gfc_error ("Derived type variable %qs at %L with default "
16093 "initialization cannot be in EQUIVALENCE with a variable "
16094 "in COMMON", sym
->name
, &e
->where
);
16098 for (; c
; c
= c
->next
)
16100 if (gfc_bt_struct (c
->ts
.type
)
16101 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16104 /* Shall not be an object of sequence derived type containing a pointer
16105 in the structure. */
16106 if (c
->attr
.pointer
)
16108 gfc_error ("Derived type variable %qs at %L with pointer "
16109 "component(s) cannot be an EQUIVALENCE object",
16110 sym
->name
, &e
->where
);
16118 /* Resolve equivalence object.
16119 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16120 an allocatable array, an object of nonsequence derived type, an object of
16121 sequence derived type containing a pointer at any level of component
16122 selection, an automatic object, a function name, an entry name, a result
16123 name, a named constant, a structure component, or a subobject of any of
16124 the preceding objects. A substring shall not have length zero. A
16125 derived type shall not have components with default initialization nor
16126 shall two objects of an equivalence group be initialized.
16127 Either all or none of the objects shall have an protected attribute.
16128 The simple constraints are done in symbol.c(check_conflict) and the rest
16129 are implemented here. */
16132 resolve_equivalence (gfc_equiv
*eq
)
16135 gfc_symbol
*first_sym
;
16138 locus
*last_where
= NULL
;
16139 seq_type eq_type
, last_eq_type
;
16140 gfc_typespec
*last_ts
;
16141 int object
, cnt_protected
;
16144 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16146 first_sym
= eq
->expr
->symtree
->n
.sym
;
16150 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16154 e
->ts
= e
->symtree
->n
.sym
->ts
;
16155 /* match_varspec might not know yet if it is seeing
16156 array reference or substring reference, as it doesn't
16158 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16160 gfc_ref
*ref
= e
->ref
;
16161 sym
= e
->symtree
->n
.sym
;
16163 if (sym
->attr
.dimension
)
16165 ref
->u
.ar
.as
= sym
->as
;
16169 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16170 if (e
->ts
.type
== BT_CHARACTER
16172 && ref
->type
== REF_ARRAY
16173 && ref
->u
.ar
.dimen
== 1
16174 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16175 && ref
->u
.ar
.stride
[0] == NULL
)
16177 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16178 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16181 /* Optimize away the (:) reference. */
16182 if (start
== NULL
&& end
== NULL
)
16185 e
->ref
= ref
->next
;
16187 e
->ref
->next
= ref
->next
;
16192 ref
->type
= REF_SUBSTRING
;
16194 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16196 ref
->u
.ss
.start
= start
;
16197 if (end
== NULL
&& e
->ts
.u
.cl
)
16198 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16199 ref
->u
.ss
.end
= end
;
16200 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16207 /* Any further ref is an error. */
16210 gcc_assert (ref
->type
== REF_ARRAY
);
16211 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16217 if (!gfc_resolve_expr (e
))
16220 sym
= e
->symtree
->n
.sym
;
16222 if (sym
->attr
.is_protected
)
16224 if (cnt_protected
> 0 && cnt_protected
!= object
)
16226 gfc_error ("Either all or none of the objects in the "
16227 "EQUIVALENCE set at %L shall have the "
16228 "PROTECTED attribute",
16233 /* Shall not equivalence common block variables in a PURE procedure. */
16234 if (sym
->ns
->proc_name
16235 && sym
->ns
->proc_name
->attr
.pure
16236 && sym
->attr
.in_common
)
16238 /* Need to check for symbols that may have entered the pure
16239 procedure via a USE statement. */
16240 bool saw_sym
= false;
16241 if (sym
->ns
->use_stmts
)
16244 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16245 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16251 gfc_error ("COMMON block member %qs at %L cannot be an "
16252 "EQUIVALENCE object in the pure procedure %qs",
16253 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16257 /* Shall not be a named constant. */
16258 if (e
->expr_type
== EXPR_CONSTANT
)
16260 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16261 "object", sym
->name
, &e
->where
);
16265 if (e
->ts
.type
== BT_DERIVED
16266 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16269 /* Check that the types correspond correctly:
16271 A numeric sequence structure may be equivalenced to another sequence
16272 structure, an object of default integer type, default real type, double
16273 precision real type, default logical type such that components of the
16274 structure ultimately only become associated to objects of the same
16275 kind. A character sequence structure may be equivalenced to an object
16276 of default character kind or another character sequence structure.
16277 Other objects may be equivalenced only to objects of the same type and
16278 kind parameters. */
16280 /* Identical types are unconditionally OK. */
16281 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16282 goto identical_types
;
16284 last_eq_type
= sequence_type (*last_ts
);
16285 eq_type
= sequence_type (sym
->ts
);
16287 /* Since the pair of objects is not of the same type, mixed or
16288 non-default sequences can be rejected. */
16290 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16291 "statement at %L with different type objects";
16293 && last_eq_type
== SEQ_MIXED
16294 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16295 || (eq_type
== SEQ_MIXED
16296 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16299 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16300 "statement at %L with objects of different type";
16302 && last_eq_type
== SEQ_NONDEFAULT
16303 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16304 || (eq_type
== SEQ_NONDEFAULT
16305 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16308 msg
="Non-CHARACTER object %qs in default CHARACTER "
16309 "EQUIVALENCE statement at %L";
16310 if (last_eq_type
== SEQ_CHARACTER
16311 && eq_type
!= SEQ_CHARACTER
16312 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16315 msg
="Non-NUMERIC object %qs in default NUMERIC "
16316 "EQUIVALENCE statement at %L";
16317 if (last_eq_type
== SEQ_NUMERIC
16318 && eq_type
!= SEQ_NUMERIC
16319 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16324 last_where
= &e
->where
;
16329 /* Shall not be an automatic array. */
16330 if (e
->ref
->type
== REF_ARRAY
16331 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16333 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16334 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16341 /* Shall not be a structure component. */
16342 if (r
->type
== REF_COMPONENT
)
16344 gfc_error ("Structure component %qs at %L cannot be an "
16345 "EQUIVALENCE object",
16346 r
->u
.c
.component
->name
, &e
->where
);
16350 /* A substring shall not have length zero. */
16351 if (r
->type
== REF_SUBSTRING
)
16353 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16355 gfc_error ("Substring at %L has length zero",
16356 &r
->u
.ss
.start
->where
);
16366 /* Function called by resolve_fntype to flag other symbol used in the
16367 length type parameter specification of function resuls. */
16370 flag_fn_result_spec (gfc_expr
*expr
,
16372 int *f ATTRIBUTE_UNUSED
)
16377 if (expr
->expr_type
== EXPR_VARIABLE
)
16379 s
= expr
->symtree
->n
.sym
;
16380 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16386 gfc_error ("Self reference in character length expression "
16387 "for %qs at %L", sym
->name
, &expr
->where
);
16391 if (!s
->fn_result_spec
16392 && s
->attr
.flavor
== FL_PARAMETER
)
16394 /* Function contained in a module.... */
16395 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16398 s
->fn_result_spec
= 1;
16399 /* Make sure that this symbol is translated as a module
16401 st
= gfc_get_unique_symtree (ns
);
16405 /* ... which is use associated and called. */
16406 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16408 /* External function matched with an interface. */
16411 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16412 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16413 && s
->ns
->proc_name
->attr
.function
))
16414 s
->fn_result_spec
= 1;
16421 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16424 resolve_fntype (gfc_namespace
*ns
)
16426 gfc_entry_list
*el
;
16429 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16432 /* If there are any entries, ns->proc_name is the entry master
16433 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16435 sym
= ns
->entries
->sym
;
16437 sym
= ns
->proc_name
;
16438 if (sym
->result
== sym
16439 && sym
->ts
.type
== BT_UNKNOWN
16440 && !gfc_set_default_type (sym
, 0, NULL
)
16441 && !sym
->attr
.untyped
)
16443 gfc_error ("Function %qs at %L has no IMPLICIT type",
16444 sym
->name
, &sym
->declared_at
);
16445 sym
->attr
.untyped
= 1;
16448 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16449 && !sym
->attr
.contained
16450 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16451 && gfc_check_symbol_access (sym
))
16453 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16454 "%L of PRIVATE type %qs", sym
->name
,
16455 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16459 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16461 if (el
->sym
->result
== el
->sym
16462 && el
->sym
->ts
.type
== BT_UNKNOWN
16463 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16464 && !el
->sym
->attr
.untyped
)
16466 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16467 el
->sym
->name
, &el
->sym
->declared_at
);
16468 el
->sym
->attr
.untyped
= 1;
16472 if (sym
->ts
.type
== BT_CHARACTER
)
16473 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16477 /* 12.3.2.1.1 Defined operators. */
16480 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16482 gfc_formal_arglist
*formal
;
16484 if (!sym
->attr
.function
)
16486 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16487 sym
->name
, &where
);
16491 if (sym
->ts
.type
== BT_CHARACTER
16492 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16493 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16494 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16496 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16497 "character length", sym
->name
, &where
);
16501 formal
= gfc_sym_get_dummy_args (sym
);
16502 if (!formal
|| !formal
->sym
)
16504 gfc_error ("User operator procedure %qs at %L must have at least "
16505 "one argument", sym
->name
, &where
);
16509 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16511 gfc_error ("First argument of operator interface at %L must be "
16512 "INTENT(IN)", &where
);
16516 if (formal
->sym
->attr
.optional
)
16518 gfc_error ("First argument of operator interface at %L cannot be "
16519 "optional", &where
);
16523 formal
= formal
->next
;
16524 if (!formal
|| !formal
->sym
)
16527 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16529 gfc_error ("Second argument of operator interface at %L must be "
16530 "INTENT(IN)", &where
);
16534 if (formal
->sym
->attr
.optional
)
16536 gfc_error ("Second argument of operator interface at %L cannot be "
16537 "optional", &where
);
16543 gfc_error ("Operator interface at %L must have, at most, two "
16544 "arguments", &where
);
16552 gfc_resolve_uops (gfc_symtree
*symtree
)
16554 gfc_interface
*itr
;
16556 if (symtree
== NULL
)
16559 gfc_resolve_uops (symtree
->left
);
16560 gfc_resolve_uops (symtree
->right
);
16562 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16563 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16567 /* Examine all of the expressions associated with a program unit,
16568 assign types to all intermediate expressions, make sure that all
16569 assignments are to compatible types and figure out which names
16570 refer to which functions or subroutines. It doesn't check code
16571 block, which is handled by gfc_resolve_code. */
16574 resolve_types (gfc_namespace
*ns
)
16580 gfc_namespace
* old_ns
= gfc_current_ns
;
16582 if (ns
->types_resolved
)
16585 /* Check that all IMPLICIT types are ok. */
16586 if (!ns
->seen_implicit_none
)
16589 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16590 if (ns
->set_flag
[letter
]
16591 && !resolve_typespec_used (&ns
->default_type
[letter
],
16592 &ns
->implicit_loc
[letter
], NULL
))
16596 gfc_current_ns
= ns
;
16598 resolve_entries (ns
);
16600 resolve_common_vars (&ns
->blank_common
, false);
16601 resolve_common_blocks (ns
->common_root
);
16603 resolve_contained_functions (ns
);
16605 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16606 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16607 resolve_formal_arglist (ns
->proc_name
);
16609 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16611 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16612 resolve_charlen (cl
);
16614 gfc_traverse_ns (ns
, resolve_symbol
);
16616 resolve_fntype (ns
);
16618 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16620 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16621 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16622 "also be PURE", n
->proc_name
->name
,
16623 &n
->proc_name
->declared_at
);
16629 gfc_do_concurrent_flag
= 0;
16630 gfc_check_interfaces (ns
);
16632 gfc_traverse_ns (ns
, resolve_values
);
16638 for (d
= ns
->data
; d
; d
= d
->next
)
16642 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16644 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16646 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16647 resolve_equivalence (eq
);
16649 /* Warn about unused labels. */
16650 if (warn_unused_label
)
16651 warn_unused_fortran_label (ns
->st_labels
);
16653 gfc_resolve_uops (ns
->uop_root
);
16655 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16657 gfc_resolve_omp_declare_simd (ns
);
16659 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16661 ns
->types_resolved
= 1;
16663 gfc_current_ns
= old_ns
;
16667 /* Call gfc_resolve_code recursively. */
16670 resolve_codes (gfc_namespace
*ns
)
16673 bitmap_obstack old_obstack
;
16675 if (ns
->resolved
== 1)
16678 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16681 gfc_current_ns
= ns
;
16683 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16684 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16687 /* Set to an out of range value. */
16688 current_entry_id
= -1;
16690 old_obstack
= labels_obstack
;
16691 bitmap_obstack_initialize (&labels_obstack
);
16693 gfc_resolve_oacc_declare (ns
);
16694 gfc_resolve_omp_local_vars (ns
);
16695 gfc_resolve_code (ns
->code
, ns
);
16697 bitmap_obstack_release (&labels_obstack
);
16698 labels_obstack
= old_obstack
;
16702 /* This function is called after a complete program unit has been compiled.
16703 Its purpose is to examine all of the expressions associated with a program
16704 unit, assign types to all intermediate expressions, make sure that all
16705 assignments are to compatible types and figure out which names refer to
16706 which functions or subroutines. */
16709 gfc_resolve (gfc_namespace
*ns
)
16711 gfc_namespace
*old_ns
;
16712 code_stack
*old_cs_base
;
16713 struct gfc_omp_saved_state old_omp_state
;
16719 old_ns
= gfc_current_ns
;
16720 old_cs_base
= cs_base
;
16722 /* As gfc_resolve can be called during resolution of an OpenMP construct
16723 body, we should clear any state associated to it, so that say NS's
16724 DO loops are not interpreted as OpenMP loops. */
16725 if (!ns
->construct_entities
)
16726 gfc_omp_save_and_clear_state (&old_omp_state
);
16728 resolve_types (ns
);
16729 component_assignment_level
= 0;
16730 resolve_codes (ns
);
16732 gfc_current_ns
= old_ns
;
16733 cs_base
= old_cs_base
;
16736 gfc_run_passes (ns
);
16738 if (!ns
->construct_entities
)
16739 gfc_omp_restore_state (&old_omp_state
);