1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag
= false;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
217 sym
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
218 sym
->attr
.pointer
= ifc
->result
->attr
.pointer
;
219 sym
->attr
.dimension
= ifc
->result
->attr
.dimension
;
220 sym
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
221 sym
->as
= gfc_copy_array_spec (ifc
->result
->as
);
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
231 sym
->as
= gfc_copy_array_spec (ifc
->as
);
233 sym
->ts
.interface
= ifc
;
234 sym
->attr
.function
= ifc
->attr
.function
;
235 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
237 sym
->attr
.pure
= ifc
->attr
.pure
;
238 sym
->attr
.elemental
= ifc
->attr
.elemental
;
239 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
240 sym
->attr
.recursive
= ifc
->attr
.recursive
;
241 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
242 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
243 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
244 /* Copy char length. */
245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
247 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
248 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
249 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
268 resolve_formal_arglist (gfc_symbol
*proc
)
270 gfc_formal_arglist
*f
;
272 bool saved_specification_expr
;
275 if (proc
->result
!= NULL
)
280 if (gfc_elemental (proc
)
281 || sym
->attr
.pointer
|| sym
->attr
.allocatable
282 || (sym
->as
&& sym
->as
->rank
!= 0))
284 proc
->attr
.always_explicit
= 1;
285 sym
->attr
.always_explicit
= 1;
288 formal_arg_flag
= true;
290 for (f
= proc
->formal
; f
; f
= f
->next
)
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc
))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc
->name
,
303 if (proc
->attr
.function
)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc
->name
,
309 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
310 && !resolve_procedure_interface (sym
))
313 if (strcmp (proc
->name
, sym
->name
) == 0)
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym
->name
,
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 saved_specification_expr
= specification_expr
;
340 specification_expr
= true;
341 gfc_resolve_array_spec (as
, 0);
342 specification_expr
= saved_specification_expr
;
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
347 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
348 && ((sym
->ts
.type
!= BT_CLASS
349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
350 || (sym
->ts
.type
== BT_CLASS
351 && !(CLASS_DATA (sym
)->attr
.class_pointer
352 || CLASS_DATA (sym
)->attr
.allocatable
)))
353 && sym
->attr
.flavor
!= FL_PROCEDURE
)
355 as
->type
= AS_ASSUMED_SHAPE
;
356 for (i
= 0; i
< as
->rank
; i
++)
357 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
360 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
361 || (as
&& as
->type
== AS_ASSUMED_RANK
)
362 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
364 && (CLASS_DATA (sym
)->attr
.class_pointer
365 || CLASS_DATA (sym
)->attr
.allocatable
366 || CLASS_DATA (sym
)->attr
.target
))
367 || sym
->attr
.optional
)
369 proc
->attr
.always_explicit
= 1;
371 proc
->result
->attr
.always_explicit
= 1;
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
377 if (sym
->attr
.flavor
== FL_UNKNOWN
)
378 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
382 if (sym
->attr
.flavor
== FL_PROCEDURE
)
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym
->name
, &sym
->declared_at
);
392 else if (!sym
->attr
.pointer
)
394 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
397 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym
->name
, proc
->name
, &sym
->declared_at
);
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
407 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
410 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym
->name
,
413 proc
->name
, &sym
->declared_at
);
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym
->name
, proc
->name
,
423 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym
->name
, proc
->name
,
432 if (proc
->attr
.implicit_pure
)
434 if (sym
->attr
.flavor
== FL_PROCEDURE
)
437 proc
->attr
.implicit_pure
= 0;
439 else if (!sym
->attr
.pointer
)
441 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
443 proc
->attr
.implicit_pure
= 0;
445 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
447 proc
->attr
.implicit_pure
= 0;
451 if (gfc_elemental (proc
))
454 if (sym
->attr
.codimension
455 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->attr
.codimension
))
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym
->name
, &sym
->declared_at
);
463 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
464 && CLASS_DATA (sym
)->as
))
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym
->name
, &sym
->declared_at
);
471 if (sym
->attr
.allocatable
472 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
473 && CLASS_DATA (sym
)->attr
.allocatable
))
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym
->name
,
481 if (sym
->attr
.pointer
482 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
483 && CLASS_DATA (sym
)->attr
.class_pointer
))
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym
->name
,
491 if (sym
->attr
.flavor
== FL_PROCEDURE
)
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym
->name
, proc
->name
,
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym
->name
, proc
->name
,
510 /* Each dummy shall be specified to be scalar. */
511 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument '%s' of statement function '%s' at %L "
518 "must be scalar", sym
->name
, proc
->name
,
523 if (sym
->ts
.type
== BT_CHARACTER
)
525 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
526 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
528 gfc_error ("Character-valued argument %qs of statement "
529 "function at %L must have constant length",
530 sym
->name
, &sym
->declared_at
);
536 formal_arg_flag
= false;
540 /* Work function called when searching for symbols that have argument lists
541 associated with them. */
544 find_arglists (gfc_symbol
*sym
)
546 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
547 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
550 resolve_formal_arglist (sym
);
554 /* Given a namespace, resolve all formal argument lists within the namespace.
558 resolve_formal_arglists (gfc_namespace
*ns
)
563 gfc_traverse_ns (ns
, find_arglists
);
568 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
572 if (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
574 && sym
->ns
->parent
->proc_name
575 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
576 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym
->name
, &sym
->declared_at
);
580 /* If this namespace is not a function or an entry master function,
582 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
583 || sym
->attr
.entry_master
)
586 /* Try to find out of what the return type is. */
587 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
589 t
= gfc_set_default_type (sym
->result
, 0, ns
);
591 if (!t
&& !sym
->result
->attr
.untyped
)
593 if (sym
->result
== sym
)
594 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
595 sym
->name
, &sym
->declared_at
);
596 else if (!sym
->result
->attr
.proc_pointer
)
597 gfc_error ("Result %qs of contained function %qs at %L has "
598 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
599 &sym
->result
->declared_at
);
600 sym
->result
->attr
.untyped
= 1;
604 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
605 type, lists the only ways a character length value of * can be used:
606 dummy arguments of procedures, named constants, function results and
607 in allocate statements if the allocate_object is an assumed length dummy
608 in external functions. Internal function results and results of module
609 procedures are not on this list, ergo, not permitted. */
611 if (sym
->result
->ts
.type
== BT_CHARACTER
)
613 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
614 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
616 /* See if this is a module-procedure and adapt error message
619 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
620 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
622 gfc_error (module_proc
623 ? G_("Character-valued module procedure %qs at %L"
624 " must not be assumed length")
625 : G_("Character-valued internal function %qs at %L"
626 " must not be assumed length"),
627 sym
->name
, &sym
->declared_at
);
633 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
634 introduce duplicates. */
637 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
639 gfc_formal_arglist
*f
, *new_arglist
;
642 for (; new_args
!= NULL
; new_args
= new_args
->next
)
644 new_sym
= new_args
->sym
;
645 /* See if this arg is already in the formal argument list. */
646 for (f
= proc
->formal
; f
; f
= f
->next
)
648 if (new_sym
== f
->sym
)
655 /* Add a new argument. Argument order is not important. */
656 new_arglist
= gfc_get_formal_arglist ();
657 new_arglist
->sym
= new_sym
;
658 new_arglist
->next
= proc
->formal
;
659 proc
->formal
= new_arglist
;
664 /* Flag the arguments that are not present in all entries. */
667 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
669 gfc_formal_arglist
*f
, *head
;
672 for (f
= proc
->formal
; f
; f
= f
->next
)
677 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
679 if (new_args
->sym
== f
->sym
)
686 f
->sym
->attr
.not_always_present
= 1;
691 /* Resolve alternate entry points. If a symbol has multiple entry points we
692 create a new master symbol for the main routine, and turn the existing
693 symbol into an entry point. */
696 resolve_entries (gfc_namespace
*ns
)
698 gfc_namespace
*old_ns
;
702 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
703 static int master_count
= 0;
705 if (ns
->proc_name
== NULL
)
708 /* No need to do anything if this procedure doesn't have alternate entry
713 /* We may already have resolved alternate entry points. */
714 if (ns
->proc_name
->attr
.entry_master
)
717 /* If this isn't a procedure something has gone horribly wrong. */
718 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
720 /* Remember the current namespace. */
721 old_ns
= gfc_current_ns
;
725 /* Add the main entry point to the list of entry points. */
726 el
= gfc_get_entry_list ();
727 el
->sym
= ns
->proc_name
;
729 el
->next
= ns
->entries
;
731 ns
->proc_name
->attr
.entry
= 1;
733 /* If it is a module function, it needs to be in the right namespace
734 so that gfc_get_fake_result_decl can gather up the results. The
735 need for this arose in get_proc_name, where these beasts were
736 left in their own namespace, to keep prior references linked to
737 the entry declaration.*/
738 if (ns
->proc_name
->attr
.function
739 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
742 /* Do the same for entries where the master is not a module
743 procedure. These are retained in the module namespace because
744 of the module procedure declaration. */
745 for (el
= el
->next
; el
; el
= el
->next
)
746 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
747 && el
->sym
->attr
.mod_proc
)
751 /* Add an entry statement for it. */
752 c
= gfc_get_code (EXEC_ENTRY
);
757 /* Create a new symbol for the master function. */
758 /* Give the internal function a unique name (within this file).
759 Also include the function name so the user has some hope of figuring
760 out what is going on. */
761 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
762 master_count
++, ns
->proc_name
->name
);
763 gfc_get_ha_symbol (name
, &proc
);
764 gcc_assert (proc
!= NULL
);
766 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
767 if (ns
->proc_name
->attr
.subroutine
)
768 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
772 gfc_typespec
*ts
, *fts
;
773 gfc_array_spec
*as
, *fas
;
774 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
776 fas
= ns
->entries
->sym
->as
;
777 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
778 fts
= &ns
->entries
->sym
->result
->ts
;
779 if (fts
->type
== BT_UNKNOWN
)
780 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
781 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
783 ts
= &el
->sym
->result
->ts
;
785 as
= as
? as
: el
->sym
->result
->as
;
786 if (ts
->type
== BT_UNKNOWN
)
787 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
789 if (! gfc_compare_types (ts
, fts
)
790 || (el
->sym
->result
->attr
.dimension
791 != ns
->entries
->sym
->result
->attr
.dimension
)
792 || (el
->sym
->result
->attr
.pointer
793 != ns
->entries
->sym
->result
->attr
.pointer
))
795 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
796 && gfc_compare_array_spec (as
, fas
) == 0)
797 gfc_error ("Function %s at %L has entries with mismatched "
798 "array specifications", ns
->entries
->sym
->name
,
799 &ns
->entries
->sym
->declared_at
);
800 /* The characteristics need to match and thus both need to have
801 the same string length, i.e. both len=*, or both len=4.
802 Having both len=<variable> is also possible, but difficult to
803 check at compile time. */
804 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
805 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
806 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
808 && ts
->u
.cl
->length
->expr_type
809 != fts
->u
.cl
->length
->expr_type
)
811 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
812 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
813 fts
->u
.cl
->length
->value
.integer
) != 0)))
814 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
815 "entries returning variables of different "
816 "string lengths", ns
->entries
->sym
->name
,
817 &ns
->entries
->sym
->declared_at
);
822 sym
= ns
->entries
->sym
->result
;
823 /* All result types the same. */
825 if (sym
->attr
.dimension
)
826 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
827 if (sym
->attr
.pointer
)
828 gfc_add_pointer (&proc
->attr
, NULL
);
832 /* Otherwise the result will be passed through a union by
834 proc
->attr
.mixed_entry_master
= 1;
835 for (el
= ns
->entries
; el
; el
= el
->next
)
837 sym
= el
->sym
->result
;
838 if (sym
->attr
.dimension
)
840 if (el
== ns
->entries
)
841 gfc_error ("FUNCTION result %s cannot be an array in "
842 "FUNCTION %s at %L", sym
->name
,
843 ns
->entries
->sym
->name
, &sym
->declared_at
);
845 gfc_error ("ENTRY result %s cannot be an array in "
846 "FUNCTION %s at %L", sym
->name
,
847 ns
->entries
->sym
->name
, &sym
->declared_at
);
849 else if (sym
->attr
.pointer
)
851 if (el
== ns
->entries
)
852 gfc_error ("FUNCTION result %s cannot be a POINTER in "
853 "FUNCTION %s at %L", sym
->name
,
854 ns
->entries
->sym
->name
, &sym
->declared_at
);
856 gfc_error ("ENTRY result %s cannot be a POINTER in "
857 "FUNCTION %s at %L", sym
->name
,
858 ns
->entries
->sym
->name
, &sym
->declared_at
);
863 if (ts
->type
== BT_UNKNOWN
)
864 ts
= gfc_get_default_type (sym
->name
, NULL
);
868 if (ts
->kind
== gfc_default_integer_kind
)
872 if (ts
->kind
== gfc_default_real_kind
873 || ts
->kind
== gfc_default_double_kind
)
877 if (ts
->kind
== gfc_default_complex_kind
)
881 if (ts
->kind
== gfc_default_logical_kind
)
885 /* We will issue error elsewhere. */
893 if (el
== ns
->entries
)
894 gfc_error ("FUNCTION result %s cannot be of type %s "
895 "in FUNCTION %s at %L", sym
->name
,
896 gfc_typename (ts
), ns
->entries
->sym
->name
,
899 gfc_error ("ENTRY result %s cannot be of type %s "
900 "in FUNCTION %s at %L", sym
->name
,
901 gfc_typename (ts
), ns
->entries
->sym
->name
,
908 proc
->attr
.access
= ACCESS_PRIVATE
;
909 proc
->attr
.entry_master
= 1;
911 /* Merge all the entry point arguments. */
912 for (el
= ns
->entries
; el
; el
= el
->next
)
913 merge_argument_lists (proc
, el
->sym
->formal
);
915 /* Check the master formal arguments for any that are not
916 present in all entry points. */
917 for (el
= ns
->entries
; el
; el
= el
->next
)
918 check_argument_lists (proc
, el
->sym
->formal
);
920 /* Use the master function for the function body. */
921 ns
->proc_name
= proc
;
923 /* Finalize the new symbols. */
924 gfc_commit_symbols ();
926 /* Restore the original namespace. */
927 gfc_current_ns
= old_ns
;
931 /* Resolve common variables. */
933 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
935 gfc_symbol
*csym
= common_block
->head
;
937 for (; csym
; csym
= csym
->common_next
)
939 /* gfc_add_in_common may have been called before, but the reported errors
940 have been ignored to continue parsing.
941 We do the checks again here. */
942 if (!csym
->attr
.use_assoc
)
944 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
945 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
946 &common_block
->where
);
949 if (csym
->value
|| csym
->attr
.data
)
951 if (!csym
->ns
->is_block_data
)
952 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
953 "but only in BLOCK DATA initialization is "
954 "allowed", csym
->name
, &csym
->declared_at
);
955 else if (!named_common
)
956 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
957 "in a blank COMMON but initialization is only "
958 "allowed in named common blocks", csym
->name
,
962 if (UNLIMITED_POLY (csym
))
963 gfc_error_now ("%qs in cannot appear in COMMON at %L "
964 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
966 if (csym
->ts
.type
!= BT_DERIVED
)
969 if (!(csym
->ts
.u
.derived
->attr
.sequence
970 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
971 gfc_error_now ("Derived type variable %qs in COMMON at %L "
972 "has neither the SEQUENCE nor the BIND(C) "
973 "attribute", csym
->name
, &csym
->declared_at
);
974 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
975 gfc_error_now ("Derived type variable %qs in COMMON at %L "
976 "has an ultimate component that is "
977 "allocatable", csym
->name
, &csym
->declared_at
);
978 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
979 gfc_error_now ("Derived type variable %qs in COMMON at %L "
980 "may not have default initializer", csym
->name
,
983 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
984 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
988 /* Resolve common blocks. */
990 resolve_common_blocks (gfc_symtree
*common_root
)
995 if (common_root
== NULL
)
998 if (common_root
->left
)
999 resolve_common_blocks (common_root
->left
);
1000 if (common_root
->right
)
1001 resolve_common_blocks (common_root
->right
);
1003 resolve_common_vars (common_root
->n
.common
, true);
1005 /* The common name is a global name - in Fortran 2003 also if it has a
1006 C binding name, since Fortran 2008 only the C binding name is a global
1008 if (!common_root
->n
.common
->binding_label
1009 || gfc_notification_std (GFC_STD_F2008
))
1011 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1012 common_root
->n
.common
->name
);
1014 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1015 && gsym
->type
== GSYM_COMMON
1016 && ((common_root
->n
.common
->binding_label
1017 && (!gsym
->binding_label
1018 || strcmp (common_root
->n
.common
->binding_label
,
1019 gsym
->binding_label
) != 0))
1020 || (!common_root
->n
.common
->binding_label
1021 && gsym
->binding_label
)))
1023 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1024 "identifier and must thus have the same binding name "
1025 "as the same-named COMMON block at %L: %s vs %s",
1026 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1028 common_root
->n
.common
->binding_label
1029 ? common_root
->n
.common
->binding_label
: "(blank)",
1030 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1034 if (gsym
&& gsym
->type
!= GSYM_COMMON
1035 && !common_root
->n
.common
->binding_label
)
1037 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1039 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1043 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1045 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1046 "%L sharing the identifier with global non-COMMON-block "
1047 "entity at %L", common_root
->n
.common
->name
,
1048 &common_root
->n
.common
->where
, &gsym
->where
);
1053 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1054 gsym
->type
= GSYM_COMMON
;
1055 gsym
->where
= common_root
->n
.common
->where
;
1061 if (common_root
->n
.common
->binding_label
)
1063 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1064 common_root
->n
.common
->binding_label
);
1065 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1067 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1068 "global identifier as entity at %L",
1069 &common_root
->n
.common
->where
,
1070 common_root
->n
.common
->binding_label
, &gsym
->where
);
1075 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1076 gsym
->type
= GSYM_COMMON
;
1077 gsym
->where
= common_root
->n
.common
->where
;
1083 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1087 if (sym
->attr
.flavor
== FL_PARAMETER
)
1088 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1089 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1091 if (sym
->attr
.external
)
1092 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1093 sym
->name
, &common_root
->n
.common
->where
);
1095 if (sym
->attr
.intrinsic
)
1096 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1097 sym
->name
, &common_root
->n
.common
->where
);
1098 else if (sym
->attr
.result
1099 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1100 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1101 "that is also a function result", sym
->name
,
1102 &common_root
->n
.common
->where
);
1103 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1104 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1105 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1106 "that is also a global procedure", sym
->name
,
1107 &common_root
->n
.common
->where
);
1111 /* Resolve contained function types. Because contained functions can call one
1112 another, they have to be worked out before any of the contained procedures
1115 The good news is that if a function doesn't already have a type, the only
1116 way it can get one is through an IMPLICIT type or a RESULT variable, because
1117 by definition contained functions are contained namespace they're contained
1118 in, not in a sibling or parent namespace. */
1121 resolve_contained_functions (gfc_namespace
*ns
)
1123 gfc_namespace
*child
;
1126 resolve_formal_arglists (ns
);
1128 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1130 /* Resolve alternate entry points first. */
1131 resolve_entries (child
);
1133 /* Then check function return types. */
1134 resolve_contained_fntype (child
->proc_name
, child
);
1135 for (el
= child
->entries
; el
; el
= el
->next
)
1136 resolve_contained_fntype (el
->sym
, child
);
1142 /* A Parameterized Derived Type constructor must contain values for
1143 the PDT KIND parameters or they must have a default initializer.
1144 Go through the constructor picking out the KIND expressions,
1145 storing them in 'param_list' and then call gfc_get_pdt_instance
1146 to obtain the PDT instance. */
1148 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1151 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1153 param
= gfc_get_actual_arglist ();
1155 param_list
= param_tail
= param
;
1158 param_tail
->next
= param
;
1159 param_tail
= param_tail
->next
;
1162 param_tail
->name
= c
->name
;
1164 param_tail
->expr
= gfc_copy_expr (expr
);
1165 else if (c
->initializer
)
1166 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1169 param_tail
->spec_type
= SPEC_ASSUMED
;
1170 if (c
->attr
.pdt_kind
)
1172 gfc_error ("The KIND parameter %qs in the PDT constructor "
1173 "at %C has no value", param
->name
);
1182 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1183 gfc_symbol
*derived
)
1185 gfc_constructor
*cons
= NULL
;
1186 gfc_component
*comp
;
1189 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1190 cons
= gfc_constructor_first (expr
->value
.constructor
);
1195 comp
= derived
->components
;
1197 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1200 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1201 && comp
->ts
.type
== BT_DERIVED
)
1203 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1207 else if (comp
->ts
.type
== BT_DERIVED
)
1209 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1213 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1214 && derived
->attr
.pdt_template
)
1216 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1225 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1226 static bool resolve_fl_struct (gfc_symbol
*sym
);
1229 /* Resolve all of the elements of a structure constructor and make sure that
1230 the types are correct. The 'init' flag indicates that the given
1231 constructor is an initializer. */
1234 resolve_structure_cons (gfc_expr
*expr
, int init
)
1236 gfc_constructor
*cons
;
1237 gfc_component
*comp
;
1243 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1245 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1246 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1248 resolve_fl_struct (expr
->ts
.u
.derived
);
1250 /* If this is a Parameterized Derived Type template, find the
1251 instance corresponding to the PDT kind parameters. */
1252 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1255 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1258 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1260 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1263 gfc_free_actual_arglist (param_list
);
1265 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1270 cons
= gfc_constructor_first (expr
->value
.constructor
);
1272 /* A constructor may have references if it is the result of substituting a
1273 parameter variable. In this case we just pull out the component we
1276 comp
= expr
->ref
->u
.c
.sym
->components
;
1278 comp
= expr
->ts
.u
.derived
->components
;
1280 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1287 /* Unions use an EXPR_NULL contrived expression to tell the translation
1288 phase to generate an initializer of the appropriate length.
1290 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1293 if (!gfc_resolve_expr (cons
->expr
))
1299 rank
= comp
->as
? comp
->as
->rank
: 0;
1300 if (comp
->ts
.type
== BT_CLASS
1301 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1302 && CLASS_DATA (comp
)->as
)
1303 rank
= CLASS_DATA (comp
)->as
->rank
;
1305 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1306 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1308 gfc_error ("The rank of the element in the structure "
1309 "constructor at %L does not match that of the "
1310 "component (%d/%d)", &cons
->expr
->where
,
1311 cons
->expr
->rank
, rank
);
1315 /* If we don't have the right type, try to convert it. */
1317 if (!comp
->attr
.proc_pointer
&&
1318 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1320 if (strcmp (comp
->name
, "_extends") == 0)
1322 /* Can afford to be brutal with the _extends initializer.
1323 The derived type can get lost because it is PRIVATE
1324 but it is not usage constrained by the standard. */
1325 cons
->expr
->ts
= comp
->ts
;
1327 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1329 gfc_error ("The element in the structure constructor at %L, "
1330 "for pointer component %qs, is %s but should be %s",
1331 &cons
->expr
->where
, comp
->name
,
1332 gfc_basic_typename (cons
->expr
->ts
.type
),
1333 gfc_basic_typename (comp
->ts
.type
));
1338 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1344 /* For strings, the length of the constructor should be the same as
1345 the one of the structure, ensure this if the lengths are known at
1346 compile time and when we are dealing with PARAMETER or structure
1348 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1349 && comp
->ts
.u
.cl
->length
1350 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1351 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1352 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1353 && cons
->expr
->rank
!= 0
1354 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1355 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1357 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1358 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1360 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1361 to make use of the gfc_resolve_character_array_constructor
1362 machinery. The expression is later simplified away to
1363 an array of string literals. */
1364 gfc_expr
*para
= cons
->expr
;
1365 cons
->expr
= gfc_get_expr ();
1366 cons
->expr
->ts
= para
->ts
;
1367 cons
->expr
->where
= para
->where
;
1368 cons
->expr
->expr_type
= EXPR_ARRAY
;
1369 cons
->expr
->rank
= para
->rank
;
1370 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1371 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1372 para
, &cons
->expr
->where
);
1375 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1377 /* Rely on the cleanup of the namespace to deal correctly with
1378 the old charlen. (There was a block here that attempted to
1379 remove the charlen but broke the chain in so doing.) */
1380 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1381 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1382 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1383 gfc_resolve_character_array_constructor (cons
->expr
);
1387 if (cons
->expr
->expr_type
== EXPR_NULL
1388 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1389 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1390 || (comp
->ts
.type
== BT_CLASS
1391 && (CLASS_DATA (comp
)->attr
.class_pointer
1392 || CLASS_DATA (comp
)->attr
.allocatable
))))
1395 gfc_error ("The NULL in the structure constructor at %L is "
1396 "being applied to component %qs, which is neither "
1397 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1401 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1403 /* Check procedure pointer interface. */
1404 gfc_symbol
*s2
= NULL
;
1409 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1412 s2
= c2
->ts
.interface
;
1415 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1417 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1418 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1420 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1422 s2
= cons
->expr
->symtree
->n
.sym
;
1423 name
= cons
->expr
->symtree
->n
.sym
->name
;
1426 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1427 err
, sizeof (err
), NULL
, NULL
))
1429 gfc_error_opt (OPT_Wargument_mismatch
,
1430 "Interface mismatch for procedure-pointer "
1431 "component %qs in structure constructor at %L:"
1432 " %s", comp
->name
, &cons
->expr
->where
, err
);
1437 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1438 || cons
->expr
->expr_type
== EXPR_NULL
)
1441 a
= gfc_expr_attr (cons
->expr
);
1443 if (!a
.pointer
&& !a
.target
)
1446 gfc_error ("The element in the structure constructor at %L, "
1447 "for pointer component %qs should be a POINTER or "
1448 "a TARGET", &cons
->expr
->where
, comp
->name
);
1453 /* F08:C461. Additional checks for pointer initialization. */
1457 gfc_error ("Pointer initialization target at %L "
1458 "must not be ALLOCATABLE", &cons
->expr
->where
);
1463 gfc_error ("Pointer initialization target at %L "
1464 "must have the SAVE attribute", &cons
->expr
->where
);
1468 /* F2003, C1272 (3). */
1469 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1470 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1471 || gfc_is_coindexed (cons
->expr
));
1472 if (impure
&& gfc_pure (NULL
))
1475 gfc_error ("Invalid expression in the structure constructor for "
1476 "pointer component %qs at %L in PURE procedure",
1477 comp
->name
, &cons
->expr
->where
);
1481 gfc_unset_implicit_pure (NULL
);
1488 /****************** Expression name resolution ******************/
1490 /* Returns 0 if a symbol was not declared with a type or
1491 attribute declaration statement, nonzero otherwise. */
1494 was_declared (gfc_symbol
*sym
)
1500 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1503 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1504 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1505 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1506 || a
.asynchronous
|| a
.codimension
)
1513 /* Determine if a symbol is generic or not. */
1516 generic_sym (gfc_symbol
*sym
)
1520 if (sym
->attr
.generic
||
1521 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1524 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1527 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1534 return generic_sym (s
);
1541 /* Determine if a symbol is specific or not. */
1544 specific_sym (gfc_symbol
*sym
)
1548 if (sym
->attr
.if_source
== IFSRC_IFBODY
1549 || sym
->attr
.proc
== PROC_MODULE
1550 || sym
->attr
.proc
== PROC_INTERNAL
1551 || sym
->attr
.proc
== PROC_ST_FUNCTION
1552 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1553 || sym
->attr
.external
)
1556 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1559 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1561 return (s
== NULL
) ? 0 : specific_sym (s
);
1565 /* Figure out if the procedure is specific, generic or unknown. */
1568 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1571 procedure_kind (gfc_symbol
*sym
)
1573 if (generic_sym (sym
))
1574 return PTYPE_GENERIC
;
1576 if (specific_sym (sym
))
1577 return PTYPE_SPECIFIC
;
1579 return PTYPE_UNKNOWN
;
1582 /* Check references to assumed size arrays. The flag need_full_assumed_size
1583 is nonzero when matching actual arguments. */
1585 static int need_full_assumed_size
= 0;
1588 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1590 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1593 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1594 What should it be? */
1595 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1596 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1597 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1599 gfc_error ("The upper bound in the last dimension must "
1600 "appear in the reference to the assumed size "
1601 "array %qs at %L", sym
->name
, &e
->where
);
1608 /* Look for bad assumed size array references in argument expressions
1609 of elemental and array valued intrinsic procedures. Since this is
1610 called from procedure resolution functions, it only recurses at
1614 resolve_assumed_size_actual (gfc_expr
*e
)
1619 switch (e
->expr_type
)
1622 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1627 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1628 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1639 /* Check a generic procedure, passed as an actual argument, to see if
1640 there is a matching specific name. If none, it is an error, and if
1641 more than one, the reference is ambiguous. */
1643 count_specific_procs (gfc_expr
*e
)
1650 sym
= e
->symtree
->n
.sym
;
1652 for (p
= sym
->generic
; p
; p
= p
->next
)
1653 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1655 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1661 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1665 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1666 "argument at %L", sym
->name
, &e
->where
);
1672 /* See if a call to sym could possibly be a not allowed RECURSION because of
1673 a missing RECURSIVE declaration. This means that either sym is the current
1674 context itself, or sym is the parent of a contained procedure calling its
1675 non-RECURSIVE containing procedure.
1676 This also works if sym is an ENTRY. */
1679 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1681 gfc_symbol
* proc_sym
;
1682 gfc_symbol
* context_proc
;
1683 gfc_namespace
* real_context
;
1685 if (sym
->attr
.flavor
== FL_PROGRAM
1686 || gfc_fl_struct (sym
->attr
.flavor
))
1689 /* If we've got an ENTRY, find real procedure. */
1690 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1691 proc_sym
= sym
->ns
->entries
->sym
;
1695 /* If sym is RECURSIVE, all is well of course. */
1696 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1699 /* Find the context procedure's "real" symbol if it has entries.
1700 We look for a procedure symbol, so recurse on the parents if we don't
1701 find one (like in case of a BLOCK construct). */
1702 for (real_context
= context
; ; real_context
= real_context
->parent
)
1704 /* We should find something, eventually! */
1705 gcc_assert (real_context
);
1707 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1708 : real_context
->proc_name
);
1710 /* In some special cases, there may not be a proc_name, like for this
1712 real(bad_kind()) function foo () ...
1713 when checking the call to bad_kind ().
1714 In these cases, we simply return here and assume that the
1719 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1723 /* A call from sym's body to itself is recursion, of course. */
1724 if (context_proc
== proc_sym
)
1727 /* The same is true if context is a contained procedure and sym the
1729 if (context_proc
->attr
.contained
)
1731 gfc_symbol
* parent_proc
;
1733 gcc_assert (context
->parent
);
1734 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1735 : context
->parent
->proc_name
);
1737 if (parent_proc
== proc_sym
)
1745 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1746 its typespec and formal argument list. */
1749 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1751 gfc_intrinsic_sym
* isym
= NULL
;
1757 /* Already resolved. */
1758 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1761 /* We already know this one is an intrinsic, so we don't call
1762 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1763 gfc_find_subroutine directly to check whether it is a function or
1766 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1768 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1769 isym
= gfc_intrinsic_subroutine_by_id (id
);
1771 else if (sym
->intmod_sym_id
)
1773 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1774 isym
= gfc_intrinsic_function_by_id (id
);
1776 else if (!sym
->attr
.subroutine
)
1777 isym
= gfc_find_function (sym
->name
);
1779 if (isym
&& !sym
->attr
.subroutine
)
1781 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1782 && !sym
->attr
.implicit_type
)
1783 gfc_warning (OPT_Wsurprising
,
1784 "Type specified for intrinsic function %qs at %L is"
1785 " ignored", sym
->name
, &sym
->declared_at
);
1787 if (!sym
->attr
.function
&&
1788 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1793 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1795 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1797 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1798 " specifier", sym
->name
, &sym
->declared_at
);
1802 if (!sym
->attr
.subroutine
&&
1803 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1808 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1813 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1815 sym
->attr
.pure
= isym
->pure
;
1816 sym
->attr
.elemental
= isym
->elemental
;
1818 /* Check it is actually available in the standard settings. */
1819 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1821 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1822 "available in the current standard settings but %s. Use "
1823 "an appropriate %<-std=*%> option or enable "
1824 "%<-fall-intrinsics%> in order to use it.",
1825 sym
->name
, &sym
->declared_at
, symstd
);
1833 /* Resolve a procedure expression, like passing it to a called procedure or as
1834 RHS for a procedure pointer assignment. */
1837 resolve_procedure_expression (gfc_expr
* expr
)
1841 if (expr
->expr_type
!= EXPR_VARIABLE
)
1843 gcc_assert (expr
->symtree
);
1845 sym
= expr
->symtree
->n
.sym
;
1847 if (sym
->attr
.intrinsic
)
1848 gfc_resolve_intrinsic (sym
, &expr
->where
);
1850 if (sym
->attr
.flavor
!= FL_PROCEDURE
1851 || (sym
->attr
.function
&& sym
->result
== sym
))
1854 /* A non-RECURSIVE procedure that is used as procedure expression within its
1855 own body is in danger of being called recursively. */
1856 if (is_illegal_recursion (sym
, gfc_current_ns
))
1857 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1858 " itself recursively. Declare it RECURSIVE or use"
1859 " %<-frecursive%>", sym
->name
, &expr
->where
);
1865 /* Check that name is not a derived type. */
1868 is_dt_name (const char *name
)
1870 gfc_symbol
*dt_list
, *dt_first
;
1872 dt_list
= dt_first
= gfc_derived_types
;
1873 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1875 if (strcmp(dt_list
->name
, name
) == 0)
1877 if (dt_first
== dt_list
->dt_next
)
1884 /* Resolve an actual argument list. Most of the time, this is just
1885 resolving the expressions in the list.
1886 The exception is that we sometimes have to decide whether arguments
1887 that look like procedure arguments are really simple variable
1891 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1892 bool no_formal_args
)
1895 gfc_symtree
*parent_st
;
1897 gfc_component
*comp
;
1898 int save_need_full_assumed_size
;
1899 bool return_value
= false;
1900 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1903 first_actual_arg
= true;
1905 for (; arg
; arg
= arg
->next
)
1910 /* Check the label is a valid branching target. */
1913 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1915 gfc_error ("Label %d referenced at %L is never defined",
1916 arg
->label
->value
, &arg
->label
->where
);
1920 first_actual_arg
= false;
1924 if (e
->expr_type
== EXPR_VARIABLE
1925 && e
->symtree
->n
.sym
->attr
.generic
1927 && count_specific_procs (e
) != 1)
1930 if (e
->ts
.type
!= BT_PROCEDURE
)
1932 save_need_full_assumed_size
= need_full_assumed_size
;
1933 if (e
->expr_type
!= EXPR_VARIABLE
)
1934 need_full_assumed_size
= 0;
1935 if (!gfc_resolve_expr (e
))
1937 need_full_assumed_size
= save_need_full_assumed_size
;
1941 /* See if the expression node should really be a variable reference. */
1943 sym
= e
->symtree
->n
.sym
;
1945 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
1947 gfc_error ("Derived type %qs is used as an actual "
1948 "argument at %L", sym
->name
, &e
->where
);
1952 if (sym
->attr
.flavor
== FL_PROCEDURE
1953 || sym
->attr
.intrinsic
1954 || sym
->attr
.external
)
1958 /* If a procedure is not already determined to be something else
1959 check if it is intrinsic. */
1960 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1961 sym
->attr
.intrinsic
= 1;
1963 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1965 gfc_error ("Statement function %qs at %L is not allowed as an "
1966 "actual argument", sym
->name
, &e
->where
);
1969 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1970 sym
->attr
.subroutine
);
1971 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1973 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1974 "actual argument", sym
->name
, &e
->where
);
1977 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1978 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1980 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1981 " used as actual argument at %L",
1982 sym
->name
, &e
->where
))
1986 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1988 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1989 "allowed as an actual argument at %L", sym
->name
,
1993 /* Check if a generic interface has a specific procedure
1994 with the same name before emitting an error. */
1995 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1998 /* Just in case a specific was found for the expression. */
1999 sym
= e
->symtree
->n
.sym
;
2001 /* If the symbol is the function that names the current (or
2002 parent) scope, then we really have a variable reference. */
2004 if (gfc_is_function_return_value (sym
, sym
->ns
))
2007 /* If all else fails, see if we have a specific intrinsic. */
2008 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2010 gfc_intrinsic_sym
*isym
;
2012 isym
= gfc_find_function (sym
->name
);
2013 if (isym
== NULL
|| !isym
->specific
)
2015 gfc_error ("Unable to find a specific INTRINSIC procedure "
2016 "for the reference %qs at %L", sym
->name
,
2021 sym
->attr
.intrinsic
= 1;
2022 sym
->attr
.function
= 1;
2025 if (!gfc_resolve_expr (e
))
2030 /* See if the name is a module procedure in a parent unit. */
2032 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2035 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2037 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2041 if (parent_st
== NULL
)
2044 sym
= parent_st
->n
.sym
;
2045 e
->symtree
= parent_st
; /* Point to the right thing. */
2047 if (sym
->attr
.flavor
== FL_PROCEDURE
2048 || sym
->attr
.intrinsic
2049 || sym
->attr
.external
)
2051 if (!gfc_resolve_expr (e
))
2057 e
->expr_type
= EXPR_VARIABLE
;
2059 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2060 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2061 && CLASS_DATA (sym
)->as
))
2063 e
->rank
= sym
->ts
.type
== BT_CLASS
2064 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2065 e
->ref
= gfc_get_ref ();
2066 e
->ref
->type
= REF_ARRAY
;
2067 e
->ref
->u
.ar
.type
= AR_FULL
;
2068 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2069 ? CLASS_DATA (sym
)->as
: sym
->as
;
2072 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2073 primary.c (match_actual_arg). If above code determines that it
2074 is a variable instead, it needs to be resolved as it was not
2075 done at the beginning of this function. */
2076 save_need_full_assumed_size
= need_full_assumed_size
;
2077 if (e
->expr_type
!= EXPR_VARIABLE
)
2078 need_full_assumed_size
= 0;
2079 if (!gfc_resolve_expr (e
))
2081 need_full_assumed_size
= save_need_full_assumed_size
;
2084 /* Check argument list functions %VAL, %LOC and %REF. There is
2085 nothing to do for %REF. */
2086 if (arg
->name
&& arg
->name
[0] == '%')
2088 if (strcmp ("%VAL", arg
->name
) == 0)
2090 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2092 gfc_error ("By-value argument at %L is not of numeric "
2099 gfc_error ("By-value argument at %L cannot be an array or "
2100 "an array section", &e
->where
);
2104 /* Intrinsics are still PROC_UNKNOWN here. However,
2105 since same file external procedures are not resolvable
2106 in gfortran, it is a good deal easier to leave them to
2108 if (ptype
!= PROC_UNKNOWN
2109 && ptype
!= PROC_DUMMY
2110 && ptype
!= PROC_EXTERNAL
2111 && ptype
!= PROC_MODULE
)
2113 gfc_error ("By-value argument at %L is not allowed "
2114 "in this context", &e
->where
);
2119 /* Statement functions have already been excluded above. */
2120 else if (strcmp ("%LOC", arg
->name
) == 0
2121 && e
->ts
.type
== BT_PROCEDURE
)
2123 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2125 gfc_error ("Passing internal procedure at %L by location "
2126 "not allowed", &e
->where
);
2132 comp
= gfc_get_proc_ptr_comp(e
);
2133 if (e
->expr_type
== EXPR_VARIABLE
2134 && comp
&& comp
->attr
.elemental
)
2136 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2137 "allowed as an actual argument at %L", comp
->name
,
2141 /* Fortran 2008, C1237. */
2142 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2143 && gfc_has_ultimate_pointer (e
))
2145 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2146 "component", &e
->where
);
2150 first_actual_arg
= false;
2153 return_value
= true;
2156 actual_arg
= actual_arg_sav
;
2157 first_actual_arg
= first_actual_arg_sav
;
2159 return return_value
;
2163 /* Do the checks of the actual argument list that are specific to elemental
2164 procedures. If called with c == NULL, we have a function, otherwise if
2165 expr == NULL, we have a subroutine. */
2168 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2170 gfc_actual_arglist
*arg0
;
2171 gfc_actual_arglist
*arg
;
2172 gfc_symbol
*esym
= NULL
;
2173 gfc_intrinsic_sym
*isym
= NULL
;
2175 gfc_intrinsic_arg
*iformal
= NULL
;
2176 gfc_formal_arglist
*eformal
= NULL
;
2177 bool formal_optional
= false;
2178 bool set_by_optional
= false;
2182 /* Is this an elemental procedure? */
2183 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2185 if (expr
->value
.function
.esym
!= NULL
2186 && expr
->value
.function
.esym
->attr
.elemental
)
2188 arg0
= expr
->value
.function
.actual
;
2189 esym
= expr
->value
.function
.esym
;
2191 else if (expr
->value
.function
.isym
!= NULL
2192 && expr
->value
.function
.isym
->elemental
)
2194 arg0
= expr
->value
.function
.actual
;
2195 isym
= expr
->value
.function
.isym
;
2200 else if (c
&& c
->ext
.actual
!= NULL
)
2202 arg0
= c
->ext
.actual
;
2204 if (c
->resolved_sym
)
2205 esym
= c
->resolved_sym
;
2207 esym
= c
->symtree
->n
.sym
;
2210 if (!esym
->attr
.elemental
)
2216 /* The rank of an elemental is the rank of its array argument(s). */
2217 for (arg
= arg0
; arg
; arg
= arg
->next
)
2219 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2221 rank
= arg
->expr
->rank
;
2222 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2223 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2224 set_by_optional
= true;
2226 /* Function specific; set the result rank and shape. */
2230 if (!expr
->shape
&& arg
->expr
->shape
)
2232 expr
->shape
= gfc_get_shape (rank
);
2233 for (i
= 0; i
< rank
; i
++)
2234 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2241 /* If it is an array, it shall not be supplied as an actual argument
2242 to an elemental procedure unless an array of the same rank is supplied
2243 as an actual argument corresponding to a nonoptional dummy argument of
2244 that elemental procedure(12.4.1.5). */
2245 formal_optional
= false;
2247 iformal
= isym
->formal
;
2249 eformal
= esym
->formal
;
2251 for (arg
= arg0
; arg
; arg
= arg
->next
)
2255 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2256 formal_optional
= true;
2257 eformal
= eformal
->next
;
2259 else if (isym
&& iformal
)
2261 if (iformal
->optional
)
2262 formal_optional
= true;
2263 iformal
= iformal
->next
;
2266 formal_optional
= true;
2268 if (pedantic
&& arg
->expr
!= NULL
2269 && arg
->expr
->expr_type
== EXPR_VARIABLE
2270 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2273 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2274 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2276 gfc_warning (OPT_Wpedantic
,
2277 "%qs at %L is an array and OPTIONAL; IF IT IS "
2278 "MISSING, it cannot be the actual argument of an "
2279 "ELEMENTAL procedure unless there is a non-optional "
2280 "argument with the same rank (12.4.1.5)",
2281 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2285 for (arg
= arg0
; arg
; arg
= arg
->next
)
2287 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2290 /* Being elemental, the last upper bound of an assumed size array
2291 argument must be present. */
2292 if (resolve_assumed_size_actual (arg
->expr
))
2295 /* Elemental procedure's array actual arguments must conform. */
2298 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2305 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2306 is an array, the intent inout/out variable needs to be also an array. */
2307 if (rank
> 0 && esym
&& expr
== NULL
)
2308 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2309 arg
= arg
->next
, eformal
= eformal
->next
)
2310 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2311 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2312 && arg
->expr
&& arg
->expr
->rank
== 0)
2314 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2315 "ELEMENTAL subroutine %qs is a scalar, but another "
2316 "actual argument is an array", &arg
->expr
->where
,
2317 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2318 : "INOUT", eformal
->sym
->name
, esym
->name
);
2325 /* This function does the checking of references to global procedures
2326 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2327 77 and 95 standards. It checks for a gsymbol for the name, making
2328 one if it does not already exist. If it already exists, then the
2329 reference being resolved must correspond to the type of gsymbol.
2330 Otherwise, the new symbol is equipped with the attributes of the
2331 reference. The corresponding code that is called in creating
2332 global entities is parse.c.
2334 In addition, for all but -std=legacy, the gsymbols are used to
2335 check the interfaces of external procedures from the same file.
2336 The namespace of the gsymbol is resolved and then, once this is
2337 done the interface is checked. */
2341 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2343 if (!gsym_ns
->proc_name
->attr
.recursive
)
2346 if (sym
->ns
== gsym_ns
)
2349 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2356 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2358 if (gsym_ns
->entries
)
2360 gfc_entry_list
*entry
= gsym_ns
->entries
;
2362 for (; entry
; entry
= entry
->next
)
2364 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2366 if (strcmp (gsym_ns
->proc_name
->name
,
2367 sym
->ns
->proc_name
->name
) == 0)
2371 && strcmp (gsym_ns
->proc_name
->name
,
2372 sym
->ns
->parent
->proc_name
->name
) == 0)
2381 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2384 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2386 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2388 for ( ; arg
; arg
= arg
->next
)
2393 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2395 strncpy (errmsg
, _("allocatable argument"), err_len
);
2398 else if (arg
->sym
->attr
.asynchronous
)
2400 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2403 else if (arg
->sym
->attr
.optional
)
2405 strncpy (errmsg
, _("optional argument"), err_len
);
2408 else if (arg
->sym
->attr
.pointer
)
2410 strncpy (errmsg
, _("pointer argument"), err_len
);
2413 else if (arg
->sym
->attr
.target
)
2415 strncpy (errmsg
, _("target argument"), err_len
);
2418 else if (arg
->sym
->attr
.value
)
2420 strncpy (errmsg
, _("value argument"), err_len
);
2423 else if (arg
->sym
->attr
.volatile_
)
2425 strncpy (errmsg
, _("volatile argument"), err_len
);
2428 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2430 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2433 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2435 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2438 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2440 strncpy (errmsg
, _("coarray argument"), err_len
);
2443 else if (false) /* (2d) TODO: parametrized derived type */
2445 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2448 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2450 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2453 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2455 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2458 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2460 /* As assumed-type is unlimited polymorphic (cf. above).
2461 See also TS 29113, Note 6.1. */
2462 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2467 if (sym
->attr
.function
)
2469 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2471 if (res
->attr
.dimension
) /* (3a) */
2473 strncpy (errmsg
, _("array result"), err_len
);
2476 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2478 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2481 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2482 && res
->ts
.u
.cl
->length
2483 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2485 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2490 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2492 strncpy (errmsg
, _("elemental procedure"), err_len
);
2495 else if (sym
->attr
.is_bind_c
) /* (5) */
2497 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2506 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2507 gfc_actual_arglist
**actual
, int sub
)
2511 enum gfc_symbol_type type
;
2514 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2516 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2517 sym
->binding_label
!= NULL
);
2519 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2520 gfc_global_used (gsym
, where
);
2522 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2523 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2524 && gsym
->type
!= GSYM_UNKNOWN
2525 && !gsym
->binding_label
2527 && gsym
->ns
->proc_name
2528 && not_in_recursive (sym
, gsym
->ns
)
2529 && not_entry_self_reference (sym
, gsym
->ns
))
2531 gfc_symbol
*def_sym
;
2532 def_sym
= gsym
->ns
->proc_name
;
2534 if (gsym
->ns
->resolved
!= -1)
2537 /* Resolve the gsymbol namespace if needed. */
2538 if (!gsym
->ns
->resolved
)
2540 gfc_symbol
*old_dt_list
;
2542 /* Stash away derived types so that the backend_decls
2543 do not get mixed up. */
2544 old_dt_list
= gfc_derived_types
;
2545 gfc_derived_types
= NULL
;
2547 gfc_resolve (gsym
->ns
);
2549 /* Store the new derived types with the global namespace. */
2550 if (gfc_derived_types
)
2551 gsym
->ns
->derived_types
= gfc_derived_types
;
2553 /* Restore the derived types of this namespace. */
2554 gfc_derived_types
= old_dt_list
;
2557 /* Make sure that translation for the gsymbol occurs before
2558 the procedure currently being resolved. */
2559 ns
= gfc_global_ns_list
;
2560 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2562 if (ns
->sibling
== gsym
->ns
)
2564 ns
->sibling
= gsym
->ns
->sibling
;
2565 gsym
->ns
->sibling
= gfc_global_ns_list
;
2566 gfc_global_ns_list
= gsym
->ns
;
2571 /* This can happen if a binding name has been specified. */
2572 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2573 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2575 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2577 gfc_entry_list
*entry
;
2578 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2579 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2581 def_sym
= entry
->sym
;
2587 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2589 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2590 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2591 gfc_typename (&def_sym
->ts
));
2595 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2596 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2598 gfc_error ("Explicit interface required for %qs at %L: %s",
2599 sym
->name
, &sym
->declared_at
, reason
);
2603 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2604 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2605 gfc_errors_to_warnings (true);
2607 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2608 reason
, sizeof(reason
), NULL
, NULL
))
2610 gfc_error_opt (OPT_Wargument_mismatch
,
2611 "Interface mismatch in global procedure %qs at %L:"
2612 " %s", sym
->name
, &sym
->declared_at
, reason
);
2617 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2618 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2619 gfc_errors_to_warnings (true);
2621 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2622 gfc_procedure_use (def_sym
, actual
, where
);
2626 gfc_errors_to_warnings (false);
2628 if (gsym
->type
== GSYM_UNKNOWN
)
2631 gsym
->where
= *where
;
2638 /************* Function resolution *************/
2640 /* Resolve a function call known to be generic.
2641 Section 14.1.2.4.1. */
2644 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2648 if (sym
->attr
.generic
)
2650 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2653 expr
->value
.function
.name
= s
->name
;
2654 expr
->value
.function
.esym
= s
;
2656 if (s
->ts
.type
!= BT_UNKNOWN
)
2658 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2659 expr
->ts
= s
->result
->ts
;
2662 expr
->rank
= s
->as
->rank
;
2663 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2664 expr
->rank
= s
->result
->as
->rank
;
2666 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2671 /* TODO: Need to search for elemental references in generic
2675 if (sym
->attr
.intrinsic
)
2676 return gfc_intrinsic_func_interface (expr
, 0);
2683 resolve_generic_f (gfc_expr
*expr
)
2687 gfc_interface
*intr
= NULL
;
2689 sym
= expr
->symtree
->n
.sym
;
2693 m
= resolve_generic_f0 (expr
, sym
);
2696 else if (m
== MATCH_ERROR
)
2701 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2702 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2705 if (sym
->ns
->parent
== NULL
)
2707 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2711 if (!generic_sym (sym
))
2715 /* Last ditch attempt. See if the reference is to an intrinsic
2716 that possesses a matching interface. 14.1.2.4 */
2717 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2719 if (gfc_init_expr_flag
)
2720 gfc_error ("Function %qs in initialization expression at %L "
2721 "must be an intrinsic function",
2722 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2724 gfc_error ("There is no specific function for the generic %qs "
2725 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2731 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2734 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2736 return resolve_structure_cons (expr
, 0);
2739 m
= gfc_intrinsic_func_interface (expr
, 0);
2744 gfc_error ("Generic function %qs at %L is not consistent with a "
2745 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2752 /* Resolve a function call known to be specific. */
2755 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2759 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2761 if (sym
->attr
.dummy
)
2763 sym
->attr
.proc
= PROC_DUMMY
;
2767 sym
->attr
.proc
= PROC_EXTERNAL
;
2771 if (sym
->attr
.proc
== PROC_MODULE
2772 || sym
->attr
.proc
== PROC_ST_FUNCTION
2773 || sym
->attr
.proc
== PROC_INTERNAL
)
2776 if (sym
->attr
.intrinsic
)
2778 m
= gfc_intrinsic_func_interface (expr
, 1);
2782 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2783 "with an intrinsic", sym
->name
, &expr
->where
);
2791 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2794 expr
->ts
= sym
->result
->ts
;
2797 expr
->value
.function
.name
= sym
->name
;
2798 expr
->value
.function
.esym
= sym
;
2799 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2801 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2803 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2804 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2805 else if (sym
->as
!= NULL
)
2806 expr
->rank
= sym
->as
->rank
;
2813 resolve_specific_f (gfc_expr
*expr
)
2818 sym
= expr
->symtree
->n
.sym
;
2822 m
= resolve_specific_f0 (sym
, expr
);
2825 if (m
== MATCH_ERROR
)
2828 if (sym
->ns
->parent
== NULL
)
2831 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2837 gfc_error ("Unable to resolve the specific function %qs at %L",
2838 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2843 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2844 candidates in CANDIDATES_LEN. */
2847 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2849 size_t &candidates_len
)
2855 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2856 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2857 vec_push (candidates
, candidates_len
, sym
->name
);
2861 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2865 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2869 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2872 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2874 char **candidates
= NULL
;
2875 size_t candidates_len
= 0;
2876 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2877 return gfc_closest_fuzzy_match (fn
, candidates
);
2881 /* Resolve a procedure call not known to be generic nor specific. */
2884 resolve_unknown_f (gfc_expr
*expr
)
2889 sym
= expr
->symtree
->n
.sym
;
2891 if (sym
->attr
.dummy
)
2893 sym
->attr
.proc
= PROC_DUMMY
;
2894 expr
->value
.function
.name
= sym
->name
;
2898 /* See if we have an intrinsic function reference. */
2900 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2902 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2907 /* The reference is to an external name. */
2909 sym
->attr
.proc
= PROC_EXTERNAL
;
2910 expr
->value
.function
.name
= sym
->name
;
2911 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2913 if (sym
->as
!= NULL
)
2914 expr
->rank
= sym
->as
->rank
;
2916 /* Type of the expression is either the type of the symbol or the
2917 default type of the symbol. */
2920 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2922 if (sym
->ts
.type
!= BT_UNKNOWN
)
2926 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2928 if (ts
->type
== BT_UNKNOWN
)
2931 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2933 gfc_error ("Function %qs at %L has no IMPLICIT type"
2934 "; did you mean %qs?",
2935 sym
->name
, &expr
->where
, guessed
);
2937 gfc_error ("Function %qs at %L has no IMPLICIT type",
2938 sym
->name
, &expr
->where
);
2949 /* Return true, if the symbol is an external procedure. */
2951 is_external_proc (gfc_symbol
*sym
)
2953 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2954 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2955 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2956 && !sym
->attr
.proc_pointer
2957 && !sym
->attr
.use_assoc
2965 /* Figure out if a function reference is pure or not. Also set the name
2966 of the function for a potential error message. Return nonzero if the
2967 function is PURE, zero if not. */
2969 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2972 gfc_pure_function (gfc_expr
*e
, const char **name
)
2975 gfc_component
*comp
;
2979 if (e
->symtree
!= NULL
2980 && e
->symtree
->n
.sym
!= NULL
2981 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2982 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2984 comp
= gfc_get_proc_ptr_comp (e
);
2987 pure
= gfc_pure (comp
->ts
.interface
);
2990 else if (e
->value
.function
.esym
)
2992 pure
= gfc_pure (e
->value
.function
.esym
);
2993 *name
= e
->value
.function
.esym
->name
;
2995 else if (e
->value
.function
.isym
)
2997 pure
= e
->value
.function
.isym
->pure
2998 || e
->value
.function
.isym
->elemental
;
2999 *name
= e
->value
.function
.isym
->name
;
3003 /* Implicit functions are not pure. */
3005 *name
= e
->value
.function
.name
;
3012 /* Check if the expression is a reference to an implicitly pure function. */
3015 gfc_implicit_pure_function (gfc_expr
*e
)
3017 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3019 return gfc_implicit_pure (comp
->ts
.interface
);
3020 else if (e
->value
.function
.esym
)
3021 return gfc_implicit_pure (e
->value
.function
.esym
);
3028 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3029 int *f ATTRIBUTE_UNUSED
)
3033 /* Don't bother recursing into other statement functions
3034 since they will be checked individually for purity. */
3035 if (e
->expr_type
!= EXPR_FUNCTION
3037 || e
->symtree
->n
.sym
== sym
3038 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3041 return gfc_pure_function (e
, &name
) ? false : true;
3046 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3048 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3052 /* Check if an impure function is allowed in the current context. */
3054 static bool check_pure_function (gfc_expr
*e
)
3056 const char *name
= NULL
;
3057 if (!gfc_pure_function (e
, &name
) && name
)
3061 gfc_error ("Reference to impure function %qs at %L inside a "
3062 "FORALL %s", name
, &e
->where
,
3063 forall_flag
== 2 ? "mask" : "block");
3066 else if (gfc_do_concurrent_flag
)
3068 gfc_error ("Reference to impure function %qs at %L inside a "
3069 "DO CONCURRENT %s", name
, &e
->where
,
3070 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3073 else if (gfc_pure (NULL
))
3075 gfc_error ("Reference to impure function %qs at %L "
3076 "within a PURE procedure", name
, &e
->where
);
3079 if (!gfc_implicit_pure_function (e
))
3080 gfc_unset_implicit_pure (NULL
);
3086 /* Update current procedure's array_outer_dependency flag, considering
3087 a call to procedure SYM. */
3090 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3092 /* Check to see if this is a sibling function that has not yet
3094 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3095 for (; sibling
; sibling
= sibling
->sibling
)
3097 if (sibling
->proc_name
== sym
)
3099 gfc_resolve (sibling
);
3104 /* If SYM has references to outer arrays, so has the procedure calling
3105 SYM. If SYM is a procedure pointer, we can assume the worst. */
3106 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3107 && gfc_current_ns
->proc_name
)
3108 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3112 /* Resolve a function call, which means resolving the arguments, then figuring
3113 out which entity the name refers to. */
3116 resolve_function (gfc_expr
*expr
)
3118 gfc_actual_arglist
*arg
;
3122 procedure_type p
= PROC_INTRINSIC
;
3123 bool no_formal_args
;
3127 sym
= expr
->symtree
->n
.sym
;
3129 /* If this is a procedure pointer component, it has already been resolved. */
3130 if (gfc_is_proc_ptr_comp (expr
))
3133 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3135 if (sym
&& sym
->attr
.intrinsic
3136 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3137 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3140 if (sym
&& sym
->attr
.intrinsic
3141 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3144 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3146 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3150 /* If this is a deferred TBP with an abstract interface (which may
3151 of course be referenced), expr->value.function.esym will be set. */
3152 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3154 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3155 sym
->name
, &expr
->where
);
3159 /* If this is a deferred TBP with an abstract interface, its result
3160 cannot be an assumed length character (F2003: C418). */
3161 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3162 && sym
->result
->ts
.u
.cl
3163 && sym
->result
->ts
.u
.cl
->length
== NULL
3164 && !sym
->result
->ts
.deferred
)
3166 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3167 "character length result (F2008: C418)", sym
->name
,
3172 /* Switch off assumed size checking and do this again for certain kinds
3173 of procedure, once the procedure itself is resolved. */
3174 need_full_assumed_size
++;
3176 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3177 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3179 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3180 inquiry_argument
= true;
3181 no_formal_args
= sym
&& is_external_proc (sym
)
3182 && gfc_sym_get_dummy_args (sym
) == NULL
;
3184 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3187 inquiry_argument
= false;
3191 inquiry_argument
= false;
3193 /* Resume assumed_size checking. */
3194 need_full_assumed_size
--;
3196 /* If the procedure is external, check for usage. */
3197 if (sym
&& is_external_proc (sym
))
3198 resolve_global_procedure (sym
, &expr
->where
,
3199 &expr
->value
.function
.actual
, 0);
3201 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3203 && sym
->ts
.u
.cl
->length
== NULL
3205 && !sym
->ts
.deferred
3206 && expr
->value
.function
.esym
== NULL
3207 && !sym
->attr
.contained
)
3209 /* Internal procedures are taken care of in resolve_contained_fntype. */
3210 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3211 "be used at %L since it is not a dummy argument",
3212 sym
->name
, &expr
->where
);
3216 /* See if function is already resolved. */
3218 if (expr
->value
.function
.name
!= NULL
3219 || expr
->value
.function
.isym
!= NULL
)
3221 if (expr
->ts
.type
== BT_UNKNOWN
)
3227 /* Apply the rules of section 14.1.2. */
3229 switch (procedure_kind (sym
))
3232 t
= resolve_generic_f (expr
);
3235 case PTYPE_SPECIFIC
:
3236 t
= resolve_specific_f (expr
);
3240 t
= resolve_unknown_f (expr
);
3244 gfc_internal_error ("resolve_function(): bad function type");
3248 /* If the expression is still a function (it might have simplified),
3249 then we check to see if we are calling an elemental function. */
3251 if (expr
->expr_type
!= EXPR_FUNCTION
)
3254 temp
= need_full_assumed_size
;
3255 need_full_assumed_size
= 0;
3257 if (!resolve_elemental_actual (expr
, NULL
))
3260 if (omp_workshare_flag
3261 && expr
->value
.function
.esym
3262 && ! gfc_elemental (expr
->value
.function
.esym
))
3264 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3265 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3270 #define GENERIC_ID expr->value.function.isym->id
3271 else if (expr
->value
.function
.actual
!= NULL
3272 && expr
->value
.function
.isym
!= NULL
3273 && GENERIC_ID
!= GFC_ISYM_LBOUND
3274 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3275 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3276 && GENERIC_ID
!= GFC_ISYM_LEN
3277 && GENERIC_ID
!= GFC_ISYM_LOC
3278 && GENERIC_ID
!= GFC_ISYM_C_LOC
3279 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3281 /* Array intrinsics must also have the last upper bound of an
3282 assumed size array argument. UBOUND and SIZE have to be
3283 excluded from the check if the second argument is anything
3286 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3288 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3289 && arg
== expr
->value
.function
.actual
3290 && arg
->next
!= NULL
&& arg
->next
->expr
)
3292 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3295 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3298 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3303 if (arg
->expr
!= NULL
3304 && arg
->expr
->rank
> 0
3305 && resolve_assumed_size_actual (arg
->expr
))
3311 need_full_assumed_size
= temp
;
3313 if (!check_pure_function(expr
))
3316 /* Functions without the RECURSIVE attribution are not allowed to
3317 * call themselves. */
3318 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3321 esym
= expr
->value
.function
.esym
;
3323 if (is_illegal_recursion (esym
, gfc_current_ns
))
3325 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3326 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3327 " function %qs is not RECURSIVE",
3328 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3330 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3331 " is not RECURSIVE", esym
->name
, &expr
->where
);
3337 /* Character lengths of use associated functions may contains references to
3338 symbols not referenced from the current program unit otherwise. Make sure
3339 those symbols are marked as referenced. */
3341 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3342 && expr
->value
.function
.esym
->attr
.use_assoc
)
3344 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3347 /* Make sure that the expression has a typespec that works. */
3348 if (expr
->ts
.type
== BT_UNKNOWN
)
3350 if (expr
->symtree
->n
.sym
->result
3351 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3352 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3353 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3356 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3358 if (expr
->value
.function
.esym
)
3359 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3361 update_current_proc_array_outer_dependency (sym
);
3364 /* typebound procedure: Assume the worst. */
3365 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3371 /************* Subroutine resolution *************/
3374 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3381 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3385 else if (gfc_do_concurrent_flag
)
3387 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3391 else if (gfc_pure (NULL
))
3393 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3397 gfc_unset_implicit_pure (NULL
);
3403 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3407 if (sym
->attr
.generic
)
3409 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3412 c
->resolved_sym
= s
;
3413 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3418 /* TODO: Need to search for elemental references in generic interface. */
3421 if (sym
->attr
.intrinsic
)
3422 return gfc_intrinsic_sub_interface (c
, 0);
3429 resolve_generic_s (gfc_code
*c
)
3434 sym
= c
->symtree
->n
.sym
;
3438 m
= resolve_generic_s0 (c
, sym
);
3441 else if (m
== MATCH_ERROR
)
3445 if (sym
->ns
->parent
== NULL
)
3447 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3451 if (!generic_sym (sym
))
3455 /* Last ditch attempt. See if the reference is to an intrinsic
3456 that possesses a matching interface. 14.1.2.4 */
3457 sym
= c
->symtree
->n
.sym
;
3459 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3461 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3462 sym
->name
, &c
->loc
);
3466 m
= gfc_intrinsic_sub_interface (c
, 0);
3470 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3471 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3477 /* Resolve a subroutine call known to be specific. */
3480 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3484 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3486 if (sym
->attr
.dummy
)
3488 sym
->attr
.proc
= PROC_DUMMY
;
3492 sym
->attr
.proc
= PROC_EXTERNAL
;
3496 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3499 if (sym
->attr
.intrinsic
)
3501 m
= gfc_intrinsic_sub_interface (c
, 1);
3505 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3506 "with an intrinsic", sym
->name
, &c
->loc
);
3514 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3516 c
->resolved_sym
= sym
;
3517 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3525 resolve_specific_s (gfc_code
*c
)
3530 sym
= c
->symtree
->n
.sym
;
3534 m
= resolve_specific_s0 (c
, sym
);
3537 if (m
== MATCH_ERROR
)
3540 if (sym
->ns
->parent
== NULL
)
3543 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3549 sym
= c
->symtree
->n
.sym
;
3550 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3551 sym
->name
, &c
->loc
);
3557 /* Resolve a subroutine call not known to be generic nor specific. */
3560 resolve_unknown_s (gfc_code
*c
)
3564 sym
= c
->symtree
->n
.sym
;
3566 if (sym
->attr
.dummy
)
3568 sym
->attr
.proc
= PROC_DUMMY
;
3572 /* See if we have an intrinsic function reference. */
3574 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3576 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3581 /* The reference is to an external name. */
3584 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3586 c
->resolved_sym
= sym
;
3588 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3592 /* Resolve a subroutine call. Although it was tempting to use the same code
3593 for functions, subroutines and functions are stored differently and this
3594 makes things awkward. */
3597 resolve_call (gfc_code
*c
)
3600 procedure_type ptype
= PROC_INTRINSIC
;
3601 gfc_symbol
*csym
, *sym
;
3602 bool no_formal_args
;
3604 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3606 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3608 gfc_error ("%qs at %L has a type, which is not consistent with "
3609 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3613 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3616 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3617 sym
= st
? st
->n
.sym
: NULL
;
3618 if (sym
&& csym
!= sym
3619 && sym
->ns
== gfc_current_ns
3620 && sym
->attr
.flavor
== FL_PROCEDURE
3621 && sym
->attr
.contained
)
3624 if (csym
->attr
.generic
)
3625 c
->symtree
->n
.sym
= sym
;
3628 csym
= c
->symtree
->n
.sym
;
3632 /* If this ia a deferred TBP, c->expr1 will be set. */
3633 if (!c
->expr1
&& csym
)
3635 if (csym
->attr
.abstract
)
3637 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3638 csym
->name
, &c
->loc
);
3642 /* Subroutines without the RECURSIVE attribution are not allowed to
3644 if (is_illegal_recursion (csym
, gfc_current_ns
))
3646 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3647 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3648 "as subroutine %qs is not RECURSIVE",
3649 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3651 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3652 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3658 /* Switch off assumed size checking and do this again for certain kinds
3659 of procedure, once the procedure itself is resolved. */
3660 need_full_assumed_size
++;
3663 ptype
= csym
->attr
.proc
;
3665 no_formal_args
= csym
&& is_external_proc (csym
)
3666 && gfc_sym_get_dummy_args (csym
) == NULL
;
3667 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3670 /* Resume assumed_size checking. */
3671 need_full_assumed_size
--;
3673 /* If external, check for usage. */
3674 if (csym
&& is_external_proc (csym
))
3675 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3678 if (c
->resolved_sym
== NULL
)
3680 c
->resolved_isym
= NULL
;
3681 switch (procedure_kind (csym
))
3684 t
= resolve_generic_s (c
);
3687 case PTYPE_SPECIFIC
:
3688 t
= resolve_specific_s (c
);
3692 t
= resolve_unknown_s (c
);
3696 gfc_internal_error ("resolve_subroutine(): bad function type");
3700 /* Some checks of elemental subroutine actual arguments. */
3701 if (!resolve_elemental_actual (NULL
, c
))
3705 update_current_proc_array_outer_dependency (csym
);
3707 /* Typebound procedure: Assume the worst. */
3708 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3714 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3715 op1->shape and op2->shape are non-NULL return true if their shapes
3716 match. If both op1->shape and op2->shape are non-NULL return false
3717 if their shapes do not match. If either op1->shape or op2->shape is
3718 NULL, return true. */
3721 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3728 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3730 for (i
= 0; i
< op1
->rank
; i
++)
3732 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3734 gfc_error ("Shapes for operands at %L and %L are not conformable",
3735 &op1
->where
, &op2
->where
);
3745 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3746 For example A .AND. B becomes IAND(A, B). */
3748 logical_to_bitwise (gfc_expr
*e
)
3750 gfc_expr
*tmp
, *op1
, *op2
;
3752 gfc_actual_arglist
*args
= NULL
;
3754 gcc_assert (e
->expr_type
== EXPR_OP
);
3756 isym
= GFC_ISYM_NONE
;
3757 op1
= e
->value
.op
.op1
;
3758 op2
= e
->value
.op
.op2
;
3760 switch (e
->value
.op
.op
)
3763 isym
= GFC_ISYM_NOT
;
3766 isym
= GFC_ISYM_IAND
;
3769 isym
= GFC_ISYM_IOR
;
3771 case INTRINSIC_NEQV
:
3772 isym
= GFC_ISYM_IEOR
;
3775 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3776 Change the old expression to NEQV, which will get replaced by IEOR,
3777 and wrap it in NOT. */
3778 tmp
= gfc_copy_expr (e
);
3779 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3780 tmp
= logical_to_bitwise (tmp
);
3781 isym
= GFC_ISYM_NOT
;
3786 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3789 /* Inherit the original operation's operands as arguments. */
3790 args
= gfc_get_actual_arglist ();
3794 args
->next
= gfc_get_actual_arglist ();
3795 args
->next
->expr
= op2
;
3798 /* Convert the expression to a function call. */
3799 e
->expr_type
= EXPR_FUNCTION
;
3800 e
->value
.function
.actual
= args
;
3801 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3802 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3803 e
->value
.function
.esym
= NULL
;
3805 /* Make up a pre-resolved function call symtree if we need to. */
3806 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3809 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3810 sym
= e
->symtree
->n
.sym
;
3812 sym
->attr
.flavor
= FL_PROCEDURE
;
3813 sym
->attr
.function
= 1;
3814 sym
->attr
.elemental
= 1;
3816 sym
->attr
.referenced
= 1;
3817 gfc_intrinsic_symbol (sym
);
3818 gfc_commit_symbol (sym
);
3821 args
->name
= e
->value
.function
.isym
->formal
->name
;
3822 if (e
->value
.function
.isym
->formal
->next
)
3823 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3828 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3829 candidates in CANDIDATES_LEN. */
3831 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3833 size_t &candidates_len
)
3840 /* Not sure how to properly filter here. Use all for a start.
3841 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3842 these as i suppose they don't make terribly sense. */
3844 if (uop
->n
.uop
->op
!= NULL
)
3845 vec_push (candidates
, candidates_len
, uop
->name
);
3849 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3853 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3856 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3859 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3861 char **candidates
= NULL
;
3862 size_t candidates_len
= 0;
3863 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3864 return gfc_closest_fuzzy_match (op
, candidates
);
3868 /* Callback finding an impure function as an operand to an .and. or
3869 .or. expression. Remember the last function warned about to
3870 avoid double warnings when recursing. */
3873 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3878 static gfc_expr
*last
= NULL
;
3879 bool *found
= (bool *) data
;
3881 if (f
->expr_type
== EXPR_FUNCTION
)
3884 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3885 && !gfc_implicit_pure_function (f
))
3888 gfc_warning (OPT_Wfunction_elimination
,
3889 "Impure function %qs at %L might not be evaluated",
3892 gfc_warning (OPT_Wfunction_elimination
,
3893 "Impure function at %L might not be evaluated",
3903 /* Resolve an operator expression node. This can involve replacing the
3904 operation with a user defined function call. */
3907 resolve_operator (gfc_expr
*e
)
3909 gfc_expr
*op1
, *op2
;
3911 bool dual_locus_error
;
3914 /* Resolve all subnodes-- give them types. */
3916 switch (e
->value
.op
.op
)
3919 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3925 case INTRINSIC_UPLUS
:
3926 case INTRINSIC_UMINUS
:
3927 case INTRINSIC_PARENTHESES
:
3928 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3933 /* Typecheck the new node. */
3935 op1
= e
->value
.op
.op1
;
3936 op2
= e
->value
.op
.op2
;
3937 dual_locus_error
= false;
3939 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3940 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3942 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3946 switch (e
->value
.op
.op
)
3948 case INTRINSIC_UPLUS
:
3949 case INTRINSIC_UMINUS
:
3950 if (op1
->ts
.type
== BT_INTEGER
3951 || op1
->ts
.type
== BT_REAL
3952 || op1
->ts
.type
== BT_COMPLEX
)
3958 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3959 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3962 case INTRINSIC_PLUS
:
3963 case INTRINSIC_MINUS
:
3964 case INTRINSIC_TIMES
:
3965 case INTRINSIC_DIVIDE
:
3966 case INTRINSIC_POWER
:
3967 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3969 gfc_type_convert_binary (e
, 1);
3973 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3975 _("Unexpected derived-type entities in binary intrinsic "
3976 "numeric operator %%<%s%%> at %%L"),
3977 gfc_op2string (e
->value
.op
.op
));
3980 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3981 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3982 gfc_typename (&op2
->ts
));
3985 case INTRINSIC_CONCAT
:
3986 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3987 && op1
->ts
.kind
== op2
->ts
.kind
)
3989 e
->ts
.type
= BT_CHARACTER
;
3990 e
->ts
.kind
= op1
->ts
.kind
;
3995 _("Operands of string concatenation operator at %%L are %s/%s"),
3996 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
4002 case INTRINSIC_NEQV
:
4003 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4005 e
->ts
.type
= BT_LOGICAL
;
4006 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4007 if (op1
->ts
.kind
< e
->ts
.kind
)
4008 gfc_convert_type (op1
, &e
->ts
, 2);
4009 else if (op2
->ts
.kind
< e
->ts
.kind
)
4010 gfc_convert_type (op2
, &e
->ts
, 2);
4012 if (flag_frontend_optimize
&&
4013 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4015 /* Warn about short-circuiting
4016 with impure function as second operand. */
4018 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4023 /* Logical ops on integers become bitwise ops with -fdec. */
4025 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4027 e
->ts
.type
= BT_INTEGER
;
4028 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4029 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4030 gfc_convert_type (op1
, &e
->ts
, 1);
4031 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4032 gfc_convert_type (op2
, &e
->ts
, 1);
4033 e
= logical_to_bitwise (e
);
4037 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4038 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4039 gfc_typename (&op2
->ts
));
4044 /* Logical ops on integers become bitwise ops with -fdec. */
4045 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4047 e
->ts
.type
= BT_INTEGER
;
4048 e
->ts
.kind
= op1
->ts
.kind
;
4049 e
= logical_to_bitwise (e
);
4053 if (op1
->ts
.type
== BT_LOGICAL
)
4055 e
->ts
.type
= BT_LOGICAL
;
4056 e
->ts
.kind
= op1
->ts
.kind
;
4060 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4061 gfc_typename (&op1
->ts
));
4065 case INTRINSIC_GT_OS
:
4067 case INTRINSIC_GE_OS
:
4069 case INTRINSIC_LT_OS
:
4071 case INTRINSIC_LE_OS
:
4072 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4074 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4081 case INTRINSIC_EQ_OS
:
4083 case INTRINSIC_NE_OS
:
4084 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4085 && op1
->ts
.kind
== op2
->ts
.kind
)
4087 e
->ts
.type
= BT_LOGICAL
;
4088 e
->ts
.kind
= gfc_default_logical_kind
;
4092 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4094 gfc_type_convert_binary (e
, 1);
4096 e
->ts
.type
= BT_LOGICAL
;
4097 e
->ts
.kind
= gfc_default_logical_kind
;
4099 if (warn_compare_reals
)
4101 gfc_intrinsic_op op
= e
->value
.op
.op
;
4103 /* Type conversion has made sure that the types of op1 and op2
4104 agree, so it is only necessary to check the first one. */
4105 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4106 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4107 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4111 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4112 msg
= "Equality comparison for %s at %L";
4114 msg
= "Inequality comparison for %s at %L";
4116 gfc_warning (OPT_Wcompare_reals
, msg
,
4117 gfc_typename (&op1
->ts
), &op1
->where
);
4124 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4126 _("Logicals at %%L must be compared with %s instead of %s"),
4127 (e
->value
.op
.op
== INTRINSIC_EQ
4128 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4129 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4132 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4133 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4134 gfc_typename (&op2
->ts
));
4138 case INTRINSIC_USER
:
4139 if (e
->value
.op
.uop
->op
== NULL
)
4141 const char *name
= e
->value
.op
.uop
->name
;
4142 const char *guessed
;
4143 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4145 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4148 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4150 else if (op2
== NULL
)
4151 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4152 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4155 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4156 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4157 gfc_typename (&op2
->ts
));
4158 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4163 case INTRINSIC_PARENTHESES
:
4165 if (e
->ts
.type
== BT_CHARACTER
)
4166 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4170 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4173 /* Deal with arrayness of an operand through an operator. */
4175 switch (e
->value
.op
.op
)
4177 case INTRINSIC_PLUS
:
4178 case INTRINSIC_MINUS
:
4179 case INTRINSIC_TIMES
:
4180 case INTRINSIC_DIVIDE
:
4181 case INTRINSIC_POWER
:
4182 case INTRINSIC_CONCAT
:
4186 case INTRINSIC_NEQV
:
4188 case INTRINSIC_EQ_OS
:
4190 case INTRINSIC_NE_OS
:
4192 case INTRINSIC_GT_OS
:
4194 case INTRINSIC_GE_OS
:
4196 case INTRINSIC_LT_OS
:
4198 case INTRINSIC_LE_OS
:
4200 if (op1
->rank
== 0 && op2
->rank
== 0)
4203 if (op1
->rank
== 0 && op2
->rank
!= 0)
4205 e
->rank
= op2
->rank
;
4207 if (e
->shape
== NULL
)
4208 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4211 if (op1
->rank
!= 0 && op2
->rank
== 0)
4213 e
->rank
= op1
->rank
;
4215 if (e
->shape
== NULL
)
4216 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4219 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4221 if (op1
->rank
== op2
->rank
)
4223 e
->rank
= op1
->rank
;
4224 if (e
->shape
== NULL
)
4226 t
= compare_shapes (op1
, op2
);
4230 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4235 /* Allow higher level expressions to work. */
4238 /* Try user-defined operators, and otherwise throw an error. */
4239 dual_locus_error
= true;
4241 _("Inconsistent ranks for operator at %%L and %%L"));
4248 case INTRINSIC_PARENTHESES
:
4250 case INTRINSIC_UPLUS
:
4251 case INTRINSIC_UMINUS
:
4252 /* Simply copy arrayness attribute */
4253 e
->rank
= op1
->rank
;
4255 if (e
->shape
== NULL
)
4256 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4266 /* Attempt to simplify the expression. */
4269 t
= gfc_simplify_expr (e
, 0);
4270 /* Some calls do not succeed in simplification and return false
4271 even though there is no error; e.g. variable references to
4272 PARAMETER arrays. */
4273 if (!gfc_is_constant_expr (e
))
4281 match m
= gfc_extend_expr (e
);
4284 if (m
== MATCH_ERROR
)
4288 if (dual_locus_error
)
4289 gfc_error (msg
, &op1
->where
, &op2
->where
);
4291 gfc_error (msg
, &e
->where
);
4297 /************** Array resolution subroutines **************/
4300 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4302 /* Compare two integer expressions. */
4304 static compare_result
4305 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4309 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4310 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4313 /* If either of the types isn't INTEGER, we must have
4314 raised an error earlier. */
4316 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4319 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4329 /* Compare an integer expression with an integer. */
4331 static compare_result
4332 compare_bound_int (gfc_expr
*a
, int b
)
4336 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4339 if (a
->ts
.type
!= BT_INTEGER
)
4340 gfc_internal_error ("compare_bound_int(): Bad expression");
4342 i
= mpz_cmp_si (a
->value
.integer
, b
);
4352 /* Compare an integer expression with a mpz_t. */
4354 static compare_result
4355 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4359 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4362 if (a
->ts
.type
!= BT_INTEGER
)
4363 gfc_internal_error ("compare_bound_int(): Bad expression");
4365 i
= mpz_cmp (a
->value
.integer
, b
);
4375 /* Compute the last value of a sequence given by a triplet.
4376 Return 0 if it wasn't able to compute the last value, or if the
4377 sequence if empty, and 1 otherwise. */
4380 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4381 gfc_expr
*stride
, mpz_t last
)
4385 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4386 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4387 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4390 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4391 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4394 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4396 if (compare_bound (start
, end
) == CMP_GT
)
4398 mpz_set (last
, end
->value
.integer
);
4402 if (compare_bound_int (stride
, 0) == CMP_GT
)
4404 /* Stride is positive */
4405 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4410 /* Stride is negative */
4411 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4416 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4417 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4418 mpz_sub (last
, end
->value
.integer
, rem
);
4425 /* Compare a single dimension of an array reference to the array
4429 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4433 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4435 gcc_assert (ar
->stride
[i
] == NULL
);
4436 /* This implies [*] as [*:] and [*:3] are not possible. */
4437 if (ar
->start
[i
] == NULL
)
4439 gcc_assert (ar
->end
[i
] == NULL
);
4444 /* Given start, end and stride values, calculate the minimum and
4445 maximum referenced indexes. */
4447 switch (ar
->dimen_type
[i
])
4450 case DIMEN_THIS_IMAGE
:
4455 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4458 gfc_warning (0, "Array reference at %L is out of bounds "
4459 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4460 mpz_get_si (ar
->start
[i
]->value
.integer
),
4461 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4463 gfc_warning (0, "Array reference at %L is out of bounds "
4464 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4465 mpz_get_si (ar
->start
[i
]->value
.integer
),
4466 mpz_get_si (as
->lower
[i
]->value
.integer
),
4470 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4473 gfc_warning (0, "Array reference at %L is out of bounds "
4474 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4475 mpz_get_si (ar
->start
[i
]->value
.integer
),
4476 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4478 gfc_warning (0, "Array reference at %L is out of bounds "
4479 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4480 mpz_get_si (ar
->start
[i
]->value
.integer
),
4481 mpz_get_si (as
->upper
[i
]->value
.integer
),
4490 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4491 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4493 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4495 /* Check for zero stride, which is not allowed. */
4496 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4498 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4502 /* if start == len || (stride > 0 && start < len)
4503 || (stride < 0 && start > len),
4504 then the array section contains at least one element. In this
4505 case, there is an out-of-bounds access if
4506 (start < lower || start > upper). */
4507 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4508 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4509 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4510 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4511 && comp_start_end
== CMP_GT
))
4513 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4515 gfc_warning (0, "Lower array reference at %L is out of bounds "
4516 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4517 mpz_get_si (AR_START
->value
.integer
),
4518 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4521 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4523 gfc_warning (0, "Lower array reference at %L is out of bounds "
4524 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4525 mpz_get_si (AR_START
->value
.integer
),
4526 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4531 /* If we can compute the highest index of the array section,
4532 then it also has to be between lower and upper. */
4533 mpz_init (last_value
);
4534 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4537 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4539 gfc_warning (0, "Upper array reference at %L is out of bounds "
4540 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4541 mpz_get_si (last_value
),
4542 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4543 mpz_clear (last_value
);
4546 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4548 gfc_warning (0, "Upper array reference at %L is out of bounds "
4549 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4550 mpz_get_si (last_value
),
4551 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4552 mpz_clear (last_value
);
4556 mpz_clear (last_value
);
4564 gfc_internal_error ("check_dimension(): Bad array reference");
4571 /* Compare an array reference with an array specification. */
4574 compare_spec_to_ref (gfc_array_ref
*ar
)
4581 /* TODO: Full array sections are only allowed as actual parameters. */
4582 if (as
->type
== AS_ASSUMED_SIZE
4583 && (/*ar->type == AR_FULL
4584 ||*/ (ar
->type
== AR_SECTION
4585 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4587 gfc_error ("Rightmost upper bound of assumed size array section "
4588 "not specified at %L", &ar
->where
);
4592 if (ar
->type
== AR_FULL
)
4595 if (as
->rank
!= ar
->dimen
)
4597 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4598 &ar
->where
, ar
->dimen
, as
->rank
);
4602 /* ar->codimen == 0 is a local array. */
4603 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4605 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4606 &ar
->where
, ar
->codimen
, as
->corank
);
4610 for (i
= 0; i
< as
->rank
; i
++)
4611 if (!check_dimension (i
, ar
, as
))
4614 /* Local access has no coarray spec. */
4615 if (ar
->codimen
!= 0)
4616 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4618 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4619 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4621 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4622 i
+ 1 - as
->rank
, &ar
->where
);
4625 if (!check_dimension (i
, ar
, as
))
4633 /* Resolve one part of an array index. */
4636 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4637 int force_index_integer_kind
)
4644 if (!gfc_resolve_expr (index
))
4647 if (check_scalar
&& index
->rank
!= 0)
4649 gfc_error ("Array index at %L must be scalar", &index
->where
);
4653 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4655 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4656 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4660 if (index
->ts
.type
== BT_REAL
)
4661 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4665 if ((index
->ts
.kind
!= gfc_index_integer_kind
4666 && force_index_integer_kind
)
4667 || index
->ts
.type
!= BT_INTEGER
)
4670 ts
.type
= BT_INTEGER
;
4671 ts
.kind
= gfc_index_integer_kind
;
4673 gfc_convert_type_warn (index
, &ts
, 2, 0);
4679 /* Resolve one part of an array index. */
4682 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4684 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4687 /* Resolve a dim argument to an intrinsic function. */
4690 gfc_resolve_dim_arg (gfc_expr
*dim
)
4695 if (!gfc_resolve_expr (dim
))
4700 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4705 if (dim
->ts
.type
!= BT_INTEGER
)
4707 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4711 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4716 ts
.type
= BT_INTEGER
;
4717 ts
.kind
= gfc_index_integer_kind
;
4719 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4725 /* Given an expression that contains array references, update those array
4726 references to point to the right array specifications. While this is
4727 filled in during matching, this information is difficult to save and load
4728 in a module, so we take care of it here.
4730 The idea here is that the original array reference comes from the
4731 base symbol. We traverse the list of reference structures, setting
4732 the stored reference to references. Component references can
4733 provide an additional array specification. */
4736 find_array_spec (gfc_expr
*e
)
4741 bool class_as
= false;
4743 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4745 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4749 as
= e
->symtree
->n
.sym
->as
;
4751 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4756 gfc_internal_error ("find_array_spec(): Missing spec");
4763 c
= ref
->u
.c
.component
;
4764 if (c
->attr
.dimension
)
4766 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4767 gfc_internal_error ("find_array_spec(): unused as(1)");
4779 gfc_internal_error ("find_array_spec(): unused as(2)");
4783 /* Resolve an array reference. */
4786 resolve_array_ref (gfc_array_ref
*ar
)
4788 int i
, check_scalar
;
4791 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4793 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4795 /* Do not force gfc_index_integer_kind for the start. We can
4796 do fine with any integer kind. This avoids temporary arrays
4797 created for indexing with a vector. */
4798 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4800 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4802 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4807 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4811 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4815 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4816 if (e
->expr_type
== EXPR_VARIABLE
4817 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4818 ar
->start
[i
] = gfc_get_parentheses (e
);
4822 gfc_error ("Array index at %L is an array of rank %d",
4823 &ar
->c_where
[i
], e
->rank
);
4827 /* Fill in the upper bound, which may be lower than the
4828 specified one for something like a(2:10:5), which is
4829 identical to a(2:7:5). Only relevant for strides not equal
4830 to one. Don't try a division by zero. */
4831 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4832 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4833 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4834 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4838 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4840 if (ar
->end
[i
] == NULL
)
4843 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4845 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4847 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4848 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4850 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4861 if (ar
->type
== AR_FULL
)
4863 if (ar
->as
->rank
== 0)
4864 ar
->type
= AR_ELEMENT
;
4866 /* Make sure array is the same as array(:,:), this way
4867 we don't need to special case all the time. */
4868 ar
->dimen
= ar
->as
->rank
;
4869 for (i
= 0; i
< ar
->dimen
; i
++)
4871 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4873 gcc_assert (ar
->start
[i
] == NULL
);
4874 gcc_assert (ar
->end
[i
] == NULL
);
4875 gcc_assert (ar
->stride
[i
] == NULL
);
4879 /* If the reference type is unknown, figure out what kind it is. */
4881 if (ar
->type
== AR_UNKNOWN
)
4883 ar
->type
= AR_ELEMENT
;
4884 for (i
= 0; i
< ar
->dimen
; i
++)
4885 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4886 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4888 ar
->type
= AR_SECTION
;
4893 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4896 if (ar
->as
->corank
&& ar
->codimen
== 0)
4899 ar
->codimen
= ar
->as
->corank
;
4900 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4901 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4909 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4911 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4913 if (ref
->u
.ss
.start
!= NULL
)
4915 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4918 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4920 gfc_error ("Substring start index at %L must be of type INTEGER",
4921 &ref
->u
.ss
.start
->where
);
4925 if (ref
->u
.ss
.start
->rank
!= 0)
4927 gfc_error ("Substring start index at %L must be scalar",
4928 &ref
->u
.ss
.start
->where
);
4932 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4933 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4934 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4936 gfc_error ("Substring start index at %L is less than one",
4937 &ref
->u
.ss
.start
->where
);
4942 if (ref
->u
.ss
.end
!= NULL
)
4944 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4947 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4949 gfc_error ("Substring end index at %L must be of type INTEGER",
4950 &ref
->u
.ss
.end
->where
);
4954 if (ref
->u
.ss
.end
->rank
!= 0)
4956 gfc_error ("Substring end index at %L must be scalar",
4957 &ref
->u
.ss
.end
->where
);
4961 if (ref
->u
.ss
.length
!= NULL
4962 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4963 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4964 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4966 gfc_error ("Substring end index at %L exceeds the string length",
4967 &ref
->u
.ss
.start
->where
);
4971 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4972 gfc_integer_kinds
[k
].huge
) == CMP_GT
4973 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4974 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4976 gfc_error ("Substring end index at %L is too large",
4977 &ref
->u
.ss
.end
->where
);
4980 /* If the substring has the same length as the original
4981 variable, the reference itself can be deleted. */
4983 if (ref
->u
.ss
.length
!= NULL
4984 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
4985 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
4986 *equal_length
= true;
4993 /* This function supplies missing substring charlens. */
4996 gfc_resolve_substring_charlen (gfc_expr
*e
)
4999 gfc_expr
*start
, *end
;
5000 gfc_typespec
*ts
= NULL
;
5003 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5005 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5007 if (char_ref
->type
== REF_COMPONENT
)
5008 ts
= &char_ref
->u
.c
.component
->ts
;
5011 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5014 gcc_assert (char_ref
->next
== NULL
);
5018 if (e
->ts
.u
.cl
->length
)
5019 gfc_free_expr (e
->ts
.u
.cl
->length
);
5020 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5024 e
->ts
.type
= BT_CHARACTER
;
5025 e
->ts
.kind
= gfc_default_character_kind
;
5028 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5030 if (char_ref
->u
.ss
.start
)
5031 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5033 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5035 if (char_ref
->u
.ss
.end
)
5036 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5037 else if (e
->expr_type
== EXPR_VARIABLE
)
5040 ts
= &e
->symtree
->n
.sym
->ts
;
5041 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5048 gfc_free_expr (start
);
5049 gfc_free_expr (end
);
5053 /* Length = (end - start + 1).
5054 Check first whether it has a constant length. */
5055 if (gfc_dep_difference (end
, start
, &diff
))
5057 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5060 mpz_add_ui (len
->value
.integer
, diff
, 1);
5062 e
->ts
.u
.cl
->length
= len
;
5063 /* The check for length < 0 is handled below */
5067 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5068 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5069 gfc_get_int_expr (gfc_charlen_int_kind
,
5073 /* F2008, 6.4.1: Both the starting point and the ending point shall
5074 be within the range 1, 2, ..., n unless the starting point exceeds
5075 the ending point, in which case the substring has length zero. */
5077 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5078 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5080 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5081 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5083 /* Make sure that the length is simplified. */
5084 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5085 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5089 /* Resolve subtype references. */
5092 resolve_ref (gfc_expr
*expr
)
5094 int current_part_dimension
, n_components
, seen_part_dimension
;
5095 gfc_ref
*ref
, **prev
;
5098 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5099 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5101 find_array_spec (expr
);
5105 for (prev
= &expr
->ref
; *prev
!= NULL
;
5106 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5107 switch ((*prev
)->type
)
5110 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5119 equal_length
= false;
5120 if (!resolve_substring (*prev
, &equal_length
))
5123 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5125 /* Remove the reference and move the charlen, if any. */
5129 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5130 ref
->u
.ss
.length
= NULL
;
5131 gfc_free_ref_list (ref
);
5136 /* Check constraints on part references. */
5138 current_part_dimension
= 0;
5139 seen_part_dimension
= 0;
5142 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5147 switch (ref
->u
.ar
.type
)
5150 /* Coarray scalar. */
5151 if (ref
->u
.ar
.as
->rank
== 0)
5153 current_part_dimension
= 0;
5158 current_part_dimension
= 1;
5162 current_part_dimension
= 0;
5166 gfc_internal_error ("resolve_ref(): Bad array reference");
5172 if (current_part_dimension
|| seen_part_dimension
)
5175 if (ref
->u
.c
.component
->attr
.pointer
5176 || ref
->u
.c
.component
->attr
.proc_pointer
5177 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5178 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5180 gfc_error ("Component to the right of a part reference "
5181 "with nonzero rank must not have the POINTER "
5182 "attribute at %L", &expr
->where
);
5185 else if (ref
->u
.c
.component
->attr
.allocatable
5186 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5187 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5190 gfc_error ("Component to the right of a part reference "
5191 "with nonzero rank must not have the ALLOCATABLE "
5192 "attribute at %L", &expr
->where
);
5205 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5206 || ref
->next
== NULL
)
5207 && current_part_dimension
5208 && seen_part_dimension
)
5210 gfc_error ("Two or more part references with nonzero rank must "
5211 "not be specified at %L", &expr
->where
);
5215 if (ref
->type
== REF_COMPONENT
)
5217 if (current_part_dimension
)
5218 seen_part_dimension
= 1;
5220 /* reset to make sure */
5221 current_part_dimension
= 0;
5229 /* Given an expression, determine its shape. This is easier than it sounds.
5230 Leaves the shape array NULL if it is not possible to determine the shape. */
5233 expression_shape (gfc_expr
*e
)
5235 mpz_t array
[GFC_MAX_DIMENSIONS
];
5238 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5241 for (i
= 0; i
< e
->rank
; i
++)
5242 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5245 e
->shape
= gfc_get_shape (e
->rank
);
5247 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5252 for (i
--; i
>= 0; i
--)
5253 mpz_clear (array
[i
]);
5257 /* Given a variable expression node, compute the rank of the expression by
5258 examining the base symbol and any reference structures it may have. */
5261 expression_rank (gfc_expr
*e
)
5266 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5267 could lead to serious confusion... */
5268 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5272 if (e
->expr_type
== EXPR_ARRAY
)
5274 /* Constructors can have a rank different from one via RESHAPE(). */
5276 if (e
->symtree
== NULL
)
5282 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5283 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5289 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5291 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5292 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5293 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5295 if (ref
->type
!= REF_ARRAY
)
5298 if (ref
->u
.ar
.type
== AR_FULL
)
5300 rank
= ref
->u
.ar
.as
->rank
;
5304 if (ref
->u
.ar
.type
== AR_SECTION
)
5306 /* Figure out the rank of the section. */
5308 gfc_internal_error ("expression_rank(): Two array specs");
5310 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5311 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5312 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5322 expression_shape (e
);
5327 add_caf_get_intrinsic (gfc_expr
*e
)
5329 gfc_expr
*wrapper
, *tmp_expr
;
5333 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5334 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5339 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5340 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5343 tmp_expr
= XCNEW (gfc_expr
);
5345 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5346 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5347 wrapper
->ts
= e
->ts
;
5348 wrapper
->rank
= e
->rank
;
5350 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5357 remove_caf_get_intrinsic (gfc_expr
*e
)
5359 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5360 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5361 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5362 e
->value
.function
.actual
->expr
= NULL
;
5363 gfc_free_actual_arglist (e
->value
.function
.actual
);
5364 gfc_free_shape (&e
->shape
, e
->rank
);
5370 /* Resolve a variable expression. */
5373 resolve_variable (gfc_expr
*e
)
5380 if (e
->symtree
== NULL
)
5382 sym
= e
->symtree
->n
.sym
;
5384 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5385 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5386 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5388 if (!actual_arg
|| inquiry_argument
)
5390 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5391 "be used as actual argument", sym
->name
, &e
->where
);
5395 /* TS 29113, 407b. */
5396 else if (e
->ts
.type
== BT_ASSUMED
)
5400 gfc_error ("Assumed-type variable %s at %L may only be used "
5401 "as actual argument", sym
->name
, &e
->where
);
5404 else if (inquiry_argument
&& !first_actual_arg
)
5406 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5407 for all inquiry functions in resolve_function; the reason is
5408 that the function-name resolution happens too late in that
5410 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5411 "an inquiry function shall be the first argument",
5412 sym
->name
, &e
->where
);
5416 /* TS 29113, C535b. */
5417 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5418 && CLASS_DATA (sym
)->as
5419 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5420 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5421 && sym
->as
->type
== AS_ASSUMED_RANK
))
5425 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5426 "actual argument", sym
->name
, &e
->where
);
5429 else if (inquiry_argument
&& !first_actual_arg
)
5431 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5432 for all inquiry functions in resolve_function; the reason is
5433 that the function-name resolution happens too late in that
5435 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5436 "to an inquiry function shall be the first argument",
5437 sym
->name
, &e
->where
);
5442 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5443 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5444 && e
->ref
->next
== NULL
))
5446 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5447 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5450 /* TS 29113, 407b. */
5451 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5452 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5453 && e
->ref
->next
== NULL
))
5455 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5456 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5460 /* TS 29113, C535b. */
5461 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5462 && CLASS_DATA (sym
)->as
5463 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5464 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5465 && sym
->as
->type
== AS_ASSUMED_RANK
))
5467 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5468 && e
->ref
->next
== NULL
))
5470 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5471 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5475 /* For variables that are used in an associate (target => object) where
5476 the object's basetype is array valued while the target is scalar,
5477 the ts' type of the component refs is still array valued, which
5478 can't be translated that way. */
5479 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5480 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5481 && CLASS_DATA (sym
->assoc
->target
)->as
)
5483 gfc_ref
*ref
= e
->ref
;
5489 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5490 /* Stop the loop. */
5500 /* If this is an associate-name, it may be parsed with an array reference
5501 in error even though the target is scalar. Fail directly in this case.
5502 TODO Understand why class scalar expressions must be excluded. */
5503 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5505 if (sym
->ts
.type
== BT_CLASS
)
5506 gfc_fix_class_refs (e
);
5507 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5509 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5511 /* This can happen because the parser did not detect that the
5512 associate name is an array and the expression had no array
5514 gfc_ref
*ref
= gfc_get_ref ();
5515 ref
->type
= REF_ARRAY
;
5516 ref
->u
.ar
= *gfc_get_array_ref();
5517 ref
->u
.ar
.type
= AR_FULL
;
5520 ref
->u
.ar
.as
= sym
->as
;
5521 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5529 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5530 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5532 /* On the other hand, the parser may not have known this is an array;
5533 in this case, we have to add a FULL reference. */
5534 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5536 e
->ref
= gfc_get_ref ();
5537 e
->ref
->type
= REF_ARRAY
;
5538 e
->ref
->u
.ar
.type
= AR_FULL
;
5539 e
->ref
->u
.ar
.dimen
= 0;
5542 /* Like above, but for class types, where the checking whether an array
5543 ref is present is more complicated. Furthermore make sure not to add
5544 the full array ref to _vptr or _len refs. */
5545 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5546 && CLASS_DATA (sym
)->attr
.dimension
5547 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5549 gfc_ref
*ref
, *newref
;
5551 newref
= gfc_get_ref ();
5552 newref
->type
= REF_ARRAY
;
5553 newref
->u
.ar
.type
= AR_FULL
;
5554 newref
->u
.ar
.dimen
= 0;
5555 /* Because this is an associate var and the first ref either is a ref to
5556 the _data component or not, no traversal of the ref chain is
5557 needed. The array ref needs to be inserted after the _data ref,
5558 or when that is not present, which may happend for polymorphic
5559 types, then at the first position. */
5563 else if (ref
->type
== REF_COMPONENT
5564 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5566 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5568 newref
->next
= ref
->next
;
5572 /* Array ref present already. */
5573 gfc_free_ref_list (newref
);
5575 else if (ref
->type
== REF_ARRAY
)
5576 /* Array ref present already. */
5577 gfc_free_ref_list (newref
);
5585 if (e
->ref
&& !resolve_ref (e
))
5588 if (sym
->attr
.flavor
== FL_PROCEDURE
5589 && (!sym
->attr
.function
5590 || (sym
->attr
.function
&& sym
->result
5591 && sym
->result
->attr
.proc_pointer
5592 && !sym
->result
->attr
.function
)))
5594 e
->ts
.type
= BT_PROCEDURE
;
5595 goto resolve_procedure
;
5598 if (sym
->ts
.type
!= BT_UNKNOWN
)
5599 gfc_variable_attr (e
, &e
->ts
);
5600 else if (sym
->attr
.flavor
== FL_PROCEDURE
5601 && sym
->attr
.function
&& sym
->result
5602 && sym
->result
->ts
.type
!= BT_UNKNOWN
5603 && sym
->result
->attr
.proc_pointer
)
5604 e
->ts
= sym
->result
->ts
;
5607 /* Must be a simple variable reference. */
5608 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5613 if (check_assumed_size_reference (sym
, e
))
5616 /* Deal with forward references to entries during gfc_resolve_code, to
5617 satisfy, at least partially, 12.5.2.5. */
5618 if (gfc_current_ns
->entries
5619 && current_entry_id
== sym
->entry_id
5622 && cs_base
->current
->op
!= EXEC_ENTRY
)
5624 gfc_entry_list
*entry
;
5625 gfc_formal_arglist
*formal
;
5627 bool seen
, saved_specification_expr
;
5629 /* If the symbol is a dummy... */
5630 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5632 entry
= gfc_current_ns
->entries
;
5635 /* ...test if the symbol is a parameter of previous entries. */
5636 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5637 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5639 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5646 /* If it has not been seen as a dummy, this is an error. */
5649 if (specification_expr
)
5650 gfc_error ("Variable %qs, used in a specification expression"
5651 ", is referenced at %L before the ENTRY statement "
5652 "in which it is a parameter",
5653 sym
->name
, &cs_base
->current
->loc
);
5655 gfc_error ("Variable %qs is used at %L before the ENTRY "
5656 "statement in which it is a parameter",
5657 sym
->name
, &cs_base
->current
->loc
);
5662 /* Now do the same check on the specification expressions. */
5663 saved_specification_expr
= specification_expr
;
5664 specification_expr
= true;
5665 if (sym
->ts
.type
== BT_CHARACTER
5666 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5670 for (n
= 0; n
< sym
->as
->rank
; n
++)
5672 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5674 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5677 specification_expr
= saved_specification_expr
;
5680 /* Update the symbol's entry level. */
5681 sym
->entry_id
= current_entry_id
+ 1;
5684 /* If a symbol has been host_associated mark it. This is used latter,
5685 to identify if aliasing is possible via host association. */
5686 if (sym
->attr
.flavor
== FL_VARIABLE
5687 && gfc_current_ns
->parent
5688 && (gfc_current_ns
->parent
== sym
->ns
5689 || (gfc_current_ns
->parent
->parent
5690 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5691 sym
->attr
.host_assoc
= 1;
5693 if (gfc_current_ns
->proc_name
5694 && sym
->attr
.dimension
5695 && (sym
->ns
!= gfc_current_ns
5696 || sym
->attr
.use_assoc
5697 || sym
->attr
.in_common
))
5698 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5701 if (t
&& !resolve_procedure_expression (e
))
5704 /* F2008, C617 and C1229. */
5705 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5706 && gfc_is_coindexed (e
))
5708 gfc_ref
*ref
, *ref2
= NULL
;
5710 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5712 if (ref
->type
== REF_COMPONENT
)
5714 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5718 for ( ; ref
; ref
= ref
->next
)
5719 if (ref
->type
== REF_COMPONENT
)
5722 /* Expression itself is not coindexed object. */
5723 if (ref
&& e
->ts
.type
== BT_CLASS
)
5725 gfc_error ("Polymorphic subobject of coindexed object at %L",
5730 /* Expression itself is coindexed object. */
5734 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5735 for ( ; c
; c
= c
->next
)
5736 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5738 gfc_error ("Coindexed object with polymorphic allocatable "
5739 "subcomponent at %L", &e
->where
);
5747 expression_rank (e
);
5749 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5750 add_caf_get_intrinsic (e
);
5752 /* Simplify cases where access to a parameter array results in a
5753 single constant. Suppress errors since those will have been
5754 issued before, as warnings. */
5755 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5757 gfc_push_suppress_errors ();
5758 gfc_simplify_expr (e
, 1);
5759 gfc_pop_suppress_errors ();
5766 /* Checks to see that the correct symbol has been host associated.
5767 The only situation where this arises is that in which a twice
5768 contained function is parsed after the host association is made.
5769 Therefore, on detecting this, change the symbol in the expression
5770 and convert the array reference into an actual arglist if the old
5771 symbol is a variable. */
5773 check_host_association (gfc_expr
*e
)
5775 gfc_symbol
*sym
, *old_sym
;
5779 gfc_actual_arglist
*arg
, *tail
= NULL
;
5780 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5782 /* If the expression is the result of substitution in
5783 interface.c(gfc_extend_expr) because there is no way in
5784 which the host association can be wrong. */
5785 if (e
->symtree
== NULL
5786 || e
->symtree
->n
.sym
== NULL
5787 || e
->user_operator
)
5790 old_sym
= e
->symtree
->n
.sym
;
5792 if (gfc_current_ns
->parent
5793 && old_sym
->ns
!= gfc_current_ns
)
5795 /* Use the 'USE' name so that renamed module symbols are
5796 correctly handled. */
5797 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5799 if (sym
&& old_sym
!= sym
5800 && sym
->ts
.type
== old_sym
->ts
.type
5801 && sym
->attr
.flavor
== FL_PROCEDURE
5802 && sym
->attr
.contained
)
5804 /* Clear the shape, since it might not be valid. */
5805 gfc_free_shape (&e
->shape
, e
->rank
);
5807 /* Give the expression the right symtree! */
5808 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5809 gcc_assert (st
!= NULL
);
5811 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5812 || e
->expr_type
== EXPR_FUNCTION
)
5814 /* Original was function so point to the new symbol, since
5815 the actual argument list is already attached to the
5817 e
->value
.function
.esym
= NULL
;
5822 /* Original was variable so convert array references into
5823 an actual arglist. This does not need any checking now
5824 since resolve_function will take care of it. */
5825 e
->value
.function
.actual
= NULL
;
5826 e
->expr_type
= EXPR_FUNCTION
;
5829 /* Ambiguity will not arise if the array reference is not
5830 the last reference. */
5831 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5832 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5835 gcc_assert (ref
->type
== REF_ARRAY
);
5837 /* Grab the start expressions from the array ref and
5838 copy them into actual arguments. */
5839 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5841 arg
= gfc_get_actual_arglist ();
5842 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5843 if (e
->value
.function
.actual
== NULL
)
5844 tail
= e
->value
.function
.actual
= arg
;
5852 /* Dump the reference list and set the rank. */
5853 gfc_free_ref_list (e
->ref
);
5855 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5858 gfc_resolve_expr (e
);
5862 /* This might have changed! */
5863 return e
->expr_type
== EXPR_FUNCTION
;
5868 gfc_resolve_character_operator (gfc_expr
*e
)
5870 gfc_expr
*op1
= e
->value
.op
.op1
;
5871 gfc_expr
*op2
= e
->value
.op
.op2
;
5872 gfc_expr
*e1
= NULL
;
5873 gfc_expr
*e2
= NULL
;
5875 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5877 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5878 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5879 else if (op1
->expr_type
== EXPR_CONSTANT
)
5880 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5881 op1
->value
.character
.length
);
5883 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5884 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5885 else if (op2
->expr_type
== EXPR_CONSTANT
)
5886 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5887 op2
->value
.character
.length
);
5889 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5899 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5900 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5901 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5902 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5903 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5909 /* Ensure that an character expression has a charlen and, if possible, a
5910 length expression. */
5913 fixup_charlen (gfc_expr
*e
)
5915 /* The cases fall through so that changes in expression type and the need
5916 for multiple fixes are picked up. In all circumstances, a charlen should
5917 be available for the middle end to hang a backend_decl on. */
5918 switch (e
->expr_type
)
5921 gfc_resolve_character_operator (e
);
5925 if (e
->expr_type
== EXPR_ARRAY
)
5926 gfc_resolve_character_array_constructor (e
);
5929 case EXPR_SUBSTRING
:
5930 if (!e
->ts
.u
.cl
&& e
->ref
)
5931 gfc_resolve_substring_charlen (e
);
5936 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5943 /* Update an actual argument to include the passed-object for type-bound
5944 procedures at the right position. */
5946 static gfc_actual_arglist
*
5947 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5950 gcc_assert (argpos
> 0);
5954 gfc_actual_arglist
* result
;
5956 result
= gfc_get_actual_arglist ();
5960 result
->name
= name
;
5966 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5968 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5973 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5976 extract_compcall_passed_object (gfc_expr
* e
)
5980 if (e
->expr_type
== EXPR_UNKNOWN
)
5982 gfc_error ("Error in typebound call at %L",
5987 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5989 if (e
->value
.compcall
.base_object
)
5990 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5993 po
= gfc_get_expr ();
5994 po
->expr_type
= EXPR_VARIABLE
;
5995 po
->symtree
= e
->symtree
;
5996 po
->ref
= gfc_copy_ref (e
->ref
);
5997 po
->where
= e
->where
;
6000 if (!gfc_resolve_expr (po
))
6007 /* Update the arglist of an EXPR_COMPCALL expression to include the
6011 update_compcall_arglist (gfc_expr
* e
)
6014 gfc_typebound_proc
* tbp
;
6016 tbp
= e
->value
.compcall
.tbp
;
6021 po
= extract_compcall_passed_object (e
);
6025 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6031 if (tbp
->pass_arg_num
<= 0)
6034 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6042 /* Extract the passed object from a PPC call (a copy of it). */
6045 extract_ppc_passed_object (gfc_expr
*e
)
6050 po
= gfc_get_expr ();
6051 po
->expr_type
= EXPR_VARIABLE
;
6052 po
->symtree
= e
->symtree
;
6053 po
->ref
= gfc_copy_ref (e
->ref
);
6054 po
->where
= e
->where
;
6056 /* Remove PPC reference. */
6058 while ((*ref
)->next
)
6059 ref
= &(*ref
)->next
;
6060 gfc_free_ref_list (*ref
);
6063 if (!gfc_resolve_expr (po
))
6070 /* Update the actual arglist of a procedure pointer component to include the
6074 update_ppc_arglist (gfc_expr
* e
)
6078 gfc_typebound_proc
* tb
;
6080 ppc
= gfc_get_proc_ptr_comp (e
);
6088 else if (tb
->nopass
)
6091 po
= extract_ppc_passed_object (e
);
6098 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6103 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6105 gfc_error ("Base object for procedure-pointer component call at %L is of"
6106 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6110 gcc_assert (tb
->pass_arg_num
> 0);
6111 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6119 /* Check that the object a TBP is called on is valid, i.e. it must not be
6120 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6123 check_typebound_baseobject (gfc_expr
* e
)
6126 bool return_value
= false;
6128 base
= extract_compcall_passed_object (e
);
6132 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6134 gfc_error ("Error in typebound call at %L", &e
->where
);
6138 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6142 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6144 gfc_error ("Base object for type-bound procedure call at %L is of"
6145 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6149 /* F08:C1230. If the procedure called is NOPASS,
6150 the base object must be scalar. */
6151 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6153 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6154 " be scalar", &e
->where
);
6158 return_value
= true;
6161 gfc_free_expr (base
);
6162 return return_value
;
6166 /* Resolve a call to a type-bound procedure, either function or subroutine,
6167 statically from the data in an EXPR_COMPCALL expression. The adapted
6168 arglist and the target-procedure symtree are returned. */
6171 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6172 gfc_actual_arglist
** actual
)
6174 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6175 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6177 /* Update the actual arglist for PASS. */
6178 if (!update_compcall_arglist (e
))
6181 *actual
= e
->value
.compcall
.actual
;
6182 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6184 gfc_free_ref_list (e
->ref
);
6186 e
->value
.compcall
.actual
= NULL
;
6188 /* If we find a deferred typebound procedure, check for derived types
6189 that an overriding typebound procedure has not been missed. */
6190 if (e
->value
.compcall
.name
6191 && !e
->value
.compcall
.tbp
->non_overridable
6192 && e
->value
.compcall
.base_object
6193 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6196 gfc_symbol
*derived
;
6198 /* Use the derived type of the base_object. */
6199 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6202 /* If necessary, go through the inheritance chain. */
6203 while (!st
&& derived
)
6205 /* Look for the typebound procedure 'name'. */
6206 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6207 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6208 e
->value
.compcall
.name
);
6210 derived
= gfc_get_derived_super_type (derived
);
6213 /* Now find the specific name in the derived type namespace. */
6214 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6215 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6216 derived
->ns
, 1, &st
);
6224 /* Get the ultimate declared type from an expression. In addition,
6225 return the last class/derived type reference and the copy of the
6226 reference list. If check_types is set true, derived types are
6227 identified as well as class references. */
6229 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6230 gfc_expr
*e
, bool check_types
)
6232 gfc_symbol
*declared
;
6239 *new_ref
= gfc_copy_ref (e
->ref
);
6241 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6243 if (ref
->type
!= REF_COMPONENT
)
6246 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6247 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6248 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6250 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6256 if (declared
== NULL
)
6257 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6263 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6264 which of the specific bindings (if any) matches the arglist and transform
6265 the expression into a call of that binding. */
6268 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6270 gfc_typebound_proc
* genproc
;
6271 const char* genname
;
6273 gfc_symbol
*derived
;
6275 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6276 genname
= e
->value
.compcall
.name
;
6277 genproc
= e
->value
.compcall
.tbp
;
6279 if (!genproc
->is_generic
)
6282 /* Try the bindings on this type and in the inheritance hierarchy. */
6283 for (; genproc
; genproc
= genproc
->overridden
)
6287 gcc_assert (genproc
->is_generic
);
6288 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6291 gfc_actual_arglist
* args
;
6294 gcc_assert (g
->specific
);
6296 if (g
->specific
->error
)
6299 target
= g
->specific
->u
.specific
->n
.sym
;
6301 /* Get the right arglist by handling PASS/NOPASS. */
6302 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6303 if (!g
->specific
->nopass
)
6306 po
= extract_compcall_passed_object (e
);
6309 gfc_free_actual_arglist (args
);
6313 gcc_assert (g
->specific
->pass_arg_num
> 0);
6314 gcc_assert (!g
->specific
->error
);
6315 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6316 g
->specific
->pass_arg
);
6318 resolve_actual_arglist (args
, target
->attr
.proc
,
6319 is_external_proc (target
)
6320 && gfc_sym_get_dummy_args (target
) == NULL
);
6322 /* Check if this arglist matches the formal. */
6323 matches
= gfc_arglist_matches_symbol (&args
, target
);
6325 /* Clean up and break out of the loop if we've found it. */
6326 gfc_free_actual_arglist (args
);
6329 e
->value
.compcall
.tbp
= g
->specific
;
6330 genname
= g
->specific_st
->name
;
6331 /* Pass along the name for CLASS methods, where the vtab
6332 procedure pointer component has to be referenced. */
6340 /* Nothing matching found! */
6341 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6342 " %qs at %L", genname
, &e
->where
);
6346 /* Make sure that we have the right specific instance for the name. */
6347 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6349 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6351 e
->value
.compcall
.tbp
= st
->n
.tb
;
6357 /* Resolve a call to a type-bound subroutine. */
6360 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6362 gfc_actual_arglist
* newactual
;
6363 gfc_symtree
* target
;
6365 /* Check that's really a SUBROUTINE. */
6366 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6368 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6369 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6370 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6371 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6372 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6375 gfc_error ("%qs at %L should be a SUBROUTINE",
6376 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6381 if (!check_typebound_baseobject (c
->expr1
))
6384 /* Pass along the name for CLASS methods, where the vtab
6385 procedure pointer component has to be referenced. */
6387 *name
= c
->expr1
->value
.compcall
.name
;
6389 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6392 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6394 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6396 /* Transform into an ordinary EXEC_CALL for now. */
6398 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6401 c
->ext
.actual
= newactual
;
6402 c
->symtree
= target
;
6403 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6405 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6407 gfc_free_expr (c
->expr1
);
6408 c
->expr1
= gfc_get_expr ();
6409 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6410 c
->expr1
->symtree
= target
;
6411 c
->expr1
->where
= c
->loc
;
6413 return resolve_call (c
);
6417 /* Resolve a component-call expression. */
6419 resolve_compcall (gfc_expr
* e
, const char **name
)
6421 gfc_actual_arglist
* newactual
;
6422 gfc_symtree
* target
;
6424 /* Check that's really a FUNCTION. */
6425 if (!e
->value
.compcall
.tbp
->function
)
6427 gfc_error ("%qs at %L should be a FUNCTION",
6428 e
->value
.compcall
.name
, &e
->where
);
6432 /* These must not be assign-calls! */
6433 gcc_assert (!e
->value
.compcall
.assign
);
6435 if (!check_typebound_baseobject (e
))
6438 /* Pass along the name for CLASS methods, where the vtab
6439 procedure pointer component has to be referenced. */
6441 *name
= e
->value
.compcall
.name
;
6443 if (!resolve_typebound_generic_call (e
, name
))
6445 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6447 /* Take the rank from the function's symbol. */
6448 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6449 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6451 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6452 arglist to the TBP's binding target. */
6454 if (!resolve_typebound_static (e
, &target
, &newactual
))
6457 e
->value
.function
.actual
= newactual
;
6458 e
->value
.function
.name
= NULL
;
6459 e
->value
.function
.esym
= target
->n
.sym
;
6460 e
->value
.function
.isym
= NULL
;
6461 e
->symtree
= target
;
6462 e
->ts
= target
->n
.sym
->ts
;
6463 e
->expr_type
= EXPR_FUNCTION
;
6465 /* Resolution is not necessary if this is a class subroutine; this
6466 function only has to identify the specific proc. Resolution of
6467 the call will be done next in resolve_typebound_call. */
6468 return gfc_resolve_expr (e
);
6472 static bool resolve_fl_derived (gfc_symbol
*sym
);
6475 /* Resolve a typebound function, or 'method'. First separate all
6476 the non-CLASS references by calling resolve_compcall directly. */
6479 resolve_typebound_function (gfc_expr
* e
)
6481 gfc_symbol
*declared
;
6493 /* Deal with typebound operators for CLASS objects. */
6494 expr
= e
->value
.compcall
.base_object
;
6495 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6496 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6498 /* If the base_object is not a variable, the corresponding actual
6499 argument expression must be stored in e->base_expression so
6500 that the corresponding tree temporary can be used as the base
6501 object in gfc_conv_procedure_call. */
6502 if (expr
->expr_type
!= EXPR_VARIABLE
)
6504 gfc_actual_arglist
*args
;
6506 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6508 if (expr
== args
->expr
)
6513 /* Since the typebound operators are generic, we have to ensure
6514 that any delays in resolution are corrected and that the vtab
6517 declared
= ts
.u
.derived
;
6518 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6519 if (c
->ts
.u
.derived
== NULL
)
6520 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6522 if (!resolve_compcall (e
, &name
))
6525 /* Use the generic name if it is there. */
6526 name
= name
? name
: e
->value
.function
.esym
->name
;
6527 e
->symtree
= expr
->symtree
;
6528 e
->ref
= gfc_copy_ref (expr
->ref
);
6529 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6531 /* Trim away the extraneous references that emerge from nested
6532 use of interface.c (extend_expr). */
6533 if (class_ref
&& class_ref
->next
)
6535 gfc_free_ref_list (class_ref
->next
);
6536 class_ref
->next
= NULL
;
6538 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6540 gfc_free_ref_list (e
->ref
);
6544 gfc_add_vptr_component (e
);
6545 gfc_add_component_ref (e
, name
);
6546 e
->value
.function
.esym
= NULL
;
6547 if (expr
->expr_type
!= EXPR_VARIABLE
)
6548 e
->base_expr
= expr
;
6553 return resolve_compcall (e
, NULL
);
6555 if (!resolve_ref (e
))
6558 /* Get the CLASS declared type. */
6559 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6561 if (!resolve_fl_derived (declared
))
6564 /* Weed out cases of the ultimate component being a derived type. */
6565 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6566 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6568 gfc_free_ref_list (new_ref
);
6569 return resolve_compcall (e
, NULL
);
6572 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6573 declared
= c
->ts
.u
.derived
;
6575 /* Treat the call as if it is a typebound procedure, in order to roll
6576 out the correct name for the specific function. */
6577 if (!resolve_compcall (e
, &name
))
6579 gfc_free_ref_list (new_ref
);
6586 /* Convert the expression to a procedure pointer component call. */
6587 e
->value
.function
.esym
= NULL
;
6593 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6594 gfc_add_vptr_component (e
);
6595 gfc_add_component_ref (e
, name
);
6597 /* Recover the typespec for the expression. This is really only
6598 necessary for generic procedures, where the additional call
6599 to gfc_add_component_ref seems to throw the collection of the
6600 correct typespec. */
6604 gfc_free_ref_list (new_ref
);
6609 /* Resolve a typebound subroutine, or 'method'. First separate all
6610 the non-CLASS references by calling resolve_typebound_call
6614 resolve_typebound_subroutine (gfc_code
*code
)
6616 gfc_symbol
*declared
;
6626 st
= code
->expr1
->symtree
;
6628 /* Deal with typebound operators for CLASS objects. */
6629 expr
= code
->expr1
->value
.compcall
.base_object
;
6630 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6631 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6633 /* If the base_object is not a variable, the corresponding actual
6634 argument expression must be stored in e->base_expression so
6635 that the corresponding tree temporary can be used as the base
6636 object in gfc_conv_procedure_call. */
6637 if (expr
->expr_type
!= EXPR_VARIABLE
)
6639 gfc_actual_arglist
*args
;
6641 args
= code
->expr1
->value
.function
.actual
;
6642 for (; args
; args
= args
->next
)
6643 if (expr
== args
->expr
)
6647 /* Since the typebound operators are generic, we have to ensure
6648 that any delays in resolution are corrected and that the vtab
6650 declared
= expr
->ts
.u
.derived
;
6651 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6652 if (c
->ts
.u
.derived
== NULL
)
6653 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6655 if (!resolve_typebound_call (code
, &name
, NULL
))
6658 /* Use the generic name if it is there. */
6659 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6660 code
->expr1
->symtree
= expr
->symtree
;
6661 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6663 /* Trim away the extraneous references that emerge from nested
6664 use of interface.c (extend_expr). */
6665 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6666 if (class_ref
&& class_ref
->next
)
6668 gfc_free_ref_list (class_ref
->next
);
6669 class_ref
->next
= NULL
;
6671 else if (code
->expr1
->ref
&& !class_ref
)
6673 gfc_free_ref_list (code
->expr1
->ref
);
6674 code
->expr1
->ref
= NULL
;
6677 /* Now use the procedure in the vtable. */
6678 gfc_add_vptr_component (code
->expr1
);
6679 gfc_add_component_ref (code
->expr1
, name
);
6680 code
->expr1
->value
.function
.esym
= NULL
;
6681 if (expr
->expr_type
!= EXPR_VARIABLE
)
6682 code
->expr1
->base_expr
= expr
;
6687 return resolve_typebound_call (code
, NULL
, NULL
);
6689 if (!resolve_ref (code
->expr1
))
6692 /* Get the CLASS declared type. */
6693 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6695 /* Weed out cases of the ultimate component being a derived type. */
6696 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6697 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6699 gfc_free_ref_list (new_ref
);
6700 return resolve_typebound_call (code
, NULL
, NULL
);
6703 if (!resolve_typebound_call (code
, &name
, &overridable
))
6705 gfc_free_ref_list (new_ref
);
6708 ts
= code
->expr1
->ts
;
6712 /* Convert the expression to a procedure pointer component call. */
6713 code
->expr1
->value
.function
.esym
= NULL
;
6714 code
->expr1
->symtree
= st
;
6717 code
->expr1
->ref
= new_ref
;
6719 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6720 gfc_add_vptr_component (code
->expr1
);
6721 gfc_add_component_ref (code
->expr1
, name
);
6723 /* Recover the typespec for the expression. This is really only
6724 necessary for generic procedures, where the additional call
6725 to gfc_add_component_ref seems to throw the collection of the
6726 correct typespec. */
6727 code
->expr1
->ts
= ts
;
6730 gfc_free_ref_list (new_ref
);
6736 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6739 resolve_ppc_call (gfc_code
* c
)
6741 gfc_component
*comp
;
6743 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6744 gcc_assert (comp
!= NULL
);
6746 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6747 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6749 if (!comp
->attr
.subroutine
)
6750 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6752 if (!resolve_ref (c
->expr1
))
6755 if (!update_ppc_arglist (c
->expr1
))
6758 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6760 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6761 !(comp
->ts
.interface
6762 && comp
->ts
.interface
->formal
)))
6765 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6768 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6774 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6777 resolve_expr_ppc (gfc_expr
* e
)
6779 gfc_component
*comp
;
6781 comp
= gfc_get_proc_ptr_comp (e
);
6782 gcc_assert (comp
!= NULL
);
6784 /* Convert to EXPR_FUNCTION. */
6785 e
->expr_type
= EXPR_FUNCTION
;
6786 e
->value
.function
.isym
= NULL
;
6787 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6789 if (comp
->as
!= NULL
)
6790 e
->rank
= comp
->as
->rank
;
6792 if (!comp
->attr
.function
)
6793 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6795 if (!resolve_ref (e
))
6798 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6799 !(comp
->ts
.interface
6800 && comp
->ts
.interface
->formal
)))
6803 if (!update_ppc_arglist (e
))
6806 if (!check_pure_function(e
))
6809 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6816 gfc_is_expandable_expr (gfc_expr
*e
)
6818 gfc_constructor
*con
;
6820 if (e
->expr_type
== EXPR_ARRAY
)
6822 /* Traverse the constructor looking for variables that are flavor
6823 parameter. Parameters must be expanded since they are fully used at
6825 con
= gfc_constructor_first (e
->value
.constructor
);
6826 for (; con
; con
= gfc_constructor_next (con
))
6828 if (con
->expr
->expr_type
== EXPR_VARIABLE
6829 && con
->expr
->symtree
6830 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6831 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6833 if (con
->expr
->expr_type
== EXPR_ARRAY
6834 && gfc_is_expandable_expr (con
->expr
))
6843 /* Sometimes variables in specification expressions of the result
6844 of module procedures in submodules wind up not being the 'real'
6845 dummy. Find this, if possible, in the namespace of the first
6849 fixup_unique_dummy (gfc_expr
*e
)
6851 gfc_symtree
*st
= NULL
;
6852 gfc_symbol
*s
= NULL
;
6854 if (e
->symtree
->n
.sym
->ns
->proc_name
6855 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6856 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6859 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6862 && st
->n
.sym
!= NULL
6863 && st
->n
.sym
->attr
.dummy
)
6867 /* Resolve an expression. That is, make sure that types of operands agree
6868 with their operators, intrinsic operators are converted to function calls
6869 for overloaded types and unresolved function references are resolved. */
6872 gfc_resolve_expr (gfc_expr
*e
)
6875 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6880 /* inquiry_argument only applies to variables. */
6881 inquiry_save
= inquiry_argument
;
6882 actual_arg_save
= actual_arg
;
6883 first_actual_arg_save
= first_actual_arg
;
6885 if (e
->expr_type
!= EXPR_VARIABLE
)
6887 inquiry_argument
= false;
6889 first_actual_arg
= false;
6891 else if (e
->symtree
!= NULL
6892 && *e
->symtree
->name
== '@'
6893 && e
->symtree
->n
.sym
->attr
.dummy
)
6895 /* Deal with submodule specification expressions that are not
6896 found to be referenced in module.c(read_cleanup). */
6897 fixup_unique_dummy (e
);
6900 switch (e
->expr_type
)
6903 t
= resolve_operator (e
);
6909 if (check_host_association (e
))
6910 t
= resolve_function (e
);
6912 t
= resolve_variable (e
);
6914 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6915 && e
->ref
->type
!= REF_SUBSTRING
)
6916 gfc_resolve_substring_charlen (e
);
6921 t
= resolve_typebound_function (e
);
6924 case EXPR_SUBSTRING
:
6925 t
= resolve_ref (e
);
6934 t
= resolve_expr_ppc (e
);
6939 if (!resolve_ref (e
))
6942 t
= gfc_resolve_array_constructor (e
);
6943 /* Also try to expand a constructor. */
6946 expression_rank (e
);
6947 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6948 gfc_expand_constructor (e
, false);
6951 /* This provides the opportunity for the length of constructors with
6952 character valued function elements to propagate the string length
6953 to the expression. */
6954 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6956 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6957 here rather then add a duplicate test for it above. */
6958 gfc_expand_constructor (e
, false);
6959 t
= gfc_resolve_character_array_constructor (e
);
6964 case EXPR_STRUCTURE
:
6965 t
= resolve_ref (e
);
6969 t
= resolve_structure_cons (e
, 0);
6973 t
= gfc_simplify_expr (e
, 0);
6977 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6980 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6983 inquiry_argument
= inquiry_save
;
6984 actual_arg
= actual_arg_save
;
6985 first_actual_arg
= first_actual_arg_save
;
6991 /* Resolve an expression from an iterator. They must be scalar and have
6992 INTEGER or (optionally) REAL type. */
6995 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6996 const char *name_msgid
)
6998 if (!gfc_resolve_expr (expr
))
7001 if (expr
->rank
!= 0)
7003 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7007 if (expr
->ts
.type
!= BT_INTEGER
)
7009 if (expr
->ts
.type
== BT_REAL
)
7012 return gfc_notify_std (GFC_STD_F95_DEL
,
7013 "%s at %L must be integer",
7014 _(name_msgid
), &expr
->where
);
7017 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7024 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7032 /* Resolve the expressions in an iterator structure. If REAL_OK is
7033 false allow only INTEGER type iterators, otherwise allow REAL types.
7034 Set own_scope to true for ac-implied-do and data-implied-do as those
7035 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7038 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7040 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7043 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7044 _("iterator variable")))
7047 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7048 "Start expression in DO loop"))
7051 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7052 "End expression in DO loop"))
7055 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7056 "Step expression in DO loop"))
7059 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7061 if ((iter
->step
->ts
.type
== BT_INTEGER
7062 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7063 || (iter
->step
->ts
.type
== BT_REAL
7064 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7066 gfc_error ("Step expression in DO loop at %L cannot be zero",
7067 &iter
->step
->where
);
7072 /* Convert start, end, and step to the same type as var. */
7073 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7074 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7075 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7077 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7078 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7079 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7081 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7082 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7083 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7085 if (iter
->start
->expr_type
== EXPR_CONSTANT
7086 && iter
->end
->expr_type
== EXPR_CONSTANT
7087 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7090 if (iter
->start
->ts
.type
== BT_INTEGER
)
7092 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7093 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7097 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7098 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7100 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7101 gfc_warning (OPT_Wzerotrip
,
7102 "DO loop at %L will be executed zero times",
7103 &iter
->step
->where
);
7106 if (iter
->end
->expr_type
== EXPR_CONSTANT
7107 && iter
->end
->ts
.type
== BT_INTEGER
7108 && iter
->step
->expr_type
== EXPR_CONSTANT
7109 && iter
->step
->ts
.type
== BT_INTEGER
7110 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7111 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7113 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7114 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7116 if (is_step_positive
7117 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7118 gfc_warning (OPT_Wundefined_do_loop
,
7119 "DO loop at %L is undefined as it overflows",
7120 &iter
->step
->where
);
7121 else if (!is_step_positive
7122 && mpz_cmp (iter
->end
->value
.integer
,
7123 gfc_integer_kinds
[k
].min_int
) == 0)
7124 gfc_warning (OPT_Wundefined_do_loop
,
7125 "DO loop at %L is undefined as it underflows",
7126 &iter
->step
->where
);
7133 /* Traversal function for find_forall_index. f == 2 signals that
7134 that variable itself is not to be checked - only the references. */
7137 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7139 if (expr
->expr_type
!= EXPR_VARIABLE
)
7142 /* A scalar assignment */
7143 if (!expr
->ref
|| *f
== 1)
7145 if (expr
->symtree
->n
.sym
== sym
)
7157 /* Check whether the FORALL index appears in the expression or not.
7158 Returns true if SYM is found in EXPR. */
7161 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7163 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7170 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7171 to be a scalar INTEGER variable. The subscripts and stride are scalar
7172 INTEGERs, and if stride is a constant it must be nonzero.
7173 Furthermore "A subscript or stride in a forall-triplet-spec shall
7174 not contain a reference to any index-name in the
7175 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7178 resolve_forall_iterators (gfc_forall_iterator
*it
)
7180 gfc_forall_iterator
*iter
, *iter2
;
7182 for (iter
= it
; iter
; iter
= iter
->next
)
7184 if (gfc_resolve_expr (iter
->var
)
7185 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7186 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7189 if (gfc_resolve_expr (iter
->start
)
7190 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7191 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7192 &iter
->start
->where
);
7193 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7194 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7196 if (gfc_resolve_expr (iter
->end
)
7197 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7198 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7200 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7201 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7203 if (gfc_resolve_expr (iter
->stride
))
7205 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7206 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7207 &iter
->stride
->where
, "INTEGER");
7209 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7210 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7211 gfc_error ("FORALL stride expression at %L cannot be zero",
7212 &iter
->stride
->where
);
7214 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7215 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7218 for (iter
= it
; iter
; iter
= iter
->next
)
7219 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7221 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7222 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7223 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7224 gfc_error ("FORALL index %qs may not appear in triplet "
7225 "specification at %L", iter
->var
->symtree
->name
,
7226 &iter2
->start
->where
);
7231 /* Given a pointer to a symbol that is a derived type, see if it's
7232 inaccessible, i.e. if it's defined in another module and the components are
7233 PRIVATE. The search is recursive if necessary. Returns zero if no
7234 inaccessible components are found, nonzero otherwise. */
7237 derived_inaccessible (gfc_symbol
*sym
)
7241 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7244 for (c
= sym
->components
; c
; c
= c
->next
)
7246 /* Prevent an infinite loop through this function. */
7247 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7248 && sym
== c
->ts
.u
.derived
)
7251 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7259 /* Resolve the argument of a deallocate expression. The expression must be
7260 a pointer or a full array. */
7263 resolve_deallocate_expr (gfc_expr
*e
)
7265 symbol_attribute attr
;
7266 int allocatable
, pointer
;
7272 if (!gfc_resolve_expr (e
))
7275 if (e
->expr_type
!= EXPR_VARIABLE
)
7278 sym
= e
->symtree
->n
.sym
;
7279 unlimited
= UNLIMITED_POLY(sym
);
7281 if (sym
->ts
.type
== BT_CLASS
)
7283 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7284 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7288 allocatable
= sym
->attr
.allocatable
;
7289 pointer
= sym
->attr
.pointer
;
7291 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7296 if (ref
->u
.ar
.type
!= AR_FULL
7297 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7298 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7303 c
= ref
->u
.c
.component
;
7304 if (c
->ts
.type
== BT_CLASS
)
7306 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7307 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7311 allocatable
= c
->attr
.allocatable
;
7312 pointer
= c
->attr
.pointer
;
7323 attr
= gfc_expr_attr (e
);
7325 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7328 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7334 if (gfc_is_coindexed (e
))
7336 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7341 && !gfc_check_vardef_context (e
, true, true, false,
7342 _("DEALLOCATE object")))
7344 if (!gfc_check_vardef_context (e
, false, true, false,
7345 _("DEALLOCATE object")))
7352 /* Returns true if the expression e contains a reference to the symbol sym. */
7354 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7356 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7363 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7365 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7369 /* Given the expression node e for an allocatable/pointer of derived type to be
7370 allocated, get the expression node to be initialized afterwards (needed for
7371 derived types with default initializers, and derived types with allocatable
7372 components that need nullification.) */
7375 gfc_expr_to_initialize (gfc_expr
*e
)
7381 result
= gfc_copy_expr (e
);
7383 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7384 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7385 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7387 ref
->u
.ar
.type
= AR_FULL
;
7389 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7390 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7395 gfc_free_shape (&result
->shape
, result
->rank
);
7397 /* Recalculate rank, shape, etc. */
7398 gfc_resolve_expr (result
);
7403 /* If the last ref of an expression is an array ref, return a copy of the
7404 expression with that one removed. Otherwise, a copy of the original
7405 expression. This is used for allocate-expressions and pointer assignment
7406 LHS, where there may be an array specification that needs to be stripped
7407 off when using gfc_check_vardef_context. */
7410 remove_last_array_ref (gfc_expr
* e
)
7415 e2
= gfc_copy_expr (e
);
7416 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7417 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7419 gfc_free_ref_list (*r
);
7428 /* Used in resolve_allocate_expr to check that a allocation-object and
7429 a source-expr are conformable. This does not catch all possible
7430 cases; in particular a runtime checking is needed. */
7433 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7436 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7438 /* First compare rank. */
7439 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7440 || (!tail
&& e1
->rank
!= e2
->rank
))
7442 gfc_error ("Source-expr at %L must be scalar or have the "
7443 "same rank as the allocate-object at %L",
7444 &e1
->where
, &e2
->where
);
7455 for (i
= 0; i
< e1
->rank
; i
++)
7457 if (tail
->u
.ar
.start
[i
] == NULL
)
7460 if (tail
->u
.ar
.end
[i
])
7462 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7463 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7464 mpz_add_ui (s
, s
, 1);
7468 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7471 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7473 gfc_error ("Source-expr at %L and allocate-object at %L must "
7474 "have the same shape", &e1
->where
, &e2
->where
);
7487 /* Resolve the expression in an ALLOCATE statement, doing the additional
7488 checks to see whether the expression is OK or not. The expression must
7489 have a trailing array reference that gives the size of the array. */
7492 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7494 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7498 symbol_attribute attr
;
7499 gfc_ref
*ref
, *ref2
;
7502 gfc_symbol
*sym
= NULL
;
7507 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7508 checking of coarrays. */
7509 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7510 if (ref
->next
== NULL
)
7513 if (ref
&& ref
->type
== REF_ARRAY
)
7514 ref
->u
.ar
.in_allocate
= true;
7516 if (!gfc_resolve_expr (e
))
7519 /* Make sure the expression is allocatable or a pointer. If it is
7520 pointer, the next-to-last reference must be a pointer. */
7524 sym
= e
->symtree
->n
.sym
;
7526 /* Check whether ultimate component is abstract and CLASS. */
7529 /* Is the allocate-object unlimited polymorphic? */
7530 unlimited
= UNLIMITED_POLY(e
);
7532 if (e
->expr_type
!= EXPR_VARIABLE
)
7535 attr
= gfc_expr_attr (e
);
7536 pointer
= attr
.pointer
;
7537 dimension
= attr
.dimension
;
7538 codimension
= attr
.codimension
;
7542 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7544 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7545 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7546 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7547 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7548 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7552 allocatable
= sym
->attr
.allocatable
;
7553 pointer
= sym
->attr
.pointer
;
7554 dimension
= sym
->attr
.dimension
;
7555 codimension
= sym
->attr
.codimension
;
7560 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7565 if (ref
->u
.ar
.codimen
> 0)
7568 for (n
= ref
->u
.ar
.dimen
;
7569 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7570 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7577 if (ref
->next
!= NULL
)
7585 gfc_error ("Coindexed allocatable object at %L",
7590 c
= ref
->u
.c
.component
;
7591 if (c
->ts
.type
== BT_CLASS
)
7593 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7594 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7595 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7596 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7597 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7601 allocatable
= c
->attr
.allocatable
;
7602 pointer
= c
->attr
.pointer
;
7603 dimension
= c
->attr
.dimension
;
7604 codimension
= c
->attr
.codimension
;
7605 is_abstract
= c
->attr
.abstract
;
7618 /* Check for F08:C628. */
7619 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7621 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7626 /* Some checks for the SOURCE tag. */
7629 /* Check F03:C631. */
7630 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7632 gfc_error ("Type of entity at %L is type incompatible with "
7633 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7637 /* Check F03:C632 and restriction following Note 6.18. */
7638 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7641 /* Check F03:C633. */
7642 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7644 gfc_error ("The allocate-object at %L and the source-expr at %L "
7645 "shall have the same kind type parameter",
7646 &e
->where
, &code
->expr3
->where
);
7650 /* Check F2008, C642. */
7651 if (code
->expr3
->ts
.type
== BT_DERIVED
7652 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7653 || (code
->expr3
->ts
.u
.derived
->from_intmod
7654 == INTMOD_ISO_FORTRAN_ENV
7655 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7656 == ISOFORTRAN_LOCK_TYPE
)))
7658 gfc_error ("The source-expr at %L shall neither be of type "
7659 "LOCK_TYPE nor have a LOCK_TYPE component if "
7660 "allocate-object at %L is a coarray",
7661 &code
->expr3
->where
, &e
->where
);
7665 /* Check TS18508, C702/C703. */
7666 if (code
->expr3
->ts
.type
== BT_DERIVED
7667 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7668 || (code
->expr3
->ts
.u
.derived
->from_intmod
7669 == INTMOD_ISO_FORTRAN_ENV
7670 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7671 == ISOFORTRAN_EVENT_TYPE
)))
7673 gfc_error ("The source-expr at %L shall neither be of type "
7674 "EVENT_TYPE nor have a EVENT_TYPE component if "
7675 "allocate-object at %L is a coarray",
7676 &code
->expr3
->where
, &e
->where
);
7681 /* Check F08:C629. */
7682 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7685 gcc_assert (e
->ts
.type
== BT_CLASS
);
7686 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7687 "type-spec or source-expr", sym
->name
, &e
->where
);
7691 /* Check F08:C632. */
7692 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7693 && !UNLIMITED_POLY (e
))
7697 if (!e
->ts
.u
.cl
->length
)
7700 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7701 code
->ext
.alloc
.ts
.u
.cl
->length
);
7702 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7704 gfc_error ("Allocating %s at %L with type-spec requires the same "
7705 "character-length parameter as in the declaration",
7706 sym
->name
, &e
->where
);
7711 /* In the variable definition context checks, gfc_expr_attr is used
7712 on the expression. This is fooled by the array specification
7713 present in e, thus we have to eliminate that one temporarily. */
7714 e2
= remove_last_array_ref (e
);
7717 t
= gfc_check_vardef_context (e2
, true, true, false,
7718 _("ALLOCATE object"));
7720 t
= gfc_check_vardef_context (e2
, false, true, false,
7721 _("ALLOCATE object"));
7726 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7727 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7729 /* For class arrays, the initialization with SOURCE is done
7730 using _copy and trans_call. It is convenient to exploit that
7731 when the allocated type is different from the declared type but
7732 no SOURCE exists by setting expr3. */
7733 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7735 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7736 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7737 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7739 /* We have to zero initialize the integer variable. */
7740 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7743 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7745 /* Make sure the vtab symbol is present when
7746 the module variables are generated. */
7747 gfc_typespec ts
= e
->ts
;
7749 ts
= code
->expr3
->ts
;
7750 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7751 ts
= code
->ext
.alloc
.ts
;
7753 /* Finding the vtab also publishes the type's symbol. Therefore this
7754 statement is necessary. */
7755 gfc_find_derived_vtab (ts
.u
.derived
);
7757 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7759 /* Again, make sure the vtab symbol is present when
7760 the module variables are generated. */
7761 gfc_typespec
*ts
= NULL
;
7763 ts
= &code
->expr3
->ts
;
7765 ts
= &code
->ext
.alloc
.ts
;
7769 /* Finding the vtab also publishes the type's symbol. Therefore this
7770 statement is necessary. */
7774 if (dimension
== 0 && codimension
== 0)
7777 /* Make sure the last reference node is an array specification. */
7779 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7780 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7785 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7786 "in ALLOCATE statement at %L", &e
->where
))
7788 if (code
->expr3
->rank
!= 0)
7789 *array_alloc_wo_spec
= true;
7792 gfc_error ("Array specification or array-valued SOURCE= "
7793 "expression required in ALLOCATE statement at %L",
7800 gfc_error ("Array specification required in ALLOCATE statement "
7801 "at %L", &e
->where
);
7806 /* Make sure that the array section reference makes sense in the
7807 context of an ALLOCATE specification. */
7812 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7814 switch (ar
->dimen_type
[i
])
7816 case DIMEN_THIS_IMAGE
:
7817 gfc_error ("Coarray specification required in ALLOCATE statement "
7818 "at %L", &e
->where
);
7822 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7824 /* If ar->stride[i] is NULL, we issued a previous error. */
7825 if (ar
->stride
[i
] == NULL
)
7826 gfc_error ("Bad array specification in ALLOCATE statement "
7827 "at %L", &e
->where
);
7830 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7832 gfc_error ("Upper cobound is less than lower cobound at %L",
7833 &ar
->start
[i
]->where
);
7839 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7841 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7842 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7844 gfc_error ("Upper cobound is less than lower cobound "
7845 "of 1 at %L", &ar
->start
[i
]->where
);
7855 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7861 for (i
= 0; i
< ar
->dimen
; i
++)
7863 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7866 switch (ar
->dimen_type
[i
])
7872 if (ar
->start
[i
] != NULL
7873 && ar
->end
[i
] != NULL
7874 && ar
->stride
[i
] == NULL
)
7882 case DIMEN_THIS_IMAGE
:
7883 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7889 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7891 sym
= a
->expr
->symtree
->n
.sym
;
7893 /* TODO - check derived type components. */
7894 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7897 if ((ar
->start
[i
] != NULL
7898 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7899 || (ar
->end
[i
] != NULL
7900 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7902 gfc_error ("%qs must not appear in the array specification at "
7903 "%L in the same ALLOCATE statement where it is "
7904 "itself allocated", sym
->name
, &ar
->where
);
7910 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7912 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7913 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7915 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7917 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7918 "statement at %L", &e
->where
);
7924 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7925 && ar
->stride
[i
] == NULL
)
7928 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7942 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7944 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7945 gfc_alloc
*a
, *p
, *q
;
7948 errmsg
= code
->expr2
;
7950 /* Check the stat variable. */
7953 gfc_check_vardef_context (stat
, false, false, false,
7954 _("STAT variable"));
7956 if ((stat
->ts
.type
!= BT_INTEGER
7957 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7958 || stat
->ref
->type
== REF_COMPONENT
)))
7960 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7961 "variable", &stat
->where
);
7963 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7964 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7966 gfc_ref
*ref1
, *ref2
;
7969 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7970 ref1
= ref1
->next
, ref2
= ref2
->next
)
7972 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7974 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7983 gfc_error ("Stat-variable at %L shall not be %sd within "
7984 "the same %s statement", &stat
->where
, fcn
, fcn
);
7990 /* Check the errmsg variable. */
7994 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7997 gfc_check_vardef_context (errmsg
, false, false, false,
7998 _("ERRMSG variable"));
8000 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8001 F18:R930 errmsg-variable is scalar-default-char-variable
8002 F18:R906 default-char-variable is variable
8003 F18:C906 default-char-variable shall be default character. */
8004 if ((errmsg
->ts
.type
!= BT_CHARACTER
8006 && (errmsg
->ref
->type
== REF_ARRAY
8007 || errmsg
->ref
->type
== REF_COMPONENT
)))
8009 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8010 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8011 "variable", &errmsg
->where
);
8013 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8014 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8016 gfc_ref
*ref1
, *ref2
;
8019 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8020 ref1
= ref1
->next
, ref2
= ref2
->next
)
8022 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8024 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8033 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8034 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8040 /* Check that an allocate-object appears only once in the statement. */
8042 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8045 for (q
= p
->next
; q
; q
= q
->next
)
8048 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8050 /* This is a potential collision. */
8051 gfc_ref
*pr
= pe
->ref
;
8052 gfc_ref
*qr
= qe
->ref
;
8054 /* Follow the references until
8055 a) They start to differ, in which case there is no error;
8056 you can deallocate a%b and a%c in a single statement
8057 b) Both of them stop, which is an error
8058 c) One of them stops, which is also an error. */
8061 if (pr
== NULL
&& qr
== NULL
)
8063 gfc_error ("Allocate-object at %L also appears at %L",
8064 &pe
->where
, &qe
->where
);
8067 else if (pr
!= NULL
&& qr
== NULL
)
8069 gfc_error ("Allocate-object at %L is subobject of"
8070 " object at %L", &pe
->where
, &qe
->where
);
8073 else if (pr
== NULL
&& qr
!= NULL
)
8075 gfc_error ("Allocate-object at %L is subobject of"
8076 " object at %L", &qe
->where
, &pe
->where
);
8079 /* Here, pr != NULL && qr != NULL */
8080 gcc_assert(pr
->type
== qr
->type
);
8081 if (pr
->type
== REF_ARRAY
)
8083 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8085 gcc_assert (qr
->type
== REF_ARRAY
);
8087 if (pr
->next
&& qr
->next
)
8090 gfc_array_ref
*par
= &(pr
->u
.ar
);
8091 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8093 for (i
=0; i
<par
->dimen
; i
++)
8095 if ((par
->start
[i
] != NULL
8096 || qar
->start
[i
] != NULL
)
8097 && gfc_dep_compare_expr (par
->start
[i
],
8098 qar
->start
[i
]) != 0)
8105 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8118 if (strcmp (fcn
, "ALLOCATE") == 0)
8120 bool arr_alloc_wo_spec
= false;
8122 /* Resolving the expr3 in the loop over all objects to allocate would
8123 execute loop invariant code for each loop item. Therefore do it just
8125 if (code
->expr3
&& code
->expr3
->mold
8126 && code
->expr3
->ts
.type
== BT_DERIVED
)
8128 /* Default initialization via MOLD (non-polymorphic). */
8129 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8132 gfc_resolve_expr (rhs
);
8133 gfc_free_expr (code
->expr3
);
8137 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8138 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8140 if (arr_alloc_wo_spec
&& code
->expr3
)
8142 /* Mark the allocate to have to take the array specification
8144 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8149 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8150 resolve_deallocate_expr (a
->expr
);
8155 /************ SELECT CASE resolution subroutines ************/
8157 /* Callback function for our mergesort variant. Determines interval
8158 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8159 op1 > op2. Assumes we're not dealing with the default case.
8160 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8161 There are nine situations to check. */
8164 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8168 if (op1
->low
== NULL
) /* op1 = (:L) */
8170 /* op2 = (:N), so overlap. */
8172 /* op2 = (M:) or (M:N), L < M */
8173 if (op2
->low
!= NULL
8174 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8177 else if (op1
->high
== NULL
) /* op1 = (K:) */
8179 /* op2 = (M:), so overlap. */
8181 /* op2 = (:N) or (M:N), K > N */
8182 if (op2
->high
!= NULL
8183 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8186 else /* op1 = (K:L) */
8188 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8189 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8191 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8192 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8194 else /* op2 = (M:N) */
8198 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8201 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8210 /* Merge-sort a double linked case list, detecting overlap in the
8211 process. LIST is the head of the double linked case list before it
8212 is sorted. Returns the head of the sorted list if we don't see any
8213 overlap, or NULL otherwise. */
8216 check_case_overlap (gfc_case
*list
)
8218 gfc_case
*p
, *q
, *e
, *tail
;
8219 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8221 /* If the passed list was empty, return immediately. */
8228 /* Loop unconditionally. The only exit from this loop is a return
8229 statement, when we've finished sorting the case list. */
8236 /* Count the number of merges we do in this pass. */
8239 /* Loop while there exists a merge to be done. */
8244 /* Count this merge. */
8247 /* Cut the list in two pieces by stepping INSIZE places
8248 forward in the list, starting from P. */
8251 for (i
= 0; i
< insize
; i
++)
8260 /* Now we have two lists. Merge them! */
8261 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8263 /* See from which the next case to merge comes from. */
8266 /* P is empty so the next case must come from Q. */
8271 else if (qsize
== 0 || q
== NULL
)
8280 cmp
= compare_cases (p
, q
);
8283 /* The whole case range for P is less than the
8291 /* The whole case range for Q is greater than
8292 the case range for P. */
8299 /* The cases overlap, or they are the same
8300 element in the list. Either way, we must
8301 issue an error and get the next case from P. */
8302 /* FIXME: Sort P and Q by line number. */
8303 gfc_error ("CASE label at %L overlaps with CASE "
8304 "label at %L", &p
->where
, &q
->where
);
8312 /* Add the next element to the merged list. */
8321 /* P has now stepped INSIZE places along, and so has Q. So
8322 they're the same. */
8327 /* If we have done only one merge or none at all, we've
8328 finished sorting the cases. */
8337 /* Otherwise repeat, merging lists twice the size. */
8343 /* Check to see if an expression is suitable for use in a CASE statement.
8344 Makes sure that all case expressions are scalar constants of the same
8345 type. Return false if anything is wrong. */
8348 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8350 if (e
== NULL
) return true;
8352 if (e
->ts
.type
!= case_expr
->ts
.type
)
8354 gfc_error ("Expression in CASE statement at %L must be of type %s",
8355 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8359 /* C805 (R808) For a given case-construct, each case-value shall be of
8360 the same type as case-expr. For character type, length differences
8361 are allowed, but the kind type parameters shall be the same. */
8363 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8365 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8366 &e
->where
, case_expr
->ts
.kind
);
8370 /* Convert the case value kind to that of case expression kind,
8373 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8374 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8378 gfc_error ("Expression in CASE statement at %L must be scalar",
8387 /* Given a completely parsed select statement, we:
8389 - Validate all expressions and code within the SELECT.
8390 - Make sure that the selection expression is not of the wrong type.
8391 - Make sure that no case ranges overlap.
8392 - Eliminate unreachable cases and unreachable code resulting from
8393 removing case labels.
8395 The standard does allow unreachable cases, e.g. CASE (5:3). But
8396 they are a hassle for code generation, and to prevent that, we just
8397 cut them out here. This is not necessary for overlapping cases
8398 because they are illegal and we never even try to generate code.
8400 We have the additional caveat that a SELECT construct could have
8401 been a computed GOTO in the source code. Fortunately we can fairly
8402 easily work around that here: The case_expr for a "real" SELECT CASE
8403 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8404 we have to do is make sure that the case_expr is a scalar integer
8408 resolve_select (gfc_code
*code
, bool select_type
)
8411 gfc_expr
*case_expr
;
8412 gfc_case
*cp
, *default_case
, *tail
, *head
;
8413 int seen_unreachable
;
8419 if (code
->expr1
== NULL
)
8421 /* This was actually a computed GOTO statement. */
8422 case_expr
= code
->expr2
;
8423 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8424 gfc_error ("Selection expression in computed GOTO statement "
8425 "at %L must be a scalar integer expression",
8428 /* Further checking is not necessary because this SELECT was built
8429 by the compiler, so it should always be OK. Just move the
8430 case_expr from expr2 to expr so that we can handle computed
8431 GOTOs as normal SELECTs from here on. */
8432 code
->expr1
= code
->expr2
;
8437 case_expr
= code
->expr1
;
8438 type
= case_expr
->ts
.type
;
8441 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8443 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8444 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8446 /* Punt. Going on here just produce more garbage error messages. */
8451 if (!select_type
&& case_expr
->rank
!= 0)
8453 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8454 "expression", &case_expr
->where
);
8460 /* Raise a warning if an INTEGER case value exceeds the range of
8461 the case-expr. Later, all expressions will be promoted to the
8462 largest kind of all case-labels. */
8464 if (type
== BT_INTEGER
)
8465 for (body
= code
->block
; body
; body
= body
->block
)
8466 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8469 && gfc_check_integer_range (cp
->low
->value
.integer
,
8470 case_expr
->ts
.kind
) != ARITH_OK
)
8471 gfc_warning (0, "Expression in CASE statement at %L is "
8472 "not in the range of %s", &cp
->low
->where
,
8473 gfc_typename (&case_expr
->ts
));
8476 && cp
->low
!= cp
->high
8477 && gfc_check_integer_range (cp
->high
->value
.integer
,
8478 case_expr
->ts
.kind
) != ARITH_OK
)
8479 gfc_warning (0, "Expression in CASE statement at %L is "
8480 "not in the range of %s", &cp
->high
->where
,
8481 gfc_typename (&case_expr
->ts
));
8484 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8485 of the SELECT CASE expression and its CASE values. Walk the lists
8486 of case values, and if we find a mismatch, promote case_expr to
8487 the appropriate kind. */
8489 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8491 for (body
= code
->block
; body
; body
= body
->block
)
8493 /* Walk the case label list. */
8494 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8496 /* Intercept the DEFAULT case. It does not have a kind. */
8497 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8500 /* Unreachable case ranges are discarded, so ignore. */
8501 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8502 && cp
->low
!= cp
->high
8503 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8507 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8508 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8510 if (cp
->high
!= NULL
8511 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8512 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8517 /* Assume there is no DEFAULT case. */
8518 default_case
= NULL
;
8523 for (body
= code
->block
; body
; body
= body
->block
)
8525 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8527 seen_unreachable
= 0;
8529 /* Walk the case label list, making sure that all case labels
8531 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8533 /* Count the number of cases in the whole construct. */
8536 /* Intercept the DEFAULT case. */
8537 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8539 if (default_case
!= NULL
)
8541 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8542 "by a second DEFAULT CASE at %L",
8543 &default_case
->where
, &cp
->where
);
8554 /* Deal with single value cases and case ranges. Errors are
8555 issued from the validation function. */
8556 if (!validate_case_label_expr (cp
->low
, case_expr
)
8557 || !validate_case_label_expr (cp
->high
, case_expr
))
8563 if (type
== BT_LOGICAL
8564 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8565 || cp
->low
!= cp
->high
))
8567 gfc_error ("Logical range in CASE statement at %L is not "
8568 "allowed", &cp
->low
->where
);
8573 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8576 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8577 if (value
& seen_logical
)
8579 gfc_error ("Constant logical value in CASE statement "
8580 "is repeated at %L",
8585 seen_logical
|= value
;
8588 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8589 && cp
->low
!= cp
->high
8590 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8592 if (warn_surprising
)
8593 gfc_warning (OPT_Wsurprising
,
8594 "Range specification at %L can never be matched",
8597 cp
->unreachable
= 1;
8598 seen_unreachable
= 1;
8602 /* If the case range can be matched, it can also overlap with
8603 other cases. To make sure it does not, we put it in a
8604 double linked list here. We sort that with a merge sort
8605 later on to detect any overlapping cases. */
8609 head
->right
= head
->left
= NULL
;
8614 tail
->right
->left
= tail
;
8621 /* It there was a failure in the previous case label, give up
8622 for this case label list. Continue with the next block. */
8626 /* See if any case labels that are unreachable have been seen.
8627 If so, we eliminate them. This is a bit of a kludge because
8628 the case lists for a single case statement (label) is a
8629 single forward linked lists. */
8630 if (seen_unreachable
)
8632 /* Advance until the first case in the list is reachable. */
8633 while (body
->ext
.block
.case_list
!= NULL
8634 && body
->ext
.block
.case_list
->unreachable
)
8636 gfc_case
*n
= body
->ext
.block
.case_list
;
8637 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8639 gfc_free_case_list (n
);
8642 /* Strip all other unreachable cases. */
8643 if (body
->ext
.block
.case_list
)
8645 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8647 if (cp
->next
->unreachable
)
8649 gfc_case
*n
= cp
->next
;
8650 cp
->next
= cp
->next
->next
;
8652 gfc_free_case_list (n
);
8659 /* See if there were overlapping cases. If the check returns NULL,
8660 there was overlap. In that case we don't do anything. If head
8661 is non-NULL, we prepend the DEFAULT case. The sorted list can
8662 then used during code generation for SELECT CASE constructs with
8663 a case expression of a CHARACTER type. */
8666 head
= check_case_overlap (head
);
8668 /* Prepend the default_case if it is there. */
8669 if (head
!= NULL
&& default_case
)
8671 default_case
->left
= NULL
;
8672 default_case
->right
= head
;
8673 head
->left
= default_case
;
8677 /* Eliminate dead blocks that may be the result if we've seen
8678 unreachable case labels for a block. */
8679 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8681 if (body
->block
->ext
.block
.case_list
== NULL
)
8683 /* Cut the unreachable block from the code chain. */
8684 gfc_code
*c
= body
->block
;
8685 body
->block
= c
->block
;
8687 /* Kill the dead block, but not the blocks below it. */
8689 gfc_free_statements (c
);
8693 /* More than two cases is legal but insane for logical selects.
8694 Issue a warning for it. */
8695 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8696 gfc_warning (OPT_Wsurprising
,
8697 "Logical SELECT CASE block at %L has more that two cases",
8702 /* Check if a derived type is extensible. */
8705 gfc_type_is_extensible (gfc_symbol
*sym
)
8707 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8708 || (sym
->attr
.is_class
8709 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8714 resolve_types (gfc_namespace
*ns
);
8716 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8717 correct as well as possibly the array-spec. */
8720 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8724 gcc_assert (sym
->assoc
);
8725 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8727 /* If this is for SELECT TYPE, the target may not yet be set. In that
8728 case, return. Resolution will be called later manually again when
8730 target
= sym
->assoc
->target
;
8733 gcc_assert (!sym
->assoc
->dangling
);
8735 if (resolve_target
&& !gfc_resolve_expr (target
))
8738 /* For variable targets, we get some attributes from the target. */
8739 if (target
->expr_type
== EXPR_VARIABLE
)
8743 gcc_assert (target
->symtree
);
8744 tsym
= target
->symtree
->n
.sym
;
8746 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8747 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8749 sym
->attr
.target
= tsym
->attr
.target
8750 || gfc_expr_attr (target
).pointer
;
8751 if (is_subref_array (target
))
8752 sym
->attr
.subref_array_pointer
= 1;
8755 if (target
->expr_type
== EXPR_NULL
)
8757 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8760 else if (target
->ts
.type
== BT_UNKNOWN
)
8762 gfc_error ("Selector at %L has no type", &target
->where
);
8766 /* Get type if this was not already set. Note that it can be
8767 some other type than the target in case this is a SELECT TYPE
8768 selector! So we must not update when the type is already there. */
8769 if (sym
->ts
.type
== BT_UNKNOWN
)
8770 sym
->ts
= target
->ts
;
8772 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8774 /* See if this is a valid association-to-variable. */
8775 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8776 && !gfc_has_vector_subscript (target
));
8778 /* Finally resolve if this is an array or not. */
8779 if (sym
->attr
.dimension
&& target
->rank
== 0)
8781 /* primary.c makes the assumption that a reference to an associate
8782 name followed by a left parenthesis is an array reference. */
8783 if (sym
->ts
.type
!= BT_CHARACTER
)
8784 gfc_error ("Associate-name %qs at %L is used as array",
8785 sym
->name
, &sym
->declared_at
);
8786 sym
->attr
.dimension
= 0;
8791 /* We cannot deal with class selectors that need temporaries. */
8792 if (target
->ts
.type
== BT_CLASS
8793 && gfc_ref_needs_temporary_p (target
->ref
))
8795 gfc_error ("CLASS selector at %L needs a temporary which is not "
8796 "yet implemented", &target
->where
);
8800 if (target
->ts
.type
== BT_CLASS
)
8801 gfc_fix_class_refs (target
);
8803 if (target
->rank
!= 0)
8806 /* The rank may be incorrectly guessed at parsing, therefore make sure
8807 it is corrected now. */
8808 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8811 sym
->as
= gfc_get_array_spec ();
8813 as
->rank
= target
->rank
;
8814 as
->type
= AS_DEFERRED
;
8815 as
->corank
= gfc_get_corank (target
);
8816 sym
->attr
.dimension
= 1;
8817 if (as
->corank
!= 0)
8818 sym
->attr
.codimension
= 1;
8820 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8822 if (!CLASS_DATA (sym
)->as
)
8823 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8824 as
= CLASS_DATA (sym
)->as
;
8825 as
->rank
= target
->rank
;
8826 as
->type
= AS_DEFERRED
;
8827 as
->corank
= gfc_get_corank (target
);
8828 CLASS_DATA (sym
)->attr
.dimension
= 1;
8829 if (as
->corank
!= 0)
8830 CLASS_DATA (sym
)->attr
.codimension
= 1;
8835 /* target's rank is 0, but the type of the sym is still array valued,
8836 which has to be corrected. */
8837 if (sym
->ts
.type
== BT_CLASS
8838 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8841 symbol_attribute attr
;
8842 /* The associated variable's type is still the array type
8843 correct this now. */
8844 gfc_typespec
*ts
= &target
->ts
;
8847 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8852 ts
= &ref
->u
.c
.component
->ts
;
8855 if (ts
->type
== BT_CLASS
)
8856 ts
= &ts
->u
.derived
->components
->ts
;
8862 /* Create a scalar instance of the current class type. Because the
8863 rank of a class array goes into its name, the type has to be
8864 rebuild. The alternative of (re-)setting just the attributes
8865 and as in the current type, destroys the type also in other
8869 sym
->ts
.type
= BT_CLASS
;
8870 attr
= CLASS_DATA (sym
)->attr
;
8872 attr
.associate_var
= 1;
8873 attr
.dimension
= attr
.codimension
= 0;
8874 attr
.class_pointer
= 1;
8875 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8877 /* Make sure the _vptr is set. */
8878 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8879 if (c
->ts
.u
.derived
== NULL
)
8880 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8881 CLASS_DATA (sym
)->attr
.pointer
= 1;
8882 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8883 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8884 gfc_commit_symbol (sym
->ts
.u
.derived
);
8885 /* _vptr now has the _vtab in it, change it to the _vtype. */
8886 if (c
->ts
.u
.derived
->attr
.vtab
)
8887 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8888 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8889 resolve_types (c
->ts
.u
.derived
->ns
);
8893 /* Mark this as an associate variable. */
8894 sym
->attr
.associate_var
= 1;
8896 /* Fix up the type-spec for CHARACTER types. */
8897 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8900 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8902 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8903 && target
->symtree
->n
.sym
->attr
.dummy
8904 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8906 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8907 sym
->ts
.deferred
= 1;
8910 if (!sym
->ts
.u
.cl
->length
8911 && !sym
->ts
.deferred
8912 && target
->expr_type
== EXPR_CONSTANT
)
8914 sym
->ts
.u
.cl
->length
=
8915 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8916 target
->value
.character
.length
);
8918 else if ((!sym
->ts
.u
.cl
->length
8919 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8920 && target
->expr_type
!= EXPR_VARIABLE
)
8922 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8923 sym
->ts
.deferred
= 1;
8925 /* This is reset in trans-stmt.c after the assignment
8926 of the target expression to the associate name. */
8927 sym
->attr
.allocatable
= 1;
8931 /* If the target is a good class object, so is the associate variable. */
8932 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8933 sym
->attr
.class_ok
= 1;
8937 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8938 array reference, where necessary. The symbols are artificial and so
8939 the dimension attribute and arrayspec can also be set. In addition,
8940 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8941 This is corrected here as well.*/
8944 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8945 int rank
, gfc_ref
*ref
)
8947 gfc_ref
*nref
= (*expr1
)->ref
;
8948 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8949 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8950 (*expr1
)->rank
= rank
;
8951 if (sym1
->ts
.type
== BT_CLASS
)
8953 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8954 (*expr1
)->ts
= sym1
->ts
;
8956 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8957 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8958 CLASS_DATA (sym1
)->as
8959 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8963 sym1
->attr
.dimension
= 1;
8964 if (sym1
->as
== NULL
&& sym2
)
8965 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8968 for (; nref
; nref
= nref
->next
)
8969 if (nref
->next
== NULL
)
8972 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8973 nref
->next
= gfc_copy_ref (ref
);
8974 else if (ref
&& !nref
)
8975 (*expr1
)->ref
= gfc_copy_ref (ref
);
8980 build_loc_call (gfc_expr
*sym_expr
)
8983 loc_call
= gfc_get_expr ();
8984 loc_call
->expr_type
= EXPR_FUNCTION
;
8985 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
8986 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8987 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8988 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8989 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8990 loc_call
->ts
.type
= BT_INTEGER
;
8991 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8992 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8993 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8994 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8995 loc_call
->where
= sym_expr
->where
;
8999 /* Resolve a SELECT TYPE statement. */
9002 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9004 gfc_symbol
*selector_type
;
9005 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9006 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9009 char name
[GFC_MAX_SYMBOL_LEN
];
9013 gfc_ref
* ref
= NULL
;
9014 gfc_expr
*selector_expr
= NULL
;
9016 ns
= code
->ext
.block
.ns
;
9019 /* Check for F03:C813. */
9020 if (code
->expr1
->ts
.type
!= BT_CLASS
9021 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9023 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9024 "at %L", &code
->loc
);
9028 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9033 gfc_ref
*ref2
= NULL
;
9034 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9035 if (ref
->type
== REF_COMPONENT
9036 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9041 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9042 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9043 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9047 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9048 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9049 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9052 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9053 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9055 /* F2008: C803 The selector expression must not be coindexed. */
9056 if (gfc_is_coindexed (code
->expr2
))
9058 gfc_error ("Selector at %L must not be coindexed",
9059 &code
->expr2
->where
);
9066 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9068 if (gfc_is_coindexed (code
->expr1
))
9070 gfc_error ("Selector at %L must not be coindexed",
9071 &code
->expr1
->where
);
9076 /* Loop over TYPE IS / CLASS IS cases. */
9077 for (body
= code
->block
; body
; body
= body
->block
)
9079 c
= body
->ext
.block
.case_list
;
9083 /* Check for repeated cases. */
9084 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9086 gfc_case
*d
= tail
->ext
.block
.case_list
;
9090 if (c
->ts
.type
== d
->ts
.type
9091 && ((c
->ts
.type
== BT_DERIVED
9092 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9093 && !strcmp (c
->ts
.u
.derived
->name
,
9094 d
->ts
.u
.derived
->name
))
9095 || c
->ts
.type
== BT_UNKNOWN
9096 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9097 && c
->ts
.kind
== d
->ts
.kind
)))
9099 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9100 &c
->where
, &d
->where
);
9106 /* Check F03:C815. */
9107 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9108 && !selector_type
->attr
.unlimited_polymorphic
9109 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9111 gfc_error ("Derived type %qs at %L must be extensible",
9112 c
->ts
.u
.derived
->name
, &c
->where
);
9117 /* Check F03:C816. */
9118 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9119 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9120 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9122 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9123 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9124 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9126 gfc_error ("Unexpected intrinsic type %qs at %L",
9127 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9132 /* Check F03:C814. */
9133 if (c
->ts
.type
== BT_CHARACTER
9134 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9136 gfc_error ("The type-spec at %L shall specify that each length "
9137 "type parameter is assumed", &c
->where
);
9142 /* Intercept the DEFAULT case. */
9143 if (c
->ts
.type
== BT_UNKNOWN
)
9145 /* Check F03:C818. */
9148 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9149 "by a second DEFAULT CASE at %L",
9150 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9155 default_case
= body
;
9162 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9163 target if present. If there are any EXIT statements referring to the
9164 SELECT TYPE construct, this is no problem because the gfc_code
9165 reference stays the same and EXIT is equally possible from the BLOCK
9166 it is changed to. */
9167 code
->op
= EXEC_BLOCK
;
9170 gfc_association_list
* assoc
;
9172 assoc
= gfc_get_association_list ();
9173 assoc
->st
= code
->expr1
->symtree
;
9174 assoc
->target
= gfc_copy_expr (code
->expr2
);
9175 assoc
->target
->where
= code
->expr2
->where
;
9176 /* assoc->variable will be set by resolve_assoc_var. */
9178 code
->ext
.block
.assoc
= assoc
;
9179 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9181 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9184 code
->ext
.block
.assoc
= NULL
;
9186 /* Ensure that the selector rank and arrayspec are available to
9187 correct expressions in which they might be missing. */
9188 if (code
->expr2
&& code
->expr2
->rank
)
9190 rank
= code
->expr2
->rank
;
9191 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9192 if (ref
->next
== NULL
)
9194 if (ref
&& ref
->type
== REF_ARRAY
)
9195 ref
= gfc_copy_ref (ref
);
9197 /* Fixup expr1 if necessary. */
9199 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9201 else if (code
->expr1
->rank
)
9203 rank
= code
->expr1
->rank
;
9204 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9205 if (ref
->next
== NULL
)
9207 if (ref
&& ref
->type
== REF_ARRAY
)
9208 ref
= gfc_copy_ref (ref
);
9211 /* Add EXEC_SELECT to switch on type. */
9212 new_st
= gfc_get_code (code
->op
);
9213 new_st
->expr1
= code
->expr1
;
9214 new_st
->expr2
= code
->expr2
;
9215 new_st
->block
= code
->block
;
9216 code
->expr1
= code
->expr2
= NULL
;
9221 ns
->code
->next
= new_st
;
9223 code
->op
= EXEC_SELECT_TYPE
;
9225 /* Use the intrinsic LOC function to generate an integer expression
9226 for the vtable of the selector. Note that the rank of the selector
9227 expression has to be set to zero. */
9228 gfc_add_vptr_component (code
->expr1
);
9229 code
->expr1
->rank
= 0;
9230 code
->expr1
= build_loc_call (code
->expr1
);
9231 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9233 /* Loop over TYPE IS / CLASS IS cases. */
9234 for (body
= code
->block
; body
; body
= body
->block
)
9238 c
= body
->ext
.block
.case_list
;
9240 /* Generate an index integer expression for address of the
9241 TYPE/CLASS vtable and store it in c->low. The hash expression
9242 is stored in c->high and is used to resolve intrinsic cases. */
9243 if (c
->ts
.type
!= BT_UNKNOWN
)
9245 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9247 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9249 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9250 c
->ts
.u
.derived
->hash_value
);
9254 vtab
= gfc_find_vtab (&c
->ts
);
9255 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9256 e
= CLASS_DATA (vtab
)->initializer
;
9257 c
->high
= gfc_copy_expr (e
);
9258 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9261 ts
.kind
= gfc_integer_4_kind
;
9262 ts
.type
= BT_INTEGER
;
9263 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9267 e
= gfc_lval_expr_from_sym (vtab
);
9268 c
->low
= build_loc_call (e
);
9273 /* Associate temporary to selector. This should only be done
9274 when this case is actually true, so build a new ASSOCIATE
9275 that does precisely this here (instead of using the
9278 if (c
->ts
.type
== BT_CLASS
)
9279 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9280 else if (c
->ts
.type
== BT_DERIVED
)
9281 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9282 else if (c
->ts
.type
== BT_CHARACTER
)
9284 HOST_WIDE_INT charlen
= 0;
9285 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9286 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9287 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9288 snprintf (name
, sizeof (name
),
9289 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9290 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9293 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9296 st
= gfc_find_symtree (ns
->sym_root
, name
);
9297 gcc_assert (st
->n
.sym
->assoc
);
9298 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9299 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9300 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9302 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9303 /* Fixup the target expression if necessary. */
9305 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9308 new_st
= gfc_get_code (EXEC_BLOCK
);
9309 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9310 new_st
->ext
.block
.ns
->code
= body
->next
;
9311 body
->next
= new_st
;
9313 /* Chain in the new list only if it is marked as dangling. Otherwise
9314 there is a CASE label overlap and this is already used. Just ignore,
9315 the error is diagnosed elsewhere. */
9316 if (st
->n
.sym
->assoc
->dangling
)
9318 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9319 st
->n
.sym
->assoc
->dangling
= 0;
9322 resolve_assoc_var (st
->n
.sym
, false);
9325 /* Take out CLASS IS cases for separate treatment. */
9327 while (body
&& body
->block
)
9329 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9331 /* Add to class_is list. */
9332 if (class_is
== NULL
)
9334 class_is
= body
->block
;
9339 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9340 tail
->block
= body
->block
;
9343 /* Remove from EXEC_SELECT list. */
9344 body
->block
= body
->block
->block
;
9357 /* Add a default case to hold the CLASS IS cases. */
9358 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9359 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9361 tail
->ext
.block
.case_list
= gfc_get_case ();
9362 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9364 default_case
= tail
;
9367 /* More than one CLASS IS block? */
9368 if (class_is
->block
)
9372 /* Sort CLASS IS blocks by extension level. */
9376 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9379 /* F03:C817 (check for doubles). */
9380 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9381 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9383 gfc_error ("Double CLASS IS block in SELECT TYPE "
9385 &c2
->ext
.block
.case_list
->where
);
9388 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9389 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9392 (*c1
)->block
= c2
->block
;
9402 /* Generate IF chain. */
9403 if_st
= gfc_get_code (EXEC_IF
);
9405 for (body
= class_is
; body
; body
= body
->block
)
9407 new_st
->block
= gfc_get_code (EXEC_IF
);
9408 new_st
= new_st
->block
;
9409 /* Set up IF condition: Call _gfortran_is_extension_of. */
9410 new_st
->expr1
= gfc_get_expr ();
9411 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9412 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9413 new_st
->expr1
->ts
.kind
= 4;
9414 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9415 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9416 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9417 /* Set up arguments. */
9418 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9419 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9420 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9421 new_st
->expr1
->where
= code
->loc
;
9422 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9423 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9424 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9425 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9426 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9427 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9428 new_st
->next
= body
->next
;
9430 if (default_case
->next
)
9432 new_st
->block
= gfc_get_code (EXEC_IF
);
9433 new_st
= new_st
->block
;
9434 new_st
->next
= default_case
->next
;
9437 /* Replace CLASS DEFAULT code by the IF chain. */
9438 default_case
->next
= if_st
;
9441 /* Resolve the internal code. This cannot be done earlier because
9442 it requires that the sym->assoc of selectors is set already. */
9443 gfc_current_ns
= ns
;
9444 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9445 gfc_current_ns
= old_ns
;
9452 /* Resolve a transfer statement. This is making sure that:
9453 -- a derived type being transferred has only non-pointer components
9454 -- a derived type being transferred doesn't have private components, unless
9455 it's being transferred from the module where the type was defined
9456 -- we're not trying to transfer a whole assumed size array. */
9459 resolve_transfer (gfc_code
*code
)
9461 gfc_symbol
*sym
, *derived
;
9465 bool formatted
= false;
9466 gfc_dt
*dt
= code
->ext
.dt
;
9467 gfc_symbol
*dtio_sub
= NULL
;
9471 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9472 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9473 exp
= exp
->value
.op
.op1
;
9475 if (exp
&& exp
->expr_type
== EXPR_NULL
9478 gfc_error ("Invalid context for NULL () intrinsic at %L",
9483 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9484 && exp
->expr_type
!= EXPR_FUNCTION
9485 && exp
->expr_type
!= EXPR_STRUCTURE
))
9488 /* If we are reading, the variable will be changed. Note that
9489 code->ext.dt may be NULL if the TRANSFER is related to
9490 an INQUIRE statement -- but in this case, we are not reading, either. */
9491 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9492 && !gfc_check_vardef_context (exp
, false, false, false,
9496 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9497 || exp
->expr_type
== EXPR_FUNCTION
9498 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9500 /* Go to actual component transferred. */
9501 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9502 if (ref
->type
== REF_COMPONENT
)
9503 ts
= &ref
->u
.c
.component
->ts
;
9505 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9506 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9508 derived
= ts
->u
.derived
;
9510 /* Determine when to use the formatted DTIO procedure. */
9511 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9514 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9515 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9516 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9518 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9521 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9522 /* Check to see if this is a nested DTIO call, with the
9523 dummy as the io-list object. */
9524 if (sym
&& sym
== dtio_sub
&& sym
->formal
9525 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9526 && exp
->ref
== NULL
)
9528 if (!sym
->attr
.recursive
)
9530 gfc_error ("DTIO %s procedure at %L must be recursive",
9531 sym
->name
, &sym
->declared_at
);
9538 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9540 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9541 "it is processed by a defined input/output procedure",
9546 if (ts
->type
== BT_DERIVED
)
9548 /* Check that transferred derived type doesn't contain POINTER
9549 components unless it is processed by a defined input/output
9551 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9553 gfc_error ("Data transfer element at %L cannot have POINTER "
9554 "components unless it is processed by a defined "
9555 "input/output procedure", &code
->loc
);
9560 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9562 gfc_error ("Data transfer element at %L cannot have "
9563 "procedure pointer components", &code
->loc
);
9567 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9569 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9570 "components unless it is processed by a defined "
9571 "input/output procedure", &code
->loc
);
9575 /* C_PTR and C_FUNPTR have private components which means they cannot
9576 be printed. However, if -std=gnu and not -pedantic, allow
9577 the component to be printed to help debugging. */
9578 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9580 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9581 "cannot have PRIVATE components", &code
->loc
))
9584 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9586 gfc_error ("Data transfer element at %L cannot have "
9587 "PRIVATE components unless it is processed by "
9588 "a defined input/output procedure", &code
->loc
);
9593 if (exp
->expr_type
== EXPR_STRUCTURE
)
9596 sym
= exp
->symtree
->n
.sym
;
9598 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9599 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9601 gfc_error ("Data transfer element at %L cannot be a full reference to "
9602 "an assumed-size array", &code
->loc
);
9606 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9607 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9611 /*********** Toplevel code resolution subroutines ***********/
9613 /* Find the set of labels that are reachable from this block. We also
9614 record the last statement in each block. */
9617 find_reachable_labels (gfc_code
*block
)
9624 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9626 /* Collect labels in this block. We don't keep those corresponding
9627 to END {IF|SELECT}, these are checked in resolve_branch by going
9628 up through the code_stack. */
9629 for (c
= block
; c
; c
= c
->next
)
9631 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9632 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9635 /* Merge with labels from parent block. */
9638 gcc_assert (cs_base
->prev
->reachable_labels
);
9639 bitmap_ior_into (cs_base
->reachable_labels
,
9640 cs_base
->prev
->reachable_labels
);
9646 resolve_lock_unlock_event (gfc_code
*code
)
9648 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9649 && code
->expr1
->value
.function
.isym
9650 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9651 remove_caf_get_intrinsic (code
->expr1
);
9653 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9654 && (code
->expr1
->ts
.type
!= BT_DERIVED
9655 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9656 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9657 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9658 || code
->expr1
->rank
!= 0
9659 || (!gfc_is_coarray (code
->expr1
) &&
9660 !gfc_is_coindexed (code
->expr1
))))
9661 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9662 &code
->expr1
->where
);
9663 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9664 && (code
->expr1
->ts
.type
!= BT_DERIVED
9665 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9666 || code
->expr1
->ts
.u
.derived
->from_intmod
9667 != INTMOD_ISO_FORTRAN_ENV
9668 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9669 != ISOFORTRAN_EVENT_TYPE
9670 || code
->expr1
->rank
!= 0))
9671 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9672 &code
->expr1
->where
);
9673 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9674 && !gfc_is_coindexed (code
->expr1
))
9675 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9676 &code
->expr1
->where
);
9677 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9678 gfc_error ("Event variable argument at %L must be a coarray but not "
9679 "coindexed", &code
->expr1
->where
);
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_check_vardef_context (code
->expr2
, false, false, false,
9690 _("STAT variable")))
9695 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9696 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9697 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9698 &code
->expr3
->where
);
9701 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9702 _("ERRMSG variable")))
9705 /* Check for LOCK the ACQUIRED_LOCK. */
9706 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9707 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9708 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9709 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9710 "variable", &code
->expr4
->where
);
9712 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9713 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9714 _("ACQUIRED_LOCK variable")))
9717 /* Check for EVENT WAIT the UNTIL_COUNT. */
9718 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9720 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9721 || code
->expr4
->rank
!= 0)
9722 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9723 "expression", &code
->expr4
->where
);
9729 resolve_critical (gfc_code
*code
)
9731 gfc_symtree
*symtree
;
9732 gfc_symbol
*lock_type
;
9733 char name
[GFC_MAX_SYMBOL_LEN
];
9734 static int serial
= 0;
9736 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9739 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9740 GFC_PREFIX ("lock_type"));
9742 lock_type
= symtree
->n
.sym
;
9745 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9748 lock_type
= symtree
->n
.sym
;
9749 lock_type
->attr
.flavor
= FL_DERIVED
;
9750 lock_type
->attr
.zero_comp
= 1;
9751 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9752 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9755 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9756 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9759 code
->resolved_sym
= symtree
->n
.sym
;
9760 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9761 symtree
->n
.sym
->attr
.referenced
= 1;
9762 symtree
->n
.sym
->attr
.artificial
= 1;
9763 symtree
->n
.sym
->attr
.codimension
= 1;
9764 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9765 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9766 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9767 symtree
->n
.sym
->as
->corank
= 1;
9768 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9769 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9770 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9772 gfc_commit_symbols();
9777 resolve_sync (gfc_code
*code
)
9779 /* Check imageset. The * case matches expr1 == NULL. */
9782 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9783 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9784 "INTEGER expression", &code
->expr1
->where
);
9785 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9786 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9787 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9788 &code
->expr1
->where
);
9789 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9790 && gfc_simplify_expr (code
->expr1
, 0))
9792 gfc_constructor
*cons
;
9793 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9794 for (; cons
; cons
= gfc_constructor_next (cons
))
9795 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9796 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9797 gfc_error ("Imageset argument at %L must between 1 and "
9798 "num_images()", &cons
->expr
->where
);
9803 gfc_resolve_expr (code
->expr2
);
9805 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9806 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9807 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9808 &code
->expr2
->where
);
9811 gfc_resolve_expr (code
->expr3
);
9813 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9814 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9815 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9816 &code
->expr3
->where
);
9820 /* Given a branch to a label, see if the branch is conforming.
9821 The code node describes where the branch is located. */
9824 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9831 /* Step one: is this a valid branching target? */
9833 if (label
->defined
== ST_LABEL_UNKNOWN
)
9835 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9840 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9842 gfc_error ("Statement at %L is not a valid branch target statement "
9843 "for the branch statement at %L", &label
->where
, &code
->loc
);
9847 /* Step two: make sure this branch is not a branch to itself ;-) */
9849 if (code
->here
== label
)
9852 "Branch at %L may result in an infinite loop", &code
->loc
);
9856 /* Step three: See if the label is in the same block as the
9857 branching statement. The hard work has been done by setting up
9858 the bitmap reachable_labels. */
9860 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9862 /* Check now whether there is a CRITICAL construct; if so, check
9863 whether the label is still visible outside of the CRITICAL block,
9864 which is invalid. */
9865 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9867 if (stack
->current
->op
== EXEC_CRITICAL
9868 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9869 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9870 "label at %L", &code
->loc
, &label
->where
);
9871 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9872 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9873 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9874 "for label at %L", &code
->loc
, &label
->where
);
9880 /* Step four: If we haven't found the label in the bitmap, it may
9881 still be the label of the END of the enclosing block, in which
9882 case we find it by going up the code_stack. */
9884 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9886 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9888 if (stack
->current
->op
== EXEC_CRITICAL
)
9890 /* Note: A label at END CRITICAL does not leave the CRITICAL
9891 construct as END CRITICAL is still part of it. */
9892 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9893 " at %L", &code
->loc
, &label
->where
);
9896 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9898 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9899 "label at %L", &code
->loc
, &label
->where
);
9906 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9910 /* The label is not in an enclosing block, so illegal. This was
9911 allowed in Fortran 66, so we allow it as extension. No
9912 further checks are necessary in this case. */
9913 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9914 "as the GOTO statement at %L", &label
->where
,
9920 /* Check whether EXPR1 has the same shape as EXPR2. */
9923 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9925 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9926 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9927 bool result
= false;
9930 /* Compare the rank. */
9931 if (expr1
->rank
!= expr2
->rank
)
9934 /* Compare the size of each dimension. */
9935 for (i
=0; i
<expr1
->rank
; i
++)
9937 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9940 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9943 if (mpz_cmp (shape
[i
], shape2
[i
]))
9947 /* When either of the two expression is an assumed size array, we
9948 ignore the comparison of dimension sizes. */
9953 gfc_clear_shape (shape
, i
);
9954 gfc_clear_shape (shape2
, i
);
9959 /* Check whether a WHERE assignment target or a WHERE mask expression
9960 has the same shape as the outmost WHERE mask expression. */
9963 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9969 cblock
= code
->block
;
9971 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9972 In case of nested WHERE, only the outmost one is stored. */
9973 if (mask
== NULL
) /* outmost WHERE */
9975 else /* inner WHERE */
9982 /* Check if the mask-expr has a consistent shape with the
9983 outmost WHERE mask-expr. */
9984 if (!resolve_where_shape (cblock
->expr1
, e
))
9985 gfc_error ("WHERE mask at %L has inconsistent shape",
9986 &cblock
->expr1
->where
);
9989 /* the assignment statement of a WHERE statement, or the first
9990 statement in where-body-construct of a WHERE construct */
9991 cnext
= cblock
->next
;
9996 /* WHERE assignment statement */
9999 /* Check shape consistent for WHERE assignment target. */
10000 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10001 gfc_error ("WHERE assignment target at %L has "
10002 "inconsistent shape", &cnext
->expr1
->where
);
10006 case EXEC_ASSIGN_CALL
:
10007 resolve_call (cnext
);
10008 if (!cnext
->resolved_sym
->attr
.elemental
)
10009 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10010 &cnext
->ext
.actual
->expr
->where
);
10013 /* WHERE or WHERE construct is part of a where-body-construct */
10015 resolve_where (cnext
, e
);
10019 gfc_error ("Unsupported statement inside WHERE at %L",
10022 /* the next statement within the same where-body-construct */
10023 cnext
= cnext
->next
;
10025 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10026 cblock
= cblock
->block
;
10031 /* Resolve assignment in FORALL construct.
10032 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10033 FORALL index variables. */
10036 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10040 for (n
= 0; n
< nvar
; n
++)
10042 gfc_symbol
*forall_index
;
10044 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10046 /* Check whether the assignment target is one of the FORALL index
10048 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10049 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10050 gfc_error ("Assignment to a FORALL index variable at %L",
10051 &code
->expr1
->where
);
10054 /* If one of the FORALL index variables doesn't appear in the
10055 assignment variable, then there could be a many-to-one
10056 assignment. Emit a warning rather than an error because the
10057 mask could be resolving this problem. */
10058 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10059 gfc_warning (0, "The FORALL with index %qs is not used on the "
10060 "left side of the assignment at %L and so might "
10061 "cause multiple assignment to this object",
10062 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10068 /* Resolve WHERE statement in FORALL construct. */
10071 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10072 gfc_expr
**var_expr
)
10077 cblock
= code
->block
;
10080 /* the assignment statement of a WHERE statement, or the first
10081 statement in where-body-construct of a WHERE construct */
10082 cnext
= cblock
->next
;
10087 /* WHERE assignment statement */
10089 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10092 /* WHERE operator assignment statement */
10093 case EXEC_ASSIGN_CALL
:
10094 resolve_call (cnext
);
10095 if (!cnext
->resolved_sym
->attr
.elemental
)
10096 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10097 &cnext
->ext
.actual
->expr
->where
);
10100 /* WHERE or WHERE construct is part of a where-body-construct */
10102 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10106 gfc_error ("Unsupported statement inside WHERE at %L",
10109 /* the next statement within the same where-body-construct */
10110 cnext
= cnext
->next
;
10112 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10113 cblock
= cblock
->block
;
10118 /* Traverse the FORALL body to check whether the following errors exist:
10119 1. For assignment, check if a many-to-one assignment happens.
10120 2. For WHERE statement, check the WHERE body to see if there is any
10121 many-to-one assignment. */
10124 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10128 c
= code
->block
->next
;
10134 case EXEC_POINTER_ASSIGN
:
10135 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10138 case EXEC_ASSIGN_CALL
:
10142 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10143 there is no need to handle it here. */
10147 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10152 /* The next statement in the FORALL body. */
10158 /* Counts the number of iterators needed inside a forall construct, including
10159 nested forall constructs. This is used to allocate the needed memory
10160 in gfc_resolve_forall. */
10163 gfc_count_forall_iterators (gfc_code
*code
)
10165 int max_iters
, sub_iters
, current_iters
;
10166 gfc_forall_iterator
*fa
;
10168 gcc_assert(code
->op
== EXEC_FORALL
);
10172 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10175 code
= code
->block
->next
;
10179 if (code
->op
== EXEC_FORALL
)
10181 sub_iters
= gfc_count_forall_iterators (code
);
10182 if (sub_iters
> max_iters
)
10183 max_iters
= sub_iters
;
10188 return current_iters
+ max_iters
;
10192 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10193 gfc_resolve_forall_body to resolve the FORALL body. */
10196 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10198 static gfc_expr
**var_expr
;
10199 static int total_var
= 0;
10200 static int nvar
= 0;
10201 int i
, old_nvar
, tmp
;
10202 gfc_forall_iterator
*fa
;
10206 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10209 /* Start to resolve a FORALL construct */
10210 if (forall_save
== 0)
10212 /* Count the total number of FORALL indices in the nested FORALL
10213 construct in order to allocate the VAR_EXPR with proper size. */
10214 total_var
= gfc_count_forall_iterators (code
);
10216 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10217 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10220 /* The information about FORALL iterator, including FORALL indices start, end
10221 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10222 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10224 /* Fortran 20008: C738 (R753). */
10225 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10227 gfc_error ("FORALL index-name at %L must be a scalar variable "
10228 "of type integer", &fa
->var
->where
);
10232 /* Check if any outer FORALL index name is the same as the current
10234 for (i
= 0; i
< nvar
; i
++)
10236 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10237 gfc_error ("An outer FORALL construct already has an index "
10238 "with this name %L", &fa
->var
->where
);
10241 /* Record the current FORALL index. */
10242 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10246 /* No memory leak. */
10247 gcc_assert (nvar
<= total_var
);
10250 /* Resolve the FORALL body. */
10251 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10253 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10254 gfc_resolve_blocks (code
->block
, ns
);
10258 /* Free only the VAR_EXPRs allocated in this frame. */
10259 for (i
= nvar
; i
< tmp
; i
++)
10260 gfc_free_expr (var_expr
[i
]);
10264 /* We are in the outermost FORALL construct. */
10265 gcc_assert (forall_save
== 0);
10267 /* VAR_EXPR is not needed any more. */
10274 /* Resolve a BLOCK construct statement. */
10277 resolve_block_construct (gfc_code
* code
)
10279 /* Resolve the BLOCK's namespace. */
10280 gfc_resolve (code
->ext
.block
.ns
);
10282 /* For an ASSOCIATE block, the associations (and their targets) are already
10283 resolved during resolve_symbol. */
10287 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10291 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10295 for (; b
; b
= b
->block
)
10297 t
= gfc_resolve_expr (b
->expr1
);
10298 if (!gfc_resolve_expr (b
->expr2
))
10304 if (t
&& b
->expr1
!= NULL
10305 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10306 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10312 && b
->expr1
!= NULL
10313 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10314 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10319 resolve_branch (b
->label1
, b
);
10323 resolve_block_construct (b
);
10327 case EXEC_SELECT_TYPE
:
10330 case EXEC_DO_WHILE
:
10331 case EXEC_DO_CONCURRENT
:
10332 case EXEC_CRITICAL
:
10335 case EXEC_IOLENGTH
:
10339 case EXEC_OMP_ATOMIC
:
10340 case EXEC_OACC_ATOMIC
:
10342 gfc_omp_atomic_op aop
10343 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10345 /* Verify this before calling gfc_resolve_code, which might
10347 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10348 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10349 && b
->next
->next
== NULL
)
10350 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10351 && b
->next
->next
!= NULL
10352 && b
->next
->next
->op
== EXEC_ASSIGN
10353 && b
->next
->next
->next
== NULL
));
10357 case EXEC_OACC_PARALLEL_LOOP
:
10358 case EXEC_OACC_PARALLEL
:
10359 case EXEC_OACC_KERNELS_LOOP
:
10360 case EXEC_OACC_KERNELS
:
10361 case EXEC_OACC_DATA
:
10362 case EXEC_OACC_HOST_DATA
:
10363 case EXEC_OACC_LOOP
:
10364 case EXEC_OACC_UPDATE
:
10365 case EXEC_OACC_WAIT
:
10366 case EXEC_OACC_CACHE
:
10367 case EXEC_OACC_ENTER_DATA
:
10368 case EXEC_OACC_EXIT_DATA
:
10369 case EXEC_OACC_ROUTINE
:
10370 case EXEC_OMP_CRITICAL
:
10371 case EXEC_OMP_DISTRIBUTE
:
10372 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10373 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10374 case EXEC_OMP_DISTRIBUTE_SIMD
:
10376 case EXEC_OMP_DO_SIMD
:
10377 case EXEC_OMP_MASTER
:
10378 case EXEC_OMP_ORDERED
:
10379 case EXEC_OMP_PARALLEL
:
10380 case EXEC_OMP_PARALLEL_DO
:
10381 case EXEC_OMP_PARALLEL_DO_SIMD
:
10382 case EXEC_OMP_PARALLEL_SECTIONS
:
10383 case EXEC_OMP_PARALLEL_WORKSHARE
:
10384 case EXEC_OMP_SECTIONS
:
10385 case EXEC_OMP_SIMD
:
10386 case EXEC_OMP_SINGLE
:
10387 case EXEC_OMP_TARGET
:
10388 case EXEC_OMP_TARGET_DATA
:
10389 case EXEC_OMP_TARGET_ENTER_DATA
:
10390 case EXEC_OMP_TARGET_EXIT_DATA
:
10391 case EXEC_OMP_TARGET_PARALLEL
:
10392 case EXEC_OMP_TARGET_PARALLEL_DO
:
10393 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10394 case EXEC_OMP_TARGET_SIMD
:
10395 case EXEC_OMP_TARGET_TEAMS
:
10396 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10397 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10398 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10399 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10400 case EXEC_OMP_TARGET_UPDATE
:
10401 case EXEC_OMP_TASK
:
10402 case EXEC_OMP_TASKGROUP
:
10403 case EXEC_OMP_TASKLOOP
:
10404 case EXEC_OMP_TASKLOOP_SIMD
:
10405 case EXEC_OMP_TASKWAIT
:
10406 case EXEC_OMP_TASKYIELD
:
10407 case EXEC_OMP_TEAMS
:
10408 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10409 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10410 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10411 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10412 case EXEC_OMP_WORKSHARE
:
10416 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10419 gfc_resolve_code (b
->next
, ns
);
10424 /* Does everything to resolve an ordinary assignment. Returns true
10425 if this is an interface assignment. */
10427 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10434 symbol_attribute attr
;
10436 if (gfc_extend_assign (code
, ns
))
10440 if (code
->op
== EXEC_ASSIGN_CALL
)
10442 lhs
= code
->ext
.actual
->expr
;
10443 rhsptr
= &code
->ext
.actual
->next
->expr
;
10447 gfc_actual_arglist
* args
;
10448 gfc_typebound_proc
* tbp
;
10450 gcc_assert (code
->op
== EXEC_COMPCALL
);
10452 args
= code
->expr1
->value
.compcall
.actual
;
10454 rhsptr
= &args
->next
->expr
;
10456 tbp
= code
->expr1
->value
.compcall
.tbp
;
10457 gcc_assert (!tbp
->is_generic
);
10460 /* Make a temporary rhs when there is a default initializer
10461 and rhs is the same symbol as the lhs. */
10462 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10463 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10464 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10465 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10466 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10475 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10476 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10480 /* Handle the case of a BOZ literal on the RHS. */
10481 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10484 if (warn_surprising
)
10485 gfc_warning (OPT_Wsurprising
,
10486 "BOZ literal at %L is bitwise transferred "
10487 "non-integer symbol %qs", &code
->loc
,
10488 lhs
->symtree
->n
.sym
->name
);
10490 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10492 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10494 if (rc
== ARITH_UNDERFLOW
)
10495 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10496 ". This check can be disabled with the option "
10497 "%<-fno-range-check%>", &rhs
->where
);
10498 else if (rc
== ARITH_OVERFLOW
)
10499 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10500 ". This check can be disabled with the option "
10501 "%<-fno-range-check%>", &rhs
->where
);
10502 else if (rc
== ARITH_NAN
)
10503 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10504 ". This check can be disabled with the option "
10505 "%<-fno-range-check%>", &rhs
->where
);
10510 if (lhs
->ts
.type
== BT_CHARACTER
10511 && warn_character_truncation
)
10513 HOST_WIDE_INT llen
= 0, rlen
= 0;
10514 if (lhs
->ts
.u
.cl
!= NULL
10515 && lhs
->ts
.u
.cl
->length
!= NULL
10516 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10517 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10519 if (rhs
->expr_type
== EXPR_CONSTANT
)
10520 rlen
= rhs
->value
.character
.length
;
10522 else if (rhs
->ts
.u
.cl
!= NULL
10523 && rhs
->ts
.u
.cl
->length
!= NULL
10524 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10525 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10527 if (rlen
&& llen
&& rlen
> llen
)
10528 gfc_warning_now (OPT_Wcharacter_truncation
,
10529 "CHARACTER expression will be truncated "
10530 "in assignment (%ld/%ld) at %L",
10531 (long) llen
, (long) rlen
, &code
->loc
);
10534 /* Ensure that a vector index expression for the lvalue is evaluated
10535 to a temporary if the lvalue symbol is referenced in it. */
10538 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10539 if (ref
->type
== REF_ARRAY
)
10541 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10542 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10543 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10544 ref
->u
.ar
.start
[n
]))
10546 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10550 if (gfc_pure (NULL
))
10552 if (lhs
->ts
.type
== BT_DERIVED
10553 && lhs
->expr_type
== EXPR_VARIABLE
10554 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10555 && rhs
->expr_type
== EXPR_VARIABLE
10556 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10557 || gfc_is_coindexed (rhs
)))
10559 /* F2008, C1283. */
10560 if (gfc_is_coindexed (rhs
))
10561 gfc_error ("Coindexed expression at %L is assigned to "
10562 "a derived type variable with a POINTER "
10563 "component in a PURE procedure",
10566 gfc_error ("The impure variable at %L is assigned to "
10567 "a derived type variable with a POINTER "
10568 "component in a PURE procedure (12.6)",
10573 /* Fortran 2008, C1283. */
10574 if (gfc_is_coindexed (lhs
))
10576 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10577 "procedure", &rhs
->where
);
10582 if (gfc_implicit_pure (NULL
))
10584 if (lhs
->expr_type
== EXPR_VARIABLE
10585 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10586 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10587 gfc_unset_implicit_pure (NULL
);
10589 if (lhs
->ts
.type
== BT_DERIVED
10590 && lhs
->expr_type
== EXPR_VARIABLE
10591 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10592 && rhs
->expr_type
== EXPR_VARIABLE
10593 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10594 || gfc_is_coindexed (rhs
)))
10595 gfc_unset_implicit_pure (NULL
);
10597 /* Fortran 2008, C1283. */
10598 if (gfc_is_coindexed (lhs
))
10599 gfc_unset_implicit_pure (NULL
);
10602 /* F2008, 7.2.1.2. */
10603 attr
= gfc_expr_attr (lhs
);
10604 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10606 if (attr
.codimension
)
10608 gfc_error ("Assignment to polymorphic coarray at %L is not "
10609 "permitted", &lhs
->where
);
10612 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10613 "polymorphic variable at %L", &lhs
->where
))
10615 if (!flag_realloc_lhs
)
10617 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10618 "requires %<-frealloc-lhs%>", &lhs
->where
);
10622 else if (lhs
->ts
.type
== BT_CLASS
)
10624 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10625 "assignment at %L - check that there is a matching specific "
10626 "subroutine for '=' operator", &lhs
->where
);
10630 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10632 /* F2008, Section 7.2.1.2. */
10633 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10635 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10636 "component in assignment at %L", &lhs
->where
);
10640 /* Assign the 'data' of a class object to a derived type. */
10641 if (lhs
->ts
.type
== BT_DERIVED
10642 && rhs
->ts
.type
== BT_CLASS
10643 && rhs
->expr_type
!= EXPR_ARRAY
)
10644 gfc_add_data_component (rhs
);
10646 /* Make sure there is a vtable and, in particular, a _copy for the
10648 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10649 gfc_find_vtab (&rhs
->ts
);
10651 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10653 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10654 && code
->expr2
->value
.function
.isym
10655 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10656 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10657 && !gfc_expr_attr (rhs
).allocatable
10658 && !gfc_has_vector_subscript (rhs
)));
10660 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10662 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10663 Additionally, insert this code when the RHS is a CAF as we then use the
10664 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10665 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10666 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10668 if (caf_convert_to_send
)
10670 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10671 && code
->expr2
->value
.function
.isym
10672 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10673 remove_caf_get_intrinsic (code
->expr2
);
10674 code
->op
= EXEC_CALL
;
10675 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10676 code
->resolved_sym
= code
->symtree
->n
.sym
;
10677 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10678 code
->resolved_sym
->attr
.intrinsic
= 1;
10679 code
->resolved_sym
->attr
.subroutine
= 1;
10680 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10681 gfc_commit_symbol (code
->resolved_sym
);
10682 code
->ext
.actual
= gfc_get_actual_arglist ();
10683 code
->ext
.actual
->expr
= lhs
;
10684 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10685 code
->ext
.actual
->next
->expr
= rhs
;
10686 code
->expr1
= NULL
;
10687 code
->expr2
= NULL
;
10694 /* Add a component reference onto an expression. */
10697 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10702 ref
= &((*ref
)->next
);
10703 *ref
= gfc_get_ref ();
10704 (*ref
)->type
= REF_COMPONENT
;
10705 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10706 (*ref
)->u
.c
.component
= c
;
10709 /* Add a full array ref, as necessary. */
10712 gfc_add_full_array_ref (e
, c
->as
);
10713 e
->rank
= c
->as
->rank
;
10718 /* Build an assignment. Keep the argument 'op' for future use, so that
10719 pointer assignments can be made. */
10722 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10723 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10725 gfc_code
*this_code
;
10727 this_code
= gfc_get_code (op
);
10728 this_code
->next
= NULL
;
10729 this_code
->expr1
= gfc_copy_expr (expr1
);
10730 this_code
->expr2
= gfc_copy_expr (expr2
);
10731 this_code
->loc
= loc
;
10732 if (comp1
&& comp2
)
10734 add_comp_ref (this_code
->expr1
, comp1
);
10735 add_comp_ref (this_code
->expr2
, comp2
);
10742 /* Makes a temporary variable expression based on the characteristics of
10743 a given variable expression. */
10746 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10748 static int serial
= 0;
10749 char name
[GFC_MAX_SYMBOL_LEN
];
10751 gfc_array_spec
*as
;
10752 gfc_array_ref
*aref
;
10755 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10756 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10757 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10759 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10760 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10762 e
->value
.character
.length
);
10768 /* Obtain the arrayspec for the temporary. */
10769 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10770 && e
->expr_type
!= EXPR_FUNCTION
10771 && e
->expr_type
!= EXPR_OP
)
10773 aref
= gfc_find_array_ref (e
);
10774 if (e
->expr_type
== EXPR_VARIABLE
10775 && e
->symtree
->n
.sym
->as
== aref
->as
)
10779 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10780 if (ref
->type
== REF_COMPONENT
10781 && ref
->u
.c
.component
->as
== aref
->as
)
10789 /* Add the attributes and the arrayspec to the temporary. */
10790 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10791 tmp
->n
.sym
->attr
.function
= 0;
10792 tmp
->n
.sym
->attr
.result
= 0;
10793 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10794 tmp
->n
.sym
->attr
.dummy
= 0;
10795 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10799 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10802 if (as
->type
== AS_DEFERRED
)
10803 tmp
->n
.sym
->attr
.allocatable
= 1;
10805 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10806 || e
->expr_type
== EXPR_FUNCTION
10807 || e
->expr_type
== EXPR_OP
))
10809 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10810 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10811 tmp
->n
.sym
->as
->rank
= e
->rank
;
10812 tmp
->n
.sym
->attr
.allocatable
= 1;
10813 tmp
->n
.sym
->attr
.dimension
= 1;
10816 tmp
->n
.sym
->attr
.dimension
= 0;
10818 gfc_set_sym_referenced (tmp
->n
.sym
);
10819 gfc_commit_symbol (tmp
->n
.sym
);
10820 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10822 /* Should the lhs be a section, use its array ref for the
10823 temporary expression. */
10824 if (aref
&& aref
->type
!= AR_FULL
)
10826 gfc_free_ref_list (e
->ref
);
10827 e
->ref
= gfc_copy_ref (ref
);
10833 /* Add one line of code to the code chain, making sure that 'head' and
10834 'tail' are appropriately updated. */
10837 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10839 gcc_assert (this_code
);
10841 *head
= *tail
= *this_code
;
10843 *tail
= gfc_append_code (*tail
, *this_code
);
10848 /* Counts the potential number of part array references that would
10849 result from resolution of typebound defined assignments. */
10852 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10855 int c_depth
= 0, t_depth
;
10857 for (c
= derived
->components
; c
; c
= c
->next
)
10859 if ((!gfc_bt_struct (c
->ts
.type
)
10861 || c
->attr
.allocatable
10862 || c
->attr
.proc_pointer_comp
10863 || c
->attr
.class_pointer
10864 || c
->attr
.proc_pointer
)
10865 && !c
->attr
.defined_assign_comp
)
10868 if (c
->as
&& c_depth
== 0)
10871 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10872 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10877 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10879 return depth
+ c_depth
;
10883 /* Implement 7.2.1.3 of the F08 standard:
10884 "An intrinsic assignment where the variable is of derived type is
10885 performed as if each component of the variable were assigned from the
10886 corresponding component of expr using pointer assignment (7.2.2) for
10887 each pointer component, defined assignment for each nonpointer
10888 nonallocatable component of a type that has a type-bound defined
10889 assignment consistent with the component, intrinsic assignment for
10890 each other nonpointer nonallocatable component, ..."
10892 The pointer assignments are taken care of by the intrinsic
10893 assignment of the structure itself. This function recursively adds
10894 defined assignments where required. The recursion is accomplished
10895 by calling gfc_resolve_code.
10897 When the lhs in a defined assignment has intent INOUT, we need a
10898 temporary for the lhs. In pseudo-code:
10900 ! Only call function lhs once.
10901 if (lhs is not a constant or an variable)
10904 ! Do the intrinsic assignment
10906 ! Now do the defined assignments
10907 do over components with typebound defined assignment [%cmp]
10908 #if one component's assignment procedure is INOUT
10910 #if expr2 non-variable
10916 t1%cmp {defined=} expr2%cmp
10922 expr1%cmp {defined=} expr2%cmp
10926 /* The temporary assignments have to be put on top of the additional
10927 code to avoid the result being changed by the intrinsic assignment.
10929 static int component_assignment_level
= 0;
10930 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10933 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10935 gfc_component
*comp1
, *comp2
;
10936 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10938 int error_count
, depth
;
10940 gfc_get_errors (NULL
, &error_count
);
10942 /* Filter out continuing processing after an error. */
10944 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10945 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10948 /* TODO: Handle more than one part array reference in assignments. */
10949 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10950 (*code
)->expr1
->rank
? 1 : 0);
10953 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10954 "done because multiple part array references would "
10955 "occur in intermediate expressions.", &(*code
)->loc
);
10959 component_assignment_level
++;
10961 /* Create a temporary so that functions get called only once. */
10962 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10963 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10965 gfc_expr
*tmp_expr
;
10967 /* Assign the rhs to the temporary. */
10968 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10969 this_code
= build_assignment (EXEC_ASSIGN
,
10970 tmp_expr
, (*code
)->expr2
,
10971 NULL
, NULL
, (*code
)->loc
);
10972 /* Add the code and substitute the rhs expression. */
10973 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10974 gfc_free_expr ((*code
)->expr2
);
10975 (*code
)->expr2
= tmp_expr
;
10978 /* Do the intrinsic assignment. This is not needed if the lhs is one
10979 of the temporaries generated here, since the intrinsic assignment
10980 to the final result already does this. */
10981 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10983 this_code
= build_assignment (EXEC_ASSIGN
,
10984 (*code
)->expr1
, (*code
)->expr2
,
10985 NULL
, NULL
, (*code
)->loc
);
10986 add_code_to_chain (&this_code
, &head
, &tail
);
10989 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10990 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10993 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10995 bool inout
= false;
10997 /* The intrinsic assignment does the right thing for pointers
10998 of all kinds and allocatable components. */
10999 if (!gfc_bt_struct (comp1
->ts
.type
)
11000 || comp1
->attr
.pointer
11001 || comp1
->attr
.allocatable
11002 || comp1
->attr
.proc_pointer_comp
11003 || comp1
->attr
.class_pointer
11004 || comp1
->attr
.proc_pointer
)
11007 /* Make an assigment for this component. */
11008 this_code
= build_assignment (EXEC_ASSIGN
,
11009 (*code
)->expr1
, (*code
)->expr2
,
11010 comp1
, comp2
, (*code
)->loc
);
11012 /* Convert the assignment if there is a defined assignment for
11013 this type. Otherwise, using the call from gfc_resolve_code,
11014 recurse into its components. */
11015 gfc_resolve_code (this_code
, ns
);
11017 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11019 gfc_formal_arglist
*dummy_args
;
11021 /* Check that there is a typebound defined assignment. If not,
11022 then this must be a module defined assignment. We cannot
11023 use the defined_assign_comp attribute here because it must
11024 be this derived type that has the defined assignment and not
11026 if (!(comp1
->ts
.u
.derived
->f2k_derived
11027 && comp1
->ts
.u
.derived
->f2k_derived
11028 ->tb_op
[INTRINSIC_ASSIGN
]))
11030 gfc_free_statements (this_code
);
11035 /* If the first argument of the subroutine has intent INOUT
11036 a temporary must be generated and used instead. */
11037 rsym
= this_code
->resolved_sym
;
11038 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11040 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11042 gfc_code
*temp_code
;
11045 /* Build the temporary required for the assignment and put
11046 it at the head of the generated code. */
11049 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11050 temp_code
= build_assignment (EXEC_ASSIGN
,
11051 t1
, (*code
)->expr1
,
11052 NULL
, NULL
, (*code
)->loc
);
11054 /* For allocatable LHS, check whether it is allocated. Note
11055 that allocatable components with defined assignment are
11056 not yet support. See PR 57696. */
11057 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11061 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11062 block
= gfc_get_code (EXEC_IF
);
11063 block
->block
= gfc_get_code (EXEC_IF
);
11064 block
->block
->expr1
11065 = gfc_build_intrinsic_call (ns
,
11066 GFC_ISYM_ALLOCATED
, "allocated",
11067 (*code
)->loc
, 1, e
);
11068 block
->block
->next
= temp_code
;
11071 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11074 /* Replace the first actual arg with the component of the
11076 gfc_free_expr (this_code
->ext
.actual
->expr
);
11077 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11078 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11080 /* If the LHS variable is allocatable and wasn't allocated and
11081 the temporary is allocatable, pointer assign the address of
11082 the freshly allocated LHS to the temporary. */
11083 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11084 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11089 cond
= gfc_get_expr ();
11090 cond
->ts
.type
= BT_LOGICAL
;
11091 cond
->ts
.kind
= gfc_default_logical_kind
;
11092 cond
->expr_type
= EXPR_OP
;
11093 cond
->where
= (*code
)->loc
;
11094 cond
->value
.op
.op
= INTRINSIC_NOT
;
11095 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11096 GFC_ISYM_ALLOCATED
, "allocated",
11097 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11098 block
= gfc_get_code (EXEC_IF
);
11099 block
->block
= gfc_get_code (EXEC_IF
);
11100 block
->block
->expr1
= cond
;
11101 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11102 t1
, (*code
)->expr1
,
11103 NULL
, NULL
, (*code
)->loc
);
11104 add_code_to_chain (&block
, &head
, &tail
);
11108 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11110 /* Don't add intrinsic assignments since they are already
11111 effected by the intrinsic assignment of the structure. */
11112 gfc_free_statements (this_code
);
11117 add_code_to_chain (&this_code
, &head
, &tail
);
11121 /* Transfer the value to the final result. */
11122 this_code
= build_assignment (EXEC_ASSIGN
,
11123 (*code
)->expr1
, t1
,
11124 comp1
, comp2
, (*code
)->loc
);
11125 add_code_to_chain (&this_code
, &head
, &tail
);
11129 /* Put the temporary assignments at the top of the generated code. */
11130 if (tmp_head
&& component_assignment_level
== 1)
11132 gfc_append_code (tmp_head
, head
);
11134 tmp_head
= tmp_tail
= NULL
;
11137 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11138 // not accidentally deallocated. Hence, nullify t1.
11139 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11140 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11146 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11147 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11148 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11149 block
= gfc_get_code (EXEC_IF
);
11150 block
->block
= gfc_get_code (EXEC_IF
);
11151 block
->block
->expr1
= cond
;
11152 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11153 t1
, gfc_get_null_expr (&(*code
)->loc
),
11154 NULL
, NULL
, (*code
)->loc
);
11155 gfc_append_code (tail
, block
);
11159 /* Now attach the remaining code chain to the input code. Step on
11160 to the end of the new code since resolution is complete. */
11161 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11162 tail
->next
= (*code
)->next
;
11163 /* Overwrite 'code' because this would place the intrinsic assignment
11164 before the temporary for the lhs is created. */
11165 gfc_free_expr ((*code
)->expr1
);
11166 gfc_free_expr ((*code
)->expr2
);
11172 component_assignment_level
--;
11176 /* F2008: Pointer function assignments are of the form:
11177 ptr_fcn (args) = expr
11178 This function breaks these assignments into two statements:
11179 temporary_pointer => ptr_fcn(args)
11180 temporary_pointer = expr */
11183 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11185 gfc_expr
*tmp_ptr_expr
;
11186 gfc_code
*this_code
;
11187 gfc_component
*comp
;
11190 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11193 /* Even if standard does not support this feature, continue to build
11194 the two statements to avoid upsetting frontend_passes.c. */
11195 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11196 "%L", &(*code
)->loc
);
11198 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11201 s
= comp
->ts
.interface
;
11203 s
= (*code
)->expr1
->symtree
->n
.sym
;
11205 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11207 gfc_error ("The function result on the lhs of the assignment at "
11208 "%L must have the pointer attribute.",
11209 &(*code
)->expr1
->where
);
11210 (*code
)->op
= EXEC_NOP
;
11214 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11216 /* get_temp_from_expression is set up for ordinary assignments. To that
11217 end, where array bounds are not known, arrays are made allocatable.
11218 Change the temporary to a pointer here. */
11219 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11220 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11221 tmp_ptr_expr
->where
= (*code
)->loc
;
11223 this_code
= build_assignment (EXEC_ASSIGN
,
11224 tmp_ptr_expr
, (*code
)->expr2
,
11225 NULL
, NULL
, (*code
)->loc
);
11226 this_code
->next
= (*code
)->next
;
11227 (*code
)->next
= this_code
;
11228 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11229 (*code
)->expr2
= (*code
)->expr1
;
11230 (*code
)->expr1
= tmp_ptr_expr
;
11236 /* Deferred character length assignments from an operator expression
11237 require a temporary because the character length of the lhs can
11238 change in the course of the assignment. */
11241 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11243 gfc_expr
*tmp_expr
;
11244 gfc_code
*this_code
;
11246 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11247 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11248 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11251 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11254 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11257 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11258 tmp_expr
->where
= (*code
)->loc
;
11260 /* A new charlen is required to ensure that the variable string
11261 length is different to that of the original lhs. */
11262 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11263 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11264 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11265 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11267 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11269 this_code
= build_assignment (EXEC_ASSIGN
,
11271 gfc_copy_expr (tmp_expr
),
11272 NULL
, NULL
, (*code
)->loc
);
11274 (*code
)->expr1
= tmp_expr
;
11276 this_code
->next
= (*code
)->next
;
11277 (*code
)->next
= this_code
;
11283 /* Given a block of code, recursively resolve everything pointed to by this
11287 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11289 int omp_workshare_save
;
11290 int forall_save
, do_concurrent_save
;
11294 frame
.prev
= cs_base
;
11298 find_reachable_labels (code
);
11300 for (; code
; code
= code
->next
)
11302 frame
.current
= code
;
11303 forall_save
= forall_flag
;
11304 do_concurrent_save
= gfc_do_concurrent_flag
;
11306 if (code
->op
== EXEC_FORALL
)
11309 gfc_resolve_forall (code
, ns
, forall_save
);
11312 else if (code
->block
)
11314 omp_workshare_save
= -1;
11317 case EXEC_OACC_PARALLEL_LOOP
:
11318 case EXEC_OACC_PARALLEL
:
11319 case EXEC_OACC_KERNELS_LOOP
:
11320 case EXEC_OACC_KERNELS
:
11321 case EXEC_OACC_DATA
:
11322 case EXEC_OACC_HOST_DATA
:
11323 case EXEC_OACC_LOOP
:
11324 gfc_resolve_oacc_blocks (code
, ns
);
11326 case EXEC_OMP_PARALLEL_WORKSHARE
:
11327 omp_workshare_save
= omp_workshare_flag
;
11328 omp_workshare_flag
= 1;
11329 gfc_resolve_omp_parallel_blocks (code
, ns
);
11331 case EXEC_OMP_PARALLEL
:
11332 case EXEC_OMP_PARALLEL_DO
:
11333 case EXEC_OMP_PARALLEL_DO_SIMD
:
11334 case EXEC_OMP_PARALLEL_SECTIONS
:
11335 case EXEC_OMP_TARGET_PARALLEL
:
11336 case EXEC_OMP_TARGET_PARALLEL_DO
:
11337 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11338 case EXEC_OMP_TARGET_TEAMS
:
11339 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11340 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11341 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11342 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11343 case EXEC_OMP_TASK
:
11344 case EXEC_OMP_TASKLOOP
:
11345 case EXEC_OMP_TASKLOOP_SIMD
:
11346 case EXEC_OMP_TEAMS
:
11347 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11348 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11349 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11350 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11351 omp_workshare_save
= omp_workshare_flag
;
11352 omp_workshare_flag
= 0;
11353 gfc_resolve_omp_parallel_blocks (code
, ns
);
11355 case EXEC_OMP_DISTRIBUTE
:
11356 case EXEC_OMP_DISTRIBUTE_SIMD
:
11358 case EXEC_OMP_DO_SIMD
:
11359 case EXEC_OMP_SIMD
:
11360 case EXEC_OMP_TARGET_SIMD
:
11361 gfc_resolve_omp_do_blocks (code
, ns
);
11363 case EXEC_SELECT_TYPE
:
11364 /* Blocks are handled in resolve_select_type because we have
11365 to transform the SELECT TYPE into ASSOCIATE first. */
11367 case EXEC_DO_CONCURRENT
:
11368 gfc_do_concurrent_flag
= 1;
11369 gfc_resolve_blocks (code
->block
, ns
);
11370 gfc_do_concurrent_flag
= 2;
11372 case EXEC_OMP_WORKSHARE
:
11373 omp_workshare_save
= omp_workshare_flag
;
11374 omp_workshare_flag
= 1;
11377 gfc_resolve_blocks (code
->block
, ns
);
11381 if (omp_workshare_save
!= -1)
11382 omp_workshare_flag
= omp_workshare_save
;
11386 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11387 t
= gfc_resolve_expr (code
->expr1
);
11388 forall_flag
= forall_save
;
11389 gfc_do_concurrent_flag
= do_concurrent_save
;
11391 if (!gfc_resolve_expr (code
->expr2
))
11394 if (code
->op
== EXEC_ALLOCATE
11395 && !gfc_resolve_expr (code
->expr3
))
11401 case EXEC_END_BLOCK
:
11402 case EXEC_END_NESTED_BLOCK
:
11406 case EXEC_ERROR_STOP
:
11408 case EXEC_CONTINUE
:
11410 case EXEC_ASSIGN_CALL
:
11413 case EXEC_CRITICAL
:
11414 resolve_critical (code
);
11417 case EXEC_SYNC_ALL
:
11418 case EXEC_SYNC_IMAGES
:
11419 case EXEC_SYNC_MEMORY
:
11420 resolve_sync (code
);
11425 case EXEC_EVENT_POST
:
11426 case EXEC_EVENT_WAIT
:
11427 resolve_lock_unlock_event (code
);
11430 case EXEC_FAIL_IMAGE
:
11431 case EXEC_FORM_TEAM
:
11432 case EXEC_CHANGE_TEAM
:
11433 case EXEC_END_TEAM
:
11434 case EXEC_SYNC_TEAM
:
11438 /* Keep track of which entry we are up to. */
11439 current_entry_id
= code
->ext
.entry
->id
;
11443 resolve_where (code
, NULL
);
11447 if (code
->expr1
!= NULL
)
11449 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11450 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11451 "INTEGER variable", &code
->expr1
->where
);
11452 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11453 gfc_error ("Variable %qs has not been assigned a target "
11454 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11455 &code
->expr1
->where
);
11458 resolve_branch (code
->label1
, code
);
11462 if (code
->expr1
!= NULL
11463 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11464 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11465 "INTEGER return specifier", &code
->expr1
->where
);
11468 case EXEC_INIT_ASSIGN
:
11469 case EXEC_END_PROCEDURE
:
11476 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11478 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11479 && code
->expr1
->value
.function
.isym
11480 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11481 remove_caf_get_intrinsic (code
->expr1
);
11483 /* If this is a pointer function in an lvalue variable context,
11484 the new code will have to be resolved afresh. This is also the
11485 case with an error, where the code is transformed into NOP to
11486 prevent ICEs downstream. */
11487 if (resolve_ptr_fcn_assign (&code
, ns
)
11488 || code
->op
== EXEC_NOP
)
11491 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11495 if (resolve_ordinary_assign (code
, ns
))
11497 if (code
->op
== EXEC_COMPCALL
)
11503 /* Check for dependencies in deferred character length array
11504 assignments and generate a temporary, if necessary. */
11505 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11508 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11509 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11510 && code
->expr1
->ts
.u
.derived
11511 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11512 generate_component_assignments (&code
, ns
);
11516 case EXEC_LABEL_ASSIGN
:
11517 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11518 gfc_error ("Label %d referenced at %L is never defined",
11519 code
->label1
->value
, &code
->label1
->where
);
11521 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11522 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11523 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11524 != gfc_default_integer_kind
11525 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11526 gfc_error ("ASSIGN statement at %L requires a scalar "
11527 "default INTEGER variable", &code
->expr1
->where
);
11530 case EXEC_POINTER_ASSIGN
:
11537 /* This is both a variable definition and pointer assignment
11538 context, so check both of them. For rank remapping, a final
11539 array ref may be present on the LHS and fool gfc_expr_attr
11540 used in gfc_check_vardef_context. Remove it. */
11541 e
= remove_last_array_ref (code
->expr1
);
11542 t
= gfc_check_vardef_context (e
, true, false, false,
11543 _("pointer assignment"));
11545 t
= gfc_check_vardef_context (e
, false, false, false,
11546 _("pointer assignment"));
11549 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11554 /* Assigning a class object always is a regular assign. */
11555 if (code
->expr2
->ts
.type
== BT_CLASS
11556 && code
->expr1
->ts
.type
== BT_CLASS
11557 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11558 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11559 && code
->expr2
->expr_type
== EXPR_VARIABLE
11560 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11562 code
->op
= EXEC_ASSIGN
;
11566 case EXEC_ARITHMETIC_IF
:
11568 gfc_expr
*e
= code
->expr1
;
11570 gfc_resolve_expr (e
);
11571 if (e
->expr_type
== EXPR_NULL
)
11572 gfc_error ("Invalid NULL at %L", &e
->where
);
11574 if (t
&& (e
->rank
> 0
11575 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11576 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11577 "REAL or INTEGER expression", &e
->where
);
11579 resolve_branch (code
->label1
, code
);
11580 resolve_branch (code
->label2
, code
);
11581 resolve_branch (code
->label3
, code
);
11586 if (t
&& code
->expr1
!= NULL
11587 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11588 || code
->expr1
->rank
!= 0))
11589 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11590 &code
->expr1
->where
);
11595 resolve_call (code
);
11598 case EXEC_COMPCALL
:
11600 resolve_typebound_subroutine (code
);
11603 case EXEC_CALL_PPC
:
11604 resolve_ppc_call (code
);
11608 /* Select is complicated. Also, a SELECT construct could be
11609 a transformed computed GOTO. */
11610 resolve_select (code
, false);
11613 case EXEC_SELECT_TYPE
:
11614 resolve_select_type (code
, ns
);
11618 resolve_block_construct (code
);
11622 if (code
->ext
.iterator
!= NULL
)
11624 gfc_iterator
*iter
= code
->ext
.iterator
;
11625 if (gfc_resolve_iterator (iter
, true, false))
11626 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11631 case EXEC_DO_WHILE
:
11632 if (code
->expr1
== NULL
)
11633 gfc_internal_error ("gfc_resolve_code(): No expression on "
11636 && (code
->expr1
->rank
!= 0
11637 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11638 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11639 "a scalar LOGICAL expression", &code
->expr1
->where
);
11642 case EXEC_ALLOCATE
:
11644 resolve_allocate_deallocate (code
, "ALLOCATE");
11648 case EXEC_DEALLOCATE
:
11650 resolve_allocate_deallocate (code
, "DEALLOCATE");
11655 if (!gfc_resolve_open (code
->ext
.open
))
11658 resolve_branch (code
->ext
.open
->err
, code
);
11662 if (!gfc_resolve_close (code
->ext
.close
))
11665 resolve_branch (code
->ext
.close
->err
, code
);
11668 case EXEC_BACKSPACE
:
11672 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11675 resolve_branch (code
->ext
.filepos
->err
, code
);
11679 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11682 resolve_branch (code
->ext
.inquire
->err
, code
);
11685 case EXEC_IOLENGTH
:
11686 gcc_assert (code
->ext
.inquire
!= NULL
);
11687 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11690 resolve_branch (code
->ext
.inquire
->err
, code
);
11694 if (!gfc_resolve_wait (code
->ext
.wait
))
11697 resolve_branch (code
->ext
.wait
->err
, code
);
11698 resolve_branch (code
->ext
.wait
->end
, code
);
11699 resolve_branch (code
->ext
.wait
->eor
, code
);
11704 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11707 resolve_branch (code
->ext
.dt
->err
, code
);
11708 resolve_branch (code
->ext
.dt
->end
, code
);
11709 resolve_branch (code
->ext
.dt
->eor
, code
);
11712 case EXEC_TRANSFER
:
11713 resolve_transfer (code
);
11716 case EXEC_DO_CONCURRENT
:
11718 resolve_forall_iterators (code
->ext
.forall_iterator
);
11720 if (code
->expr1
!= NULL
11721 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11722 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11723 "expression", &code
->expr1
->where
);
11726 case EXEC_OACC_PARALLEL_LOOP
:
11727 case EXEC_OACC_PARALLEL
:
11728 case EXEC_OACC_KERNELS_LOOP
:
11729 case EXEC_OACC_KERNELS
:
11730 case EXEC_OACC_DATA
:
11731 case EXEC_OACC_HOST_DATA
:
11732 case EXEC_OACC_LOOP
:
11733 case EXEC_OACC_UPDATE
:
11734 case EXEC_OACC_WAIT
:
11735 case EXEC_OACC_CACHE
:
11736 case EXEC_OACC_ENTER_DATA
:
11737 case EXEC_OACC_EXIT_DATA
:
11738 case EXEC_OACC_ATOMIC
:
11739 case EXEC_OACC_DECLARE
:
11740 gfc_resolve_oacc_directive (code
, ns
);
11743 case EXEC_OMP_ATOMIC
:
11744 case EXEC_OMP_BARRIER
:
11745 case EXEC_OMP_CANCEL
:
11746 case EXEC_OMP_CANCELLATION_POINT
:
11747 case EXEC_OMP_CRITICAL
:
11748 case EXEC_OMP_FLUSH
:
11749 case EXEC_OMP_DISTRIBUTE
:
11750 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11751 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11752 case EXEC_OMP_DISTRIBUTE_SIMD
:
11754 case EXEC_OMP_DO_SIMD
:
11755 case EXEC_OMP_MASTER
:
11756 case EXEC_OMP_ORDERED
:
11757 case EXEC_OMP_SECTIONS
:
11758 case EXEC_OMP_SIMD
:
11759 case EXEC_OMP_SINGLE
:
11760 case EXEC_OMP_TARGET
:
11761 case EXEC_OMP_TARGET_DATA
:
11762 case EXEC_OMP_TARGET_ENTER_DATA
:
11763 case EXEC_OMP_TARGET_EXIT_DATA
:
11764 case EXEC_OMP_TARGET_PARALLEL
:
11765 case EXEC_OMP_TARGET_PARALLEL_DO
:
11766 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11767 case EXEC_OMP_TARGET_SIMD
:
11768 case EXEC_OMP_TARGET_TEAMS
:
11769 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11770 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11771 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11772 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11773 case EXEC_OMP_TARGET_UPDATE
:
11774 case EXEC_OMP_TASK
:
11775 case EXEC_OMP_TASKGROUP
:
11776 case EXEC_OMP_TASKLOOP
:
11777 case EXEC_OMP_TASKLOOP_SIMD
:
11778 case EXEC_OMP_TASKWAIT
:
11779 case EXEC_OMP_TASKYIELD
:
11780 case EXEC_OMP_TEAMS
:
11781 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11782 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11783 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11784 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11785 case EXEC_OMP_WORKSHARE
:
11786 gfc_resolve_omp_directive (code
, ns
);
11789 case EXEC_OMP_PARALLEL
:
11790 case EXEC_OMP_PARALLEL_DO
:
11791 case EXEC_OMP_PARALLEL_DO_SIMD
:
11792 case EXEC_OMP_PARALLEL_SECTIONS
:
11793 case EXEC_OMP_PARALLEL_WORKSHARE
:
11794 omp_workshare_save
= omp_workshare_flag
;
11795 omp_workshare_flag
= 0;
11796 gfc_resolve_omp_directive (code
, ns
);
11797 omp_workshare_flag
= omp_workshare_save
;
11801 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11805 cs_base
= frame
.prev
;
11809 /* Resolve initial values and make sure they are compatible with
11813 resolve_values (gfc_symbol
*sym
)
11817 if (sym
->value
== NULL
)
11820 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11821 t
= resolve_structure_cons (sym
->value
, 1);
11823 t
= gfc_resolve_expr (sym
->value
);
11828 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11832 /* Verify any BIND(C) derived types in the namespace so we can report errors
11833 for them once, rather than for each variable declared of that type. */
11836 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11838 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11839 && derived_sym
->attr
.is_bind_c
== 1)
11840 verify_bind_c_derived_type (derived_sym
);
11846 /* Check the interfaces of DTIO procedures associated with derived
11847 type 'sym'. These procedures can either have typebound bindings or
11848 can appear in DTIO generic interfaces. */
11851 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11853 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11856 gfc_check_dtio_interfaces (sym
);
11861 /* Verify that any binding labels used in a given namespace do not collide
11862 with the names or binding labels of any global symbols. Multiple INTERFACE
11863 for the same procedure are permitted. */
11866 gfc_verify_binding_labels (gfc_symbol
*sym
)
11869 const char *module
;
11871 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11872 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11875 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11878 module
= sym
->module
;
11879 else if (sym
->ns
&& sym
->ns
->proc_name
11880 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11881 module
= sym
->ns
->proc_name
->name
;
11882 else if (sym
->ns
&& sym
->ns
->parent
11883 && sym
->ns
&& sym
->ns
->parent
->proc_name
11884 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11885 module
= sym
->ns
->parent
->proc_name
->name
;
11891 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11894 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
11895 gsym
->where
= sym
->declared_at
;
11896 gsym
->sym_name
= sym
->name
;
11897 gsym
->binding_label
= sym
->binding_label
;
11898 gsym
->ns
= sym
->ns
;
11899 gsym
->mod_name
= module
;
11900 if (sym
->attr
.function
)
11901 gsym
->type
= GSYM_FUNCTION
;
11902 else if (sym
->attr
.subroutine
)
11903 gsym
->type
= GSYM_SUBROUTINE
;
11904 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11905 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11909 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11911 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11912 "identifier as entity at %L", sym
->name
,
11913 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11914 /* Clear the binding label to prevent checking multiple times. */
11915 sym
->binding_label
= NULL
;
11919 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11920 && (strcmp (module
, gsym
->mod_name
) != 0
11921 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11923 /* This can only happen if the variable is defined in a module - if it
11924 isn't the same module, reject it. */
11925 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11926 "uses the same global identifier as entity at %L from module %qs",
11927 sym
->name
, module
, sym
->binding_label
,
11928 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11929 sym
->binding_label
= NULL
;
11933 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11934 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11935 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11936 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
11937 && (module
!= gsym
->mod_name
11938 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11939 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11941 /* Print an error if the procedure is defined multiple times; we have to
11942 exclude references to the same procedure via module association or
11943 multiple checks for the same procedure. */
11944 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11945 "global identifier as entity at %L", sym
->name
,
11946 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11947 sym
->binding_label
= NULL
;
11952 /* Resolve an index expression. */
11955 resolve_index_expr (gfc_expr
*e
)
11957 if (!gfc_resolve_expr (e
))
11960 if (!gfc_simplify_expr (e
, 0))
11963 if (!gfc_specification_expr (e
))
11970 /* Resolve a charlen structure. */
11973 resolve_charlen (gfc_charlen
*cl
)
11976 bool saved_specification_expr
;
11982 saved_specification_expr
= specification_expr
;
11983 specification_expr
= true;
11985 if (cl
->length_from_typespec
)
11987 if (!gfc_resolve_expr (cl
->length
))
11989 specification_expr
= saved_specification_expr
;
11993 if (!gfc_simplify_expr (cl
->length
, 0))
11995 specification_expr
= saved_specification_expr
;
11999 /* cl->length has been resolved. It should have an integer type. */
12000 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12002 gfc_error ("Scalar INTEGER expression expected at %L",
12003 &cl
->length
->where
);
12009 if (!resolve_index_expr (cl
->length
))
12011 specification_expr
= saved_specification_expr
;
12016 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12017 a negative value, the length of character entities declared is zero. */
12018 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12019 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12020 gfc_replace_expr (cl
->length
,
12021 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12023 /* Check that the character length is not too large. */
12024 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12025 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12026 && cl
->length
->ts
.type
== BT_INTEGER
12027 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12029 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12030 specification_expr
= saved_specification_expr
;
12034 specification_expr
= saved_specification_expr
;
12039 /* Test for non-constant shape arrays. */
12042 is_non_constant_shape_array (gfc_symbol
*sym
)
12048 not_constant
= false;
12049 if (sym
->as
!= NULL
)
12051 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12052 has not been simplified; parameter array references. Do the
12053 simplification now. */
12054 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12056 e
= sym
->as
->lower
[i
];
12057 if (e
&& (!resolve_index_expr(e
)
12058 || !gfc_is_constant_expr (e
)))
12059 not_constant
= true;
12060 e
= sym
->as
->upper
[i
];
12061 if (e
&& (!resolve_index_expr(e
)
12062 || !gfc_is_constant_expr (e
)))
12063 not_constant
= true;
12066 return not_constant
;
12069 /* Given a symbol and an initialization expression, add code to initialize
12070 the symbol to the function entry. */
12072 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12076 gfc_namespace
*ns
= sym
->ns
;
12078 /* Search for the function namespace if this is a contained
12079 function without an explicit result. */
12080 if (sym
->attr
.function
&& sym
== sym
->result
12081 && sym
->name
!= sym
->ns
->proc_name
->name
)
12083 ns
= ns
->contained
;
12084 for (;ns
; ns
= ns
->sibling
)
12085 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12091 gfc_free_expr (init
);
12095 /* Build an l-value expression for the result. */
12096 lval
= gfc_lval_expr_from_sym (sym
);
12098 /* Add the code at scope entry. */
12099 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12100 init_st
->next
= ns
->code
;
12101 ns
->code
= init_st
;
12103 /* Assign the default initializer to the l-value. */
12104 init_st
->loc
= sym
->declared_at
;
12105 init_st
->expr1
= lval
;
12106 init_st
->expr2
= init
;
12110 /* Whether or not we can generate a default initializer for a symbol. */
12113 can_generate_init (gfc_symbol
*sym
)
12115 symbol_attribute
*a
;
12120 /* These symbols should never have a default initialization. */
12125 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12126 && (CLASS_DATA (sym
)->attr
.class_pointer
12127 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12128 || a
->in_equivalence
12135 || (!a
->referenced
&& !a
->result
)
12136 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12137 || (a
->function
&& sym
!= sym
->result
)
12142 /* Assign the default initializer to a derived type variable or result. */
12145 apply_default_init (gfc_symbol
*sym
)
12147 gfc_expr
*init
= NULL
;
12149 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12152 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12153 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12155 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12158 build_init_assign (sym
, init
);
12159 sym
->attr
.referenced
= 1;
12163 /* Build an initializer for a local. Returns null if the symbol should not have
12164 a default initialization. */
12167 build_default_init_expr (gfc_symbol
*sym
)
12169 /* These symbols should never have a default initialization. */
12170 if (sym
->attr
.allocatable
12171 || sym
->attr
.external
12173 || sym
->attr
.pointer
12174 || sym
->attr
.in_equivalence
12175 || sym
->attr
.in_common
12178 || sym
->attr
.cray_pointee
12179 || sym
->attr
.cray_pointer
12183 /* Get the appropriate init expression. */
12184 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12187 /* Add an initialization expression to a local variable. */
12189 apply_default_init_local (gfc_symbol
*sym
)
12191 gfc_expr
*init
= NULL
;
12193 /* The symbol should be a variable or a function return value. */
12194 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12195 || (sym
->attr
.function
&& sym
->result
!= sym
))
12198 /* Try to build the initializer expression. If we can't initialize
12199 this symbol, then init will be NULL. */
12200 init
= build_default_init_expr (sym
);
12204 /* For saved variables, we don't want to add an initializer at function
12205 entry, so we just add a static initializer. Note that automatic variables
12206 are stack allocated even with -fno-automatic; we have also to exclude
12207 result variable, which are also nonstatic. */
12208 if (!sym
->attr
.automatic
12209 && (sym
->attr
.save
|| sym
->ns
->save_all
12210 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12211 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12212 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12214 /* Don't clobber an existing initializer! */
12215 gcc_assert (sym
->value
== NULL
);
12220 build_init_assign (sym
, init
);
12224 /* Resolution of common features of flavors variable and procedure. */
12227 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12229 gfc_array_spec
*as
;
12231 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12232 as
= CLASS_DATA (sym
)->as
;
12236 /* Constraints on deferred shape variable. */
12237 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12239 bool pointer
, allocatable
, dimension
;
12241 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12243 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12244 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12245 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12249 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12250 allocatable
= sym
->attr
.allocatable
;
12251 dimension
= sym
->attr
.dimension
;
12256 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12258 gfc_error ("Allocatable array %qs at %L must have a deferred "
12259 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12262 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12263 "%qs at %L may not be ALLOCATABLE",
12264 sym
->name
, &sym
->declared_at
))
12268 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12270 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12271 "assumed rank", sym
->name
, &sym
->declared_at
);
12277 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12278 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12280 gfc_error ("Array %qs at %L cannot have a deferred shape",
12281 sym
->name
, &sym
->declared_at
);
12286 /* Constraints on polymorphic variables. */
12287 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12290 if (sym
->attr
.class_ok
12291 && !sym
->attr
.select_type_temporary
12292 && !UNLIMITED_POLY (sym
)
12293 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12295 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12296 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12297 &sym
->declared_at
);
12302 /* Assume that use associated symbols were checked in the module ns.
12303 Class-variables that are associate-names are also something special
12304 and excepted from the test. */
12305 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12307 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12308 "or pointer", sym
->name
, &sym
->declared_at
);
12317 /* Additional checks for symbols with flavor variable and derived
12318 type. To be called from resolve_fl_variable. */
12321 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12323 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12325 /* Check to see if a derived type is blocked from being host
12326 associated by the presence of another class I symbol in the same
12327 namespace. 14.6.1.3 of the standard and the discussion on
12328 comp.lang.fortran. */
12329 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12330 && !sym
->ts
.u
.derived
->attr
.use_assoc
12331 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12334 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12335 if (s
&& s
->attr
.generic
)
12336 s
= gfc_find_dt_in_generic (s
);
12337 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12339 gfc_error ("The type %qs cannot be host associated at %L "
12340 "because it is blocked by an incompatible object "
12341 "of the same name declared at %L",
12342 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12348 /* 4th constraint in section 11.3: "If an object of a type for which
12349 component-initialization is specified (R429) appears in the
12350 specification-part of a module and does not have the ALLOCATABLE
12351 or POINTER attribute, the object shall have the SAVE attribute."
12353 The check for initializers is performed with
12354 gfc_has_default_initializer because gfc_default_initializer generates
12355 a hidden default for allocatable components. */
12356 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12357 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12358 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12359 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12360 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12361 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12362 "%qs at %L, needed due to the default "
12363 "initialization", sym
->name
, &sym
->declared_at
))
12366 /* Assign default initializer. */
12367 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12368 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12369 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12375 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12376 except in the declaration of an entity or component that has the POINTER
12377 or ALLOCATABLE attribute. */
12380 deferred_requirements (gfc_symbol
*sym
)
12382 if (sym
->ts
.deferred
12383 && !(sym
->attr
.pointer
12384 || sym
->attr
.allocatable
12385 || sym
->attr
.associate_var
12386 || sym
->attr
.omp_udr_artificial_var
))
12388 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12389 "requires either the POINTER or ALLOCATABLE attribute",
12390 sym
->name
, &sym
->declared_at
);
12397 /* Resolve symbols with flavor variable. */
12400 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12402 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12405 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12408 /* Set this flag to check that variables are parameters of all entries.
12409 This check is effected by the call to gfc_resolve_expr through
12410 is_non_constant_shape_array. */
12411 bool saved_specification_expr
= specification_expr
;
12412 specification_expr
= true;
12414 if (sym
->ns
->proc_name
12415 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12416 || sym
->ns
->proc_name
->attr
.is_main_program
)
12417 && !sym
->attr
.use_assoc
12418 && !sym
->attr
.allocatable
12419 && !sym
->attr
.pointer
12420 && is_non_constant_shape_array (sym
))
12422 /* F08:C541. The shape of an array defined in a main program or module
12423 * needs to be constant. */
12424 gfc_error ("The module or main program array %qs at %L must "
12425 "have constant shape", sym
->name
, &sym
->declared_at
);
12426 specification_expr
= saved_specification_expr
;
12430 /* Constraints on deferred type parameter. */
12431 if (!deferred_requirements (sym
))
12434 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12436 /* Make sure that character string variables with assumed length are
12437 dummy arguments. */
12438 gfc_expr
*e
= NULL
;
12441 e
= sym
->ts
.u
.cl
->length
;
12445 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12446 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12447 && !sym
->attr
.omp_udr_artificial_var
)
12449 gfc_error ("Entity with assumed character length at %L must be a "
12450 "dummy argument or a PARAMETER", &sym
->declared_at
);
12451 specification_expr
= saved_specification_expr
;
12455 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12457 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12458 specification_expr
= saved_specification_expr
;
12462 if (!gfc_is_constant_expr (e
)
12463 && !(e
->expr_type
== EXPR_VARIABLE
12464 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12466 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12467 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12468 || sym
->ns
->proc_name
->attr
.is_main_program
))
12470 gfc_error ("%qs at %L must have constant character length "
12471 "in this context", sym
->name
, &sym
->declared_at
);
12472 specification_expr
= saved_specification_expr
;
12475 if (sym
->attr
.in_common
)
12477 gfc_error ("COMMON variable %qs at %L must have constant "
12478 "character length", sym
->name
, &sym
->declared_at
);
12479 specification_expr
= saved_specification_expr
;
12485 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12486 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12488 /* Determine if the symbol may not have an initializer. */
12489 int no_init_flag
= 0, automatic_flag
= 0;
12490 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12491 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12493 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12494 && is_non_constant_shape_array (sym
))
12496 no_init_flag
= automatic_flag
= 1;
12498 /* Also, they must not have the SAVE attribute.
12499 SAVE_IMPLICIT is checked below. */
12500 if (sym
->as
&& sym
->attr
.codimension
)
12502 int corank
= sym
->as
->corank
;
12503 sym
->as
->corank
= 0;
12504 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12505 sym
->as
->corank
= corank
;
12507 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12509 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12510 specification_expr
= saved_specification_expr
;
12515 /* Ensure that any initializer is simplified. */
12517 gfc_simplify_expr (sym
->value
, 1);
12519 /* Reject illegal initializers. */
12520 if (!sym
->mark
&& sym
->value
)
12522 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12523 && CLASS_DATA (sym
)->attr
.allocatable
))
12524 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12525 sym
->name
, &sym
->declared_at
);
12526 else if (sym
->attr
.external
)
12527 gfc_error ("External %qs at %L cannot have an initializer",
12528 sym
->name
, &sym
->declared_at
);
12529 else if (sym
->attr
.dummy
12530 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12531 gfc_error ("Dummy %qs at %L cannot have an initializer",
12532 sym
->name
, &sym
->declared_at
);
12533 else if (sym
->attr
.intrinsic
)
12534 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12535 sym
->name
, &sym
->declared_at
);
12536 else if (sym
->attr
.result
)
12537 gfc_error ("Function result %qs at %L cannot have an initializer",
12538 sym
->name
, &sym
->declared_at
);
12539 else if (automatic_flag
)
12540 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12541 sym
->name
, &sym
->declared_at
);
12543 goto no_init_error
;
12544 specification_expr
= saved_specification_expr
;
12549 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12551 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12552 specification_expr
= saved_specification_expr
;
12556 specification_expr
= saved_specification_expr
;
12561 /* Compare the dummy characteristics of a module procedure interface
12562 declaration with the corresponding declaration in a submodule. */
12563 static gfc_formal_arglist
*new_formal
;
12564 static char errmsg
[200];
12567 compare_fsyms (gfc_symbol
*sym
)
12571 if (sym
== NULL
|| new_formal
== NULL
)
12574 fsym
= new_formal
->sym
;
12579 if (strcmp (sym
->name
, fsym
->name
) == 0)
12581 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12582 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12587 /* Resolve a procedure. */
12590 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12592 gfc_formal_arglist
*arg
;
12594 if (sym
->attr
.function
12595 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12598 if (sym
->ts
.type
== BT_CHARACTER
)
12600 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12602 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12603 && !resolve_charlen (cl
))
12606 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12607 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12609 gfc_error ("Character-valued statement function %qs at %L must "
12610 "have constant length", sym
->name
, &sym
->declared_at
);
12615 /* Ensure that derived type for are not of a private type. Internal
12616 module procedures are excluded by 2.2.3.3 - i.e., they are not
12617 externally accessible and can access all the objects accessible in
12619 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12620 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12621 && gfc_check_symbol_access (sym
))
12623 gfc_interface
*iface
;
12625 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12628 && arg
->sym
->ts
.type
== BT_DERIVED
12629 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12630 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12631 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12632 "and cannot be a dummy argument"
12633 " of %qs, which is PUBLIC at %L",
12634 arg
->sym
->name
, sym
->name
,
12635 &sym
->declared_at
))
12637 /* Stop this message from recurring. */
12638 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12643 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12644 PRIVATE to the containing module. */
12645 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12647 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12650 && arg
->sym
->ts
.type
== BT_DERIVED
12651 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12652 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12653 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12654 "PUBLIC interface %qs at %L "
12655 "takes dummy arguments of %qs which "
12656 "is PRIVATE", iface
->sym
->name
,
12657 sym
->name
, &iface
->sym
->declared_at
,
12658 gfc_typename(&arg
->sym
->ts
)))
12660 /* Stop this message from recurring. */
12661 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12668 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12669 && !sym
->attr
.proc_pointer
)
12671 gfc_error ("Function %qs at %L cannot have an initializer",
12672 sym
->name
, &sym
->declared_at
);
12674 /* Make sure no second error is issued for this. */
12675 sym
->value
->error
= 1;
12679 /* An external symbol may not have an initializer because it is taken to be
12680 a procedure. Exception: Procedure Pointers. */
12681 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12683 gfc_error ("External object %qs at %L may not have an initializer",
12684 sym
->name
, &sym
->declared_at
);
12688 /* An elemental function is required to return a scalar 12.7.1 */
12689 if (sym
->attr
.elemental
&& sym
->attr
.function
12690 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12692 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12693 "result", sym
->name
, &sym
->declared_at
);
12694 /* Reset so that the error only occurs once. */
12695 sym
->attr
.elemental
= 0;
12699 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12700 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12702 gfc_error ("Statement function %qs at %L may not have pointer or "
12703 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12707 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12708 char-len-param shall not be array-valued, pointer-valued, recursive
12709 or pure. ....snip... A character value of * may only be used in the
12710 following ways: (i) Dummy arg of procedure - dummy associates with
12711 actual length; (ii) To declare a named constant; or (iii) External
12712 function - but length must be declared in calling scoping unit. */
12713 if (sym
->attr
.function
12714 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12715 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12717 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12718 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12720 if (sym
->as
&& sym
->as
->rank
)
12721 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12722 "array-valued", sym
->name
, &sym
->declared_at
);
12724 if (sym
->attr
.pointer
)
12725 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12726 "pointer-valued", sym
->name
, &sym
->declared_at
);
12728 if (sym
->attr
.pure
)
12729 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12730 "pure", sym
->name
, &sym
->declared_at
);
12732 if (sym
->attr
.recursive
)
12733 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12734 "recursive", sym
->name
, &sym
->declared_at
);
12739 /* Appendix B.2 of the standard. Contained functions give an
12740 error anyway. Deferred character length is an F2003 feature.
12741 Don't warn on intrinsic conversion functions, which start
12742 with two underscores. */
12743 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12744 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12745 gfc_notify_std (GFC_STD_F95_OBS
,
12746 "CHARACTER(*) function %qs at %L",
12747 sym
->name
, &sym
->declared_at
);
12750 /* F2008, C1218. */
12751 if (sym
->attr
.elemental
)
12753 if (sym
->attr
.proc_pointer
)
12755 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12756 sym
->name
, &sym
->declared_at
);
12759 if (sym
->attr
.dummy
)
12761 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12762 sym
->name
, &sym
->declared_at
);
12767 /* F2018, C15100: "The result of an elemental function shall be scalar,
12768 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12769 pointer is tested and caught elsewhere. */
12770 if (sym
->attr
.elemental
&& sym
->result
12771 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12773 gfc_error ("Function result variable %qs at %L of elemental "
12774 "function %qs shall not have an ALLOCATABLE or POINTER "
12775 "attribute", sym
->result
->name
,
12776 &sym
->result
->declared_at
, sym
->name
);
12780 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12782 gfc_formal_arglist
*curr_arg
;
12783 int has_non_interop_arg
= 0;
12785 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12786 sym
->common_block
))
12788 /* Clear these to prevent looking at them again if there was an
12790 sym
->attr
.is_bind_c
= 0;
12791 sym
->attr
.is_c_interop
= 0;
12792 sym
->ts
.is_c_interop
= 0;
12796 /* So far, no errors have been found. */
12797 sym
->attr
.is_c_interop
= 1;
12798 sym
->ts
.is_c_interop
= 1;
12801 curr_arg
= gfc_sym_get_dummy_args (sym
);
12802 while (curr_arg
!= NULL
)
12804 /* Skip implicitly typed dummy args here. */
12805 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12806 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12807 /* If something is found to fail, record the fact so we
12808 can mark the symbol for the procedure as not being
12809 BIND(C) to try and prevent multiple errors being
12811 has_non_interop_arg
= 1;
12813 curr_arg
= curr_arg
->next
;
12816 /* See if any of the arguments were not interoperable and if so, clear
12817 the procedure symbol to prevent duplicate error messages. */
12818 if (has_non_interop_arg
!= 0)
12820 sym
->attr
.is_c_interop
= 0;
12821 sym
->ts
.is_c_interop
= 0;
12822 sym
->attr
.is_bind_c
= 0;
12826 if (!sym
->attr
.proc_pointer
)
12828 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12830 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12831 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12834 if (sym
->attr
.intent
)
12836 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12837 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12840 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12842 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12843 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12846 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12847 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12848 || sym
->attr
.contained
))
12850 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12851 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12854 if (strcmp ("ppr@", sym
->name
) == 0)
12856 gfc_error ("Procedure pointer result %qs at %L "
12857 "is missing the pointer attribute",
12858 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12863 /* Assume that a procedure whose body is not known has references
12864 to external arrays. */
12865 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12866 sym
->attr
.array_outer_dependency
= 1;
12868 /* Compare the characteristics of a module procedure with the
12869 interface declaration. Ideally this would be done with
12870 gfc_compare_interfaces but, at present, the formal interface
12871 cannot be copied to the ts.interface. */
12872 if (sym
->attr
.module_procedure
12873 && sym
->attr
.if_source
== IFSRC_DECL
)
12876 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12878 char *submodule_name
;
12879 strcpy (name
, sym
->ns
->proc_name
->name
);
12880 module_name
= strtok (name
, ".");
12881 submodule_name
= strtok (NULL
, ".");
12883 iface
= sym
->tlink
;
12886 /* Make sure that the result uses the correct charlen for deferred
12888 if (iface
&& sym
->result
12889 && iface
->ts
.type
== BT_CHARACTER
12890 && iface
->ts
.deferred
)
12891 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12896 /* Check the procedure characteristics. */
12897 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12899 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12900 "PROCEDURE at %L and its interface in %s",
12901 &sym
->declared_at
, module_name
);
12905 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12907 gfc_error ("Mismatch in PURE attribute between MODULE "
12908 "PROCEDURE at %L and its interface in %s",
12909 &sym
->declared_at
, module_name
);
12913 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12915 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12916 "PROCEDURE at %L and its interface in %s",
12917 &sym
->declared_at
, module_name
);
12921 /* Check the result characteristics. */
12922 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12924 gfc_error ("%s between the MODULE PROCEDURE declaration "
12925 "in MODULE %qs and the declaration at %L in "
12927 errmsg
, module_name
, &sym
->declared_at
,
12928 submodule_name
? submodule_name
: module_name
);
12933 /* Check the characteristics of the formal arguments. */
12934 if (sym
->formal
&& sym
->formal_ns
)
12936 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12939 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12947 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12948 been defined and we now know their defined arguments, check that they fulfill
12949 the requirements of the standard for procedures used as finalizers. */
12952 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12954 gfc_finalizer
* list
;
12955 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12956 bool result
= true;
12957 bool seen_scalar
= false;
12960 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12963 gfc_resolve_finalizers (parent
, finalizable
);
12965 /* Ensure that derived-type components have a their finalizers resolved. */
12966 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12967 for (c
= derived
->components
; c
; c
= c
->next
)
12968 if (c
->ts
.type
== BT_DERIVED
12969 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12971 bool has_final2
= false;
12972 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12973 return false; /* Error. */
12974 has_final
= has_final
|| has_final2
;
12976 /* Return early if not finalizable. */
12980 *finalizable
= false;
12984 /* Walk over the list of finalizer-procedures, check them, and if any one
12985 does not fit in with the standard's definition, print an error and remove
12986 it from the list. */
12987 prev_link
= &derived
->f2k_derived
->finalizers
;
12988 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12990 gfc_formal_arglist
*dummy_args
;
12995 /* Skip this finalizer if we already resolved it. */
12996 if (list
->proc_tree
)
12998 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12999 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13000 seen_scalar
= true;
13001 prev_link
= &(list
->next
);
13005 /* Check this exists and is a SUBROUTINE. */
13006 if (!list
->proc_sym
->attr
.subroutine
)
13008 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13009 list
->proc_sym
->name
, &list
->where
);
13013 /* We should have exactly one argument. */
13014 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13015 if (!dummy_args
|| dummy_args
->next
)
13017 gfc_error ("FINAL procedure at %L must have exactly one argument",
13021 arg
= dummy_args
->sym
;
13023 /* This argument must be of our type. */
13024 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13026 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13027 &arg
->declared_at
, derived
->name
);
13031 /* It must neither be a pointer nor allocatable nor optional. */
13032 if (arg
->attr
.pointer
)
13034 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13035 &arg
->declared_at
);
13038 if (arg
->attr
.allocatable
)
13040 gfc_error ("Argument of FINAL procedure at %L must not be"
13041 " ALLOCATABLE", &arg
->declared_at
);
13044 if (arg
->attr
.optional
)
13046 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13047 &arg
->declared_at
);
13051 /* It must not be INTENT(OUT). */
13052 if (arg
->attr
.intent
== INTENT_OUT
)
13054 gfc_error ("Argument of FINAL procedure at %L must not be"
13055 " INTENT(OUT)", &arg
->declared_at
);
13059 /* Warn if the procedure is non-scalar and not assumed shape. */
13060 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13061 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13062 gfc_warning (OPT_Wsurprising
,
13063 "Non-scalar FINAL procedure at %L should have assumed"
13064 " shape argument", &arg
->declared_at
);
13066 /* Check that it does not match in kind and rank with a FINAL procedure
13067 defined earlier. To really loop over the *earlier* declarations,
13068 we need to walk the tail of the list as new ones were pushed at the
13070 /* TODO: Handle kind parameters once they are implemented. */
13071 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13072 for (i
= list
->next
; i
; i
= i
->next
)
13074 gfc_formal_arglist
*dummy_args
;
13076 /* Argument list might be empty; that is an error signalled earlier,
13077 but we nevertheless continued resolving. */
13078 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13081 gfc_symbol
* i_arg
= dummy_args
->sym
;
13082 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13083 if (i_rank
== my_rank
)
13085 gfc_error ("FINAL procedure %qs declared at %L has the same"
13086 " rank (%d) as %qs",
13087 list
->proc_sym
->name
, &list
->where
, my_rank
,
13088 i
->proc_sym
->name
);
13094 /* Is this the/a scalar finalizer procedure? */
13096 seen_scalar
= true;
13098 /* Find the symtree for this procedure. */
13099 gcc_assert (!list
->proc_tree
);
13100 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13102 prev_link
= &list
->next
;
13105 /* Remove wrong nodes immediately from the list so we don't risk any
13106 troubles in the future when they might fail later expectations. */
13109 *prev_link
= list
->next
;
13110 gfc_free_finalizer (i
);
13114 if (result
== false)
13117 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13118 were nodes in the list, must have been for arrays. It is surely a good
13119 idea to have a scalar version there if there's something to finalize. */
13120 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13121 gfc_warning (OPT_Wsurprising
,
13122 "Only array FINAL procedures declared for derived type %qs"
13123 " defined at %L, suggest also scalar one",
13124 derived
->name
, &derived
->declared_at
);
13126 vtab
= gfc_find_derived_vtab (derived
);
13127 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13128 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13131 *finalizable
= true;
13137 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13140 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13141 const char* generic_name
, locus where
)
13143 gfc_symbol
*sym1
, *sym2
;
13144 const char *pass1
, *pass2
;
13145 gfc_formal_arglist
*dummy_args
;
13147 gcc_assert (t1
->specific
&& t2
->specific
);
13148 gcc_assert (!t1
->specific
->is_generic
);
13149 gcc_assert (!t2
->specific
->is_generic
);
13150 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13152 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13153 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13158 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13159 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13160 || sym1
->attr
.function
!= sym2
->attr
.function
)
13162 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13163 " GENERIC %qs at %L",
13164 sym1
->name
, sym2
->name
, generic_name
, &where
);
13168 /* Determine PASS arguments. */
13169 if (t1
->specific
->nopass
)
13171 else if (t1
->specific
->pass_arg
)
13172 pass1
= t1
->specific
->pass_arg
;
13175 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13177 pass1
= dummy_args
->sym
->name
;
13181 if (t2
->specific
->nopass
)
13183 else if (t2
->specific
->pass_arg
)
13184 pass2
= t2
->specific
->pass_arg
;
13187 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13189 pass2
= dummy_args
->sym
->name
;
13194 /* Compare the interfaces. */
13195 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13196 NULL
, 0, pass1
, pass2
))
13198 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13199 sym1
->name
, sym2
->name
, generic_name
, &where
);
13207 /* Worker function for resolving a generic procedure binding; this is used to
13208 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13210 The difference between those cases is finding possible inherited bindings
13211 that are overridden, as one has to look for them in tb_sym_root,
13212 tb_uop_root or tb_op, respectively. Thus the caller must already find
13213 the super-type and set p->overridden correctly. */
13216 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13217 gfc_typebound_proc
* p
, const char* name
)
13219 gfc_tbp_generic
* target
;
13220 gfc_symtree
* first_target
;
13221 gfc_symtree
* inherited
;
13223 gcc_assert (p
&& p
->is_generic
);
13225 /* Try to find the specific bindings for the symtrees in our target-list. */
13226 gcc_assert (p
->u
.generic
);
13227 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13228 if (!target
->specific
)
13230 gfc_typebound_proc
* overridden_tbp
;
13231 gfc_tbp_generic
* g
;
13232 const char* target_name
;
13234 target_name
= target
->specific_st
->name
;
13236 /* Defined for this type directly. */
13237 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13239 target
->specific
= target
->specific_st
->n
.tb
;
13240 goto specific_found
;
13243 /* Look for an inherited specific binding. */
13246 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13251 gcc_assert (inherited
->n
.tb
);
13252 target
->specific
= inherited
->n
.tb
;
13253 goto specific_found
;
13257 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13258 " at %L", target_name
, name
, &p
->where
);
13261 /* Once we've found the specific binding, check it is not ambiguous with
13262 other specifics already found or inherited for the same GENERIC. */
13264 gcc_assert (target
->specific
);
13266 /* This must really be a specific binding! */
13267 if (target
->specific
->is_generic
)
13269 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13270 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13274 /* Check those already resolved on this type directly. */
13275 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13276 if (g
!= target
&& g
->specific
13277 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13280 /* Check for ambiguity with inherited specific targets. */
13281 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13282 overridden_tbp
= overridden_tbp
->overridden
)
13283 if (overridden_tbp
->is_generic
)
13285 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13287 gcc_assert (g
->specific
);
13288 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13294 /* If we attempt to "overwrite" a specific binding, this is an error. */
13295 if (p
->overridden
&& !p
->overridden
->is_generic
)
13297 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13298 " the same name", name
, &p
->where
);
13302 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13303 all must have the same attributes here. */
13304 first_target
= p
->u
.generic
->specific
->u
.specific
;
13305 gcc_assert (first_target
);
13306 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13307 p
->function
= first_target
->n
.sym
->attr
.function
;
13313 /* Resolve a GENERIC procedure binding for a derived type. */
13316 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13318 gfc_symbol
* super_type
;
13320 /* Find the overridden binding if any. */
13321 st
->n
.tb
->overridden
= NULL
;
13322 super_type
= gfc_get_derived_super_type (derived
);
13325 gfc_symtree
* overridden
;
13326 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13329 if (overridden
&& overridden
->n
.tb
)
13330 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13333 /* Resolve using worker function. */
13334 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13338 /* Retrieve the target-procedure of an operator binding and do some checks in
13339 common for intrinsic and user-defined type-bound operators. */
13342 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13344 gfc_symbol
* target_proc
;
13346 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13347 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13348 gcc_assert (target_proc
);
13350 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13351 if (target
->specific
->nopass
)
13353 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13357 return target_proc
;
13361 /* Resolve a type-bound intrinsic operator. */
13364 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13365 gfc_typebound_proc
* p
)
13367 gfc_symbol
* super_type
;
13368 gfc_tbp_generic
* target
;
13370 /* If there's already an error here, do nothing (but don't fail again). */
13374 /* Operators should always be GENERIC bindings. */
13375 gcc_assert (p
->is_generic
);
13377 /* Look for an overridden binding. */
13378 super_type
= gfc_get_derived_super_type (derived
);
13379 if (super_type
&& super_type
->f2k_derived
)
13380 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13383 p
->overridden
= NULL
;
13385 /* Resolve general GENERIC properties using worker function. */
13386 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13389 /* Check the targets to be procedures of correct interface. */
13390 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13392 gfc_symbol
* target_proc
;
13394 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13398 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13401 /* Add target to non-typebound operator list. */
13402 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13403 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13405 gfc_interface
*head
, *intr
;
13407 /* Preempt 'gfc_check_new_interface' for submodules, where the
13408 mechanism for handling module procedures winds up resolving
13409 operator interfaces twice and would otherwise cause an error. */
13410 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13411 if (intr
->sym
== target_proc
13412 && target_proc
->attr
.used_in_submodule
)
13415 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13416 target_proc
, p
->where
))
13418 head
= derived
->ns
->op
[op
];
13419 intr
= gfc_get_interface ();
13420 intr
->sym
= target_proc
;
13421 intr
->where
= p
->where
;
13423 derived
->ns
->op
[op
] = intr
;
13435 /* Resolve a type-bound user operator (tree-walker callback). */
13437 static gfc_symbol
* resolve_bindings_derived
;
13438 static bool resolve_bindings_result
;
13440 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13443 resolve_typebound_user_op (gfc_symtree
* stree
)
13445 gfc_symbol
* super_type
;
13446 gfc_tbp_generic
* target
;
13448 gcc_assert (stree
&& stree
->n
.tb
);
13450 if (stree
->n
.tb
->error
)
13453 /* Operators should always be GENERIC bindings. */
13454 gcc_assert (stree
->n
.tb
->is_generic
);
13456 /* Find overridden procedure, if any. */
13457 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13458 if (super_type
&& super_type
->f2k_derived
)
13460 gfc_symtree
* overridden
;
13461 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13462 stree
->name
, true, NULL
);
13464 if (overridden
&& overridden
->n
.tb
)
13465 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13468 stree
->n
.tb
->overridden
= NULL
;
13470 /* Resolve basically using worker function. */
13471 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13474 /* Check the targets to be functions of correct interface. */
13475 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13477 gfc_symbol
* target_proc
;
13479 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13483 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13490 resolve_bindings_result
= false;
13491 stree
->n
.tb
->error
= 1;
13495 /* Resolve the type-bound procedures for a derived type. */
13498 resolve_typebound_procedure (gfc_symtree
* stree
)
13502 gfc_symbol
* me_arg
;
13503 gfc_symbol
* super_type
;
13504 gfc_component
* comp
;
13506 gcc_assert (stree
);
13508 /* Undefined specific symbol from GENERIC target definition. */
13512 if (stree
->n
.tb
->error
)
13515 /* If this is a GENERIC binding, use that routine. */
13516 if (stree
->n
.tb
->is_generic
)
13518 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13523 /* Get the target-procedure to check it. */
13524 gcc_assert (!stree
->n
.tb
->is_generic
);
13525 gcc_assert (stree
->n
.tb
->u
.specific
);
13526 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13527 where
= stree
->n
.tb
->where
;
13529 /* Default access should already be resolved from the parser. */
13530 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13532 if (stree
->n
.tb
->deferred
)
13534 if (!check_proc_interface (proc
, &where
))
13539 /* Check for F08:C465. */
13540 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13541 || (proc
->attr
.proc
!= PROC_MODULE
13542 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13543 || proc
->attr
.abstract
)
13545 gfc_error ("%qs must be a module procedure or an external procedure with"
13546 " an explicit interface at %L", proc
->name
, &where
);
13551 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13552 stree
->n
.tb
->function
= proc
->attr
.function
;
13554 /* Find the super-type of the current derived type. We could do this once and
13555 store in a global if speed is needed, but as long as not I believe this is
13556 more readable and clearer. */
13557 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13559 /* If PASS, resolve and check arguments if not already resolved / loaded
13560 from a .mod file. */
13561 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13563 gfc_formal_arglist
*dummy_args
;
13565 dummy_args
= gfc_sym_get_dummy_args (proc
);
13566 if (stree
->n
.tb
->pass_arg
)
13568 gfc_formal_arglist
*i
;
13570 /* If an explicit passing argument name is given, walk the arg-list
13571 and look for it. */
13574 stree
->n
.tb
->pass_arg_num
= 1;
13575 for (i
= dummy_args
; i
; i
= i
->next
)
13577 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13582 ++stree
->n
.tb
->pass_arg_num
;
13587 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13589 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13590 stree
->n
.tb
->pass_arg
);
13596 /* Otherwise, take the first one; there should in fact be at least
13598 stree
->n
.tb
->pass_arg_num
= 1;
13601 gfc_error ("Procedure %qs with PASS at %L must have at"
13602 " least one argument", proc
->name
, &where
);
13605 me_arg
= dummy_args
->sym
;
13608 /* Now check that the argument-type matches and the passed-object
13609 dummy argument is generally fine. */
13611 gcc_assert (me_arg
);
13613 if (me_arg
->ts
.type
!= BT_CLASS
)
13615 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13616 " at %L", proc
->name
, &where
);
13620 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13621 != resolve_bindings_derived
)
13623 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13624 " the derived-type %qs", me_arg
->name
, proc
->name
,
13625 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13629 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13630 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13632 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13633 " scalar", proc
->name
, &where
);
13636 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13638 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13639 " be ALLOCATABLE", proc
->name
, &where
);
13642 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13644 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13645 " be POINTER", proc
->name
, &where
);
13650 /* If we are extending some type, check that we don't override a procedure
13651 flagged NON_OVERRIDABLE. */
13652 stree
->n
.tb
->overridden
= NULL
;
13655 gfc_symtree
* overridden
;
13656 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13657 stree
->name
, true, NULL
);
13661 if (overridden
->n
.tb
)
13662 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13664 if (!gfc_check_typebound_override (stree
, overridden
))
13669 /* See if there's a name collision with a component directly in this type. */
13670 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13671 if (!strcmp (comp
->name
, stree
->name
))
13673 gfc_error ("Procedure %qs at %L has the same name as a component of"
13675 stree
->name
, &where
, resolve_bindings_derived
->name
);
13679 /* Try to find a name collision with an inherited component. */
13680 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13683 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13684 " component of %qs",
13685 stree
->name
, &where
, resolve_bindings_derived
->name
);
13689 stree
->n
.tb
->error
= 0;
13693 resolve_bindings_result
= false;
13694 stree
->n
.tb
->error
= 1;
13699 resolve_typebound_procedures (gfc_symbol
* derived
)
13702 gfc_symbol
* super_type
;
13704 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13707 super_type
= gfc_get_derived_super_type (derived
);
13709 resolve_symbol (super_type
);
13711 resolve_bindings_derived
= derived
;
13712 resolve_bindings_result
= true;
13714 if (derived
->f2k_derived
->tb_sym_root
)
13715 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13716 &resolve_typebound_procedure
);
13718 if (derived
->f2k_derived
->tb_uop_root
)
13719 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13720 &resolve_typebound_user_op
);
13722 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13724 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13725 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13726 (gfc_intrinsic_op
)op
, p
))
13727 resolve_bindings_result
= false;
13730 return resolve_bindings_result
;
13734 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13735 to give all identical derived types the same backend_decl. */
13737 add_dt_to_dt_list (gfc_symbol
*derived
)
13739 if (!derived
->dt_next
)
13741 if (gfc_derived_types
)
13743 derived
->dt_next
= gfc_derived_types
->dt_next
;
13744 gfc_derived_types
->dt_next
= derived
;
13748 derived
->dt_next
= derived
;
13750 gfc_derived_types
= derived
;
13755 /* Ensure that a derived-type is really not abstract, meaning that every
13756 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13759 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13764 if (!ensure_not_abstract_walker (sub
, st
->left
))
13766 if (!ensure_not_abstract_walker (sub
, st
->right
))
13769 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13771 gfc_symtree
* overriding
;
13772 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13775 gcc_assert (overriding
->n
.tb
);
13776 if (overriding
->n
.tb
->deferred
)
13778 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13779 " %qs is DEFERRED and not overridden",
13780 sub
->name
, &sub
->declared_at
, st
->name
);
13789 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13791 /* The algorithm used here is to recursively travel up the ancestry of sub
13792 and for each ancestor-type, check all bindings. If any of them is
13793 DEFERRED, look it up starting from sub and see if the found (overriding)
13794 binding is not DEFERRED.
13795 This is not the most efficient way to do this, but it should be ok and is
13796 clearer than something sophisticated. */
13798 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13800 if (!ancestor
->attr
.abstract
)
13803 /* Walk bindings of this ancestor. */
13804 if (ancestor
->f2k_derived
)
13807 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13812 /* Find next ancestor type and recurse on it. */
13813 ancestor
= gfc_get_derived_super_type (ancestor
);
13815 return ensure_not_abstract (sub
, ancestor
);
13821 /* This check for typebound defined assignments is done recursively
13822 since the order in which derived types are resolved is not always in
13823 order of the declarations. */
13826 check_defined_assignments (gfc_symbol
*derived
)
13830 for (c
= derived
->components
; c
; c
= c
->next
)
13832 if (!gfc_bt_struct (c
->ts
.type
)
13834 || c
->attr
.allocatable
13835 || c
->attr
.proc_pointer_comp
13836 || c
->attr
.class_pointer
13837 || c
->attr
.proc_pointer
)
13840 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13841 || (c
->ts
.u
.derived
->f2k_derived
13842 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13844 derived
->attr
.defined_assign_comp
= 1;
13848 check_defined_assignments (c
->ts
.u
.derived
);
13849 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13851 derived
->attr
.defined_assign_comp
= 1;
13858 /* Resolve a single component of a derived type or structure. */
13861 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13863 gfc_symbol
*super_type
;
13864 symbol_attribute
*attr
;
13866 if (c
->attr
.artificial
)
13869 /* Do not allow vtype components to be resolved in nameless namespaces
13870 such as block data because the procedure pointers will cause ICEs
13871 and vtables are not needed in these contexts. */
13872 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13873 && sym
->ns
->proc_name
== NULL
)
13877 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13878 && c
->attr
.codimension
13879 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13881 gfc_error ("Coarray component %qs at %L must be allocatable with "
13882 "deferred shape", c
->name
, &c
->loc
);
13887 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13888 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13890 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13891 "shall not be a coarray", c
->name
, &c
->loc
);
13896 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13897 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13898 || c
->attr
.allocatable
))
13900 gfc_error ("Component %qs at %L with coarray component "
13901 "shall be a nonpointer, nonallocatable scalar",
13907 if (c
->ts
.type
== BT_CLASS
)
13909 if (CLASS_DATA (c
))
13911 attr
= &(CLASS_DATA (c
)->attr
);
13913 /* Fix up contiguous attribute. */
13914 if (c
->attr
.contiguous
)
13915 attr
->contiguous
= 1;
13923 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
13925 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13926 "is not an array pointer", c
->name
, &c
->loc
);
13930 /* F2003, 15.2.1 - length has to be one. */
13931 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13932 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
13933 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
13934 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
13936 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13941 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13943 gfc_symbol
*ifc
= c
->ts
.interface
;
13945 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13951 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13953 /* Resolve interface and copy attributes. */
13954 if (ifc
->formal
&& !ifc
->formal_ns
)
13955 resolve_symbol (ifc
);
13956 if (ifc
->attr
.intrinsic
)
13957 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13961 c
->ts
= ifc
->result
->ts
;
13962 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13963 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13964 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13965 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13966 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13971 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13972 c
->attr
.pointer
= ifc
->attr
.pointer
;
13973 c
->attr
.dimension
= ifc
->attr
.dimension
;
13974 c
->as
= gfc_copy_array_spec (ifc
->as
);
13975 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13977 c
->ts
.interface
= ifc
;
13978 c
->attr
.function
= ifc
->attr
.function
;
13979 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13981 c
->attr
.pure
= ifc
->attr
.pure
;
13982 c
->attr
.elemental
= ifc
->attr
.elemental
;
13983 c
->attr
.recursive
= ifc
->attr
.recursive
;
13984 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13985 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13986 /* Copy char length. */
13987 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13989 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13990 if (cl
->length
&& !cl
->resolved
13991 && !gfc_resolve_expr (cl
->length
))
14000 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14002 /* Since PPCs are not implicitly typed, a PPC without an explicit
14003 interface must be a subroutine. */
14004 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14007 /* Procedure pointer components: Check PASS arg. */
14008 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14009 && !sym
->attr
.vtype
)
14011 gfc_symbol
* me_arg
;
14013 if (c
->tb
->pass_arg
)
14015 gfc_formal_arglist
* i
;
14017 /* If an explicit passing argument name is given, walk the arg-list
14018 and look for it. */
14021 c
->tb
->pass_arg_num
= 1;
14022 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14024 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14029 c
->tb
->pass_arg_num
++;
14034 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14035 "at %L has no argument %qs", c
->name
,
14036 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14043 /* Otherwise, take the first one; there should in fact be at least
14045 c
->tb
->pass_arg_num
= 1;
14046 if (!c
->ts
.interface
->formal
)
14048 gfc_error ("Procedure pointer component %qs with PASS at %L "
14049 "must have at least one argument",
14054 me_arg
= c
->ts
.interface
->formal
->sym
;
14057 /* Now check that the argument-type matches. */
14058 gcc_assert (me_arg
);
14059 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14060 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14061 || (me_arg
->ts
.type
== BT_CLASS
14062 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14064 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14065 " the derived type %qs", me_arg
->name
, c
->name
,
14066 me_arg
->name
, &c
->loc
, sym
->name
);
14071 /* Check for F03:C453. */
14072 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14074 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14075 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14081 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14083 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14084 "may not have the POINTER attribute", me_arg
->name
,
14085 c
->name
, me_arg
->name
, &c
->loc
);
14090 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14092 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14093 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14094 me_arg
->name
, &c
->loc
);
14099 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14101 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14102 " at %L", c
->name
, &c
->loc
);
14108 /* Check type-spec if this is not the parent-type component. */
14109 if (((sym
->attr
.is_class
14110 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14111 || c
!= sym
->components
->ts
.u
.derived
->components
))
14112 || (!sym
->attr
.is_class
14113 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14114 && !sym
->attr
.vtype
14115 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14118 super_type
= gfc_get_derived_super_type (sym
);
14120 /* If this type is an extension, set the accessibility of the parent
14123 && ((sym
->attr
.is_class
14124 && c
== sym
->components
->ts
.u
.derived
->components
)
14125 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14126 && strcmp (super_type
->name
, c
->name
) == 0)
14127 c
->attr
.access
= super_type
->attr
.access
;
14129 /* If this type is an extension, see if this component has the same name
14130 as an inherited type-bound procedure. */
14131 if (super_type
&& !sym
->attr
.is_class
14132 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14134 gfc_error ("Component %qs of %qs at %L has the same name as an"
14135 " inherited type-bound procedure",
14136 c
->name
, sym
->name
, &c
->loc
);
14140 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14141 && !c
->ts
.deferred
)
14143 if (c
->ts
.u
.cl
->length
== NULL
14144 || (!resolve_charlen(c
->ts
.u
.cl
))
14145 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14147 gfc_error ("Character length of component %qs needs to "
14148 "be a constant specification expression at %L",
14150 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14155 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14156 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14158 gfc_error ("Character component %qs of %qs at %L with deferred "
14159 "length must be a POINTER or ALLOCATABLE",
14160 c
->name
, sym
->name
, &c
->loc
);
14164 /* Add the hidden deferred length field. */
14165 if (c
->ts
.type
== BT_CHARACTER
14166 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14167 && !c
->attr
.function
14168 && !sym
->attr
.is_class
)
14170 char name
[GFC_MAX_SYMBOL_LEN
+9];
14171 gfc_component
*strlen
;
14172 sprintf (name
, "_%s_length", c
->name
);
14173 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14174 if (strlen
== NULL
)
14176 if (!gfc_add_component (sym
, name
, &strlen
))
14178 strlen
->ts
.type
= BT_INTEGER
;
14179 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14180 strlen
->attr
.access
= ACCESS_PRIVATE
;
14181 strlen
->attr
.artificial
= 1;
14185 if (c
->ts
.type
== BT_DERIVED
14186 && sym
->component_access
!= ACCESS_PRIVATE
14187 && gfc_check_symbol_access (sym
)
14188 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14189 && !c
->ts
.u
.derived
->attr
.use_assoc
14190 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14191 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14192 "PRIVATE type and cannot be a component of "
14193 "%qs, which is PUBLIC at %L", c
->name
,
14194 sym
->name
, &sym
->declared_at
))
14197 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14199 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14200 "type %s", c
->name
, &c
->loc
, sym
->name
);
14204 if (sym
->attr
.sequence
)
14206 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14208 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14209 "not have the SEQUENCE attribute",
14210 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14215 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14216 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14217 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14218 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14219 CLASS_DATA (c
)->ts
.u
.derived
14220 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14222 /* If an allocatable component derived type is of the same type as
14223 the enclosing derived type, we need a vtable generating so that
14224 the __deallocate procedure is created. */
14225 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14226 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14227 gfc_find_vtab (&c
->ts
);
14229 /* Ensure that all the derived type components are put on the
14230 derived type list; even in formal namespaces, where derived type
14231 pointer components might not have been declared. */
14232 if (c
->ts
.type
== BT_DERIVED
14234 && c
->ts
.u
.derived
->components
14236 && sym
!= c
->ts
.u
.derived
)
14237 add_dt_to_dt_list (c
->ts
.u
.derived
);
14239 if (!gfc_resolve_array_spec (c
->as
,
14240 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14241 || c
->attr
.allocatable
)))
14244 if (c
->initializer
&& !sym
->attr
.vtype
14245 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14246 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14253 /* Be nice about the locus for a structure expression - show the locus of the
14254 first non-null sub-expression if we can. */
14257 cons_where (gfc_expr
*struct_expr
)
14259 gfc_constructor
*cons
;
14261 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14263 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14264 for (; cons
; cons
= gfc_constructor_next (cons
))
14266 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14267 return &cons
->expr
->where
;
14270 return &struct_expr
->where
;
14273 /* Resolve the components of a structure type. Much less work than derived
14277 resolve_fl_struct (gfc_symbol
*sym
)
14280 gfc_expr
*init
= NULL
;
14283 /* Make sure UNIONs do not have overlapping initializers. */
14284 if (sym
->attr
.flavor
== FL_UNION
)
14286 for (c
= sym
->components
; c
; c
= c
->next
)
14288 if (init
&& c
->initializer
)
14290 gfc_error ("Conflicting initializers in union at %L and %L",
14291 cons_where (init
), cons_where (c
->initializer
));
14292 gfc_free_expr (c
->initializer
);
14293 c
->initializer
= NULL
;
14296 init
= c
->initializer
;
14301 for (c
= sym
->components
; c
; c
= c
->next
)
14302 if (!resolve_component (c
, sym
))
14308 if (sym
->components
)
14309 add_dt_to_dt_list (sym
);
14315 /* Resolve the components of a derived type. This does not have to wait until
14316 resolution stage, but can be done as soon as the dt declaration has been
14320 resolve_fl_derived0 (gfc_symbol
*sym
)
14322 gfc_symbol
* super_type
;
14324 gfc_formal_arglist
*f
;
14327 if (sym
->attr
.unlimited_polymorphic
)
14330 super_type
= gfc_get_derived_super_type (sym
);
14333 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14335 gfc_error ("As extending type %qs at %L has a coarray component, "
14336 "parent type %qs shall also have one", sym
->name
,
14337 &sym
->declared_at
, super_type
->name
);
14341 /* Ensure the extended type gets resolved before we do. */
14342 if (super_type
&& !resolve_fl_derived0 (super_type
))
14345 /* An ABSTRACT type must be extensible. */
14346 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14348 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14349 sym
->name
, &sym
->declared_at
);
14353 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14357 for ( ; c
!= NULL
; c
= c
->next
)
14358 if (!resolve_component (c
, sym
))
14364 /* Now add the caf token field, where needed. */
14365 if (flag_coarray
!= GFC_FCOARRAY_NONE
14366 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14368 for (c
= sym
->components
; c
; c
= c
->next
)
14369 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14370 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14372 char name
[GFC_MAX_SYMBOL_LEN
+9];
14373 gfc_component
*token
;
14374 sprintf (name
, "_caf_%s", c
->name
);
14375 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14378 if (!gfc_add_component (sym
, name
, &token
))
14380 token
->ts
.type
= BT_VOID
;
14381 token
->ts
.kind
= gfc_default_integer_kind
;
14382 token
->attr
.access
= ACCESS_PRIVATE
;
14383 token
->attr
.artificial
= 1;
14384 token
->attr
.caf_token
= 1;
14389 check_defined_assignments (sym
);
14391 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14392 sym
->attr
.defined_assign_comp
14393 = super_type
->attr
.defined_assign_comp
;
14395 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14396 all DEFERRED bindings are overridden. */
14397 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14398 && !sym
->attr
.is_class
14399 && !ensure_not_abstract (sym
, super_type
))
14402 /* Check that there is a component for every PDT parameter. */
14403 if (sym
->attr
.pdt_template
)
14405 for (f
= sym
->formal
; f
; f
= f
->next
)
14409 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14412 gfc_error ("Parameterized type %qs does not have a component "
14413 "corresponding to parameter %qs at %L", sym
->name
,
14414 f
->sym
->name
, &sym
->declared_at
);
14420 /* Add derived type to the derived type list. */
14421 add_dt_to_dt_list (sym
);
14427 /* The following procedure does the full resolution of a derived type,
14428 including resolution of all type-bound procedures (if present). In contrast
14429 to 'resolve_fl_derived0' this can only be done after the module has been
14430 parsed completely. */
14433 resolve_fl_derived (gfc_symbol
*sym
)
14435 gfc_symbol
*gen_dt
= NULL
;
14437 if (sym
->attr
.unlimited_polymorphic
)
14440 if (!sym
->attr
.is_class
)
14441 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14442 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14443 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14444 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14445 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14446 "%qs at %L being the same name as derived "
14447 "type at %L", sym
->name
,
14448 gen_dt
->generic
->sym
== sym
14449 ? gen_dt
->generic
->next
->sym
->name
14450 : gen_dt
->generic
->sym
->name
,
14451 gen_dt
->generic
->sym
== sym
14452 ? &gen_dt
->generic
->next
->sym
->declared_at
14453 : &gen_dt
->generic
->sym
->declared_at
,
14454 &sym
->declared_at
))
14457 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14459 gfc_error ("Derived type %qs at %L has not been declared",
14460 sym
->name
, &sym
->declared_at
);
14464 /* Resolve the finalizer procedures. */
14465 if (!gfc_resolve_finalizers (sym
, NULL
))
14468 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14470 /* Fix up incomplete CLASS symbols. */
14471 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14472 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14474 /* Nothing more to do for unlimited polymorphic entities. */
14475 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14477 else if (vptr
->ts
.u
.derived
== NULL
)
14479 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14481 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14482 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14487 if (!resolve_fl_derived0 (sym
))
14490 /* Resolve the type-bound procedures. */
14491 if (!resolve_typebound_procedures (sym
))
14494 /* Generate module vtables subject to their accessibility and their not
14495 being vtables or pdt templates. If this is not done class declarations
14496 in external procedures wind up with their own version and so SELECT TYPE
14497 fails because the vptrs do not have the same address. */
14498 if (gfc_option
.allow_std
& GFC_STD_F2003
14499 && sym
->ns
->proc_name
14500 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14501 && sym
->attr
.access
!= ACCESS_PRIVATE
14502 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14504 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14505 gfc_set_sym_referenced (vtab
);
14513 resolve_fl_namelist (gfc_symbol
*sym
)
14518 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14520 /* Check again, the check in match only works if NAMELIST comes
14522 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14524 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14525 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14529 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14530 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14531 "with assumed shape in namelist %qs at %L",
14532 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14535 if (is_non_constant_shape_array (nl
->sym
)
14536 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14537 "with nonconstant shape in namelist %qs at %L",
14538 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14541 if (nl
->sym
->ts
.type
== BT_CHARACTER
14542 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14543 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14544 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14545 "nonconstant character length in "
14546 "namelist %qs at %L", nl
->sym
->name
,
14547 sym
->name
, &sym
->declared_at
))
14552 /* Reject PRIVATE objects in a PUBLIC namelist. */
14553 if (gfc_check_symbol_access (sym
))
14555 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14557 if (!nl
->sym
->attr
.use_assoc
14558 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14559 && !gfc_check_symbol_access (nl
->sym
))
14561 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14562 "cannot be member of PUBLIC namelist %qs at %L",
14563 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14567 if (nl
->sym
->ts
.type
== BT_DERIVED
14568 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14569 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14571 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14572 "namelist %qs at %L with ALLOCATABLE "
14573 "or POINTER components", nl
->sym
->name
,
14574 sym
->name
, &sym
->declared_at
))
14579 /* Types with private components that came here by USE-association. */
14580 if (nl
->sym
->ts
.type
== BT_DERIVED
14581 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14583 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14584 "components and cannot be member of namelist %qs at %L",
14585 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14589 /* Types with private components that are defined in the same module. */
14590 if (nl
->sym
->ts
.type
== BT_DERIVED
14591 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14592 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14594 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14595 "cannot be a member of PUBLIC namelist %qs at %L",
14596 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14603 /* 14.1.2 A module or internal procedure represent local entities
14604 of the same type as a namelist member and so are not allowed. */
14605 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14607 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14610 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14611 if ((nl
->sym
== sym
->ns
->proc_name
)
14613 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14618 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14619 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14621 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14622 "attribute in %qs at %L", nlsym
->name
,
14623 &sym
->declared_at
);
14630 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14631 nl
->sym
->attr
.asynchronous
= 1;
14638 resolve_fl_parameter (gfc_symbol
*sym
)
14640 /* A parameter array's shape needs to be constant. */
14641 if (sym
->as
!= NULL
14642 && (sym
->as
->type
== AS_DEFERRED
14643 || is_non_constant_shape_array (sym
)))
14645 gfc_error ("Parameter array %qs at %L cannot be automatic "
14646 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14650 /* Constraints on deferred type parameter. */
14651 if (!deferred_requirements (sym
))
14654 /* Make sure a parameter that has been implicitly typed still
14655 matches the implicit type, since PARAMETER statements can precede
14656 IMPLICIT statements. */
14657 if (sym
->attr
.implicit_type
14658 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14661 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14662 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14666 /* Make sure the types of derived parameters are consistent. This
14667 type checking is deferred until resolution because the type may
14668 refer to a derived type from the host. */
14669 if (sym
->ts
.type
== BT_DERIVED
14670 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14672 gfc_error ("Incompatible derived type in PARAMETER at %L",
14673 &sym
->value
->where
);
14677 /* F03:C509,C514. */
14678 if (sym
->ts
.type
== BT_CLASS
)
14680 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14681 sym
->name
, &sym
->declared_at
);
14689 /* Called by resolve_symbol to check PDTs. */
14692 resolve_pdt (gfc_symbol
* sym
)
14694 gfc_symbol
*derived
= NULL
;
14695 gfc_actual_arglist
*param
;
14697 bool const_len_exprs
= true;
14698 bool assumed_len_exprs
= false;
14699 symbol_attribute
*attr
;
14701 if (sym
->ts
.type
== BT_DERIVED
)
14703 derived
= sym
->ts
.u
.derived
;
14704 attr
= &(sym
->attr
);
14706 else if (sym
->ts
.type
== BT_CLASS
)
14708 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14709 attr
= &(CLASS_DATA (sym
)->attr
);
14712 gcc_unreachable ();
14714 gcc_assert (derived
->attr
.pdt_type
);
14716 for (param
= sym
->param_list
; param
; param
= param
->next
)
14718 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14720 if (c
->attr
.pdt_kind
)
14723 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14724 && c
->attr
.pdt_len
)
14725 const_len_exprs
= false;
14726 else if (param
->spec_type
== SPEC_ASSUMED
)
14727 assumed_len_exprs
= true;
14729 if (param
->spec_type
== SPEC_DEFERRED
14730 && !attr
->allocatable
&& !attr
->pointer
)
14731 gfc_error ("The object %qs at %L has a deferred LEN "
14732 "parameter %qs and is neither allocatable "
14733 "nor a pointer", sym
->name
, &sym
->declared_at
,
14738 if (!const_len_exprs
14739 && (sym
->ns
->proc_name
->attr
.is_main_program
14740 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14741 || sym
->attr
.save
!= SAVE_NONE
))
14742 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14743 "SAVE attribute or be a variable declared in the "
14744 "main program, a module or a submodule(F08/C513)",
14745 sym
->name
, &sym
->declared_at
);
14747 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14748 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14749 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14750 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14751 sym
->name
, &sym
->declared_at
);
14755 /* Do anything necessary to resolve a symbol. Right now, we just
14756 assume that an otherwise unknown symbol is a variable. This sort
14757 of thing commonly happens for symbols in module. */
14760 resolve_symbol (gfc_symbol
*sym
)
14762 int check_constant
, mp_flag
;
14763 gfc_symtree
*symtree
;
14764 gfc_symtree
*this_symtree
;
14767 symbol_attribute class_attr
;
14768 gfc_array_spec
*as
;
14769 bool saved_specification_expr
;
14775 /* No symbol will ever have union type; only components can be unions.
14776 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14777 (just like derived type declaration symbols have flavor FL_DERIVED). */
14778 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14780 /* Coarrayed polymorphic objects with allocatable or pointer components are
14781 yet unsupported for -fcoarray=lib. */
14782 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14783 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14784 && CLASS_DATA (sym
)->attr
.codimension
14785 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14786 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14788 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14789 "type coarrays at %L are unsupported", &sym
->declared_at
);
14793 if (sym
->attr
.artificial
)
14796 if (sym
->attr
.unlimited_polymorphic
)
14799 if (sym
->attr
.flavor
== FL_UNKNOWN
14800 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14801 && !sym
->attr
.generic
&& !sym
->attr
.external
14802 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14803 && sym
->ts
.type
== BT_UNKNOWN
))
14806 /* If we find that a flavorless symbol is an interface in one of the
14807 parent namespaces, find its symtree in this namespace, free the
14808 symbol and set the symtree to point to the interface symbol. */
14809 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14811 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14812 if (symtree
&& (symtree
->n
.sym
->generic
||
14813 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14814 && sym
->ns
->construct_entities
)))
14816 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14818 if (this_symtree
->n
.sym
== sym
)
14820 symtree
->n
.sym
->refs
++;
14821 gfc_release_symbol (sym
);
14822 this_symtree
->n
.sym
= symtree
->n
.sym
;
14828 /* Otherwise give it a flavor according to such attributes as
14830 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14831 && sym
->attr
.intrinsic
== 0)
14832 sym
->attr
.flavor
= FL_VARIABLE
;
14833 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14835 sym
->attr
.flavor
= FL_PROCEDURE
;
14836 if (sym
->attr
.dimension
)
14837 sym
->attr
.function
= 1;
14841 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14842 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14844 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14845 && !resolve_procedure_interface (sym
))
14848 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14849 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14851 if (sym
->attr
.external
)
14852 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14853 "at %L", &sym
->declared_at
);
14855 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14856 "at %L", &sym
->declared_at
);
14861 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14864 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14865 && !resolve_fl_struct (sym
))
14868 /* Symbols that are module procedures with results (functions) have
14869 the types and array specification copied for type checking in
14870 procedures that call them, as well as for saving to a module
14871 file. These symbols can't stand the scrutiny that their results
14873 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14875 /* Make sure that the intrinsic is consistent with its internal
14876 representation. This needs to be done before assigning a default
14877 type to avoid spurious warnings. */
14878 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14879 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14882 /* Resolve associate names. */
14884 resolve_assoc_var (sym
, true);
14886 /* Assign default type to symbols that need one and don't have one. */
14887 if (sym
->ts
.type
== BT_UNKNOWN
)
14889 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14891 gfc_set_default_type (sym
, 1, NULL
);
14894 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14895 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14896 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14897 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14899 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14901 /* The specific case of an external procedure should emit an error
14902 in the case that there is no implicit type. */
14905 if (!sym
->attr
.mixed_entry_master
)
14906 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14910 /* Result may be in another namespace. */
14911 resolve_symbol (sym
->result
);
14913 if (!sym
->result
->attr
.proc_pointer
)
14915 sym
->ts
= sym
->result
->ts
;
14916 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14917 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14918 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14919 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14920 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14925 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14927 bool saved_specification_expr
= specification_expr
;
14928 specification_expr
= true;
14929 gfc_resolve_array_spec (sym
->result
->as
, false);
14930 specification_expr
= saved_specification_expr
;
14933 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14935 as
= CLASS_DATA (sym
)->as
;
14936 class_attr
= CLASS_DATA (sym
)->attr
;
14937 class_attr
.pointer
= class_attr
.class_pointer
;
14941 class_attr
= sym
->attr
;
14946 if (sym
->attr
.contiguous
14947 && (!class_attr
.dimension
14948 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14949 && !class_attr
.pointer
)))
14951 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14952 "array pointer or an assumed-shape or assumed-rank array",
14953 sym
->name
, &sym
->declared_at
);
14957 /* Assumed size arrays and assumed shape arrays must be dummy
14958 arguments. Array-spec's of implied-shape should have been resolved to
14959 AS_EXPLICIT already. */
14963 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14964 specification expression. */
14965 if (as
->type
== AS_IMPLIED_SHAPE
)
14968 for (i
=0; i
<as
->rank
; i
++)
14970 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
14972 gfc_error ("Bad specification for assumed size array at %L",
14973 &as
->lower
[i
]->where
);
14980 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14981 || as
->type
== AS_ASSUMED_SHAPE
)
14982 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14984 if (as
->type
== AS_ASSUMED_SIZE
)
14985 gfc_error ("Assumed size array at %L must be a dummy argument",
14986 &sym
->declared_at
);
14988 gfc_error ("Assumed shape array at %L must be a dummy argument",
14989 &sym
->declared_at
);
14992 /* TS 29113, C535a. */
14993 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14994 && !sym
->attr
.select_type_temporary
)
14996 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14997 &sym
->declared_at
);
15000 if (as
->type
== AS_ASSUMED_RANK
15001 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15003 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15004 "CODIMENSION attribute", &sym
->declared_at
);
15009 /* Make sure symbols with known intent or optional are really dummy
15010 variable. Because of ENTRY statement, this has to be deferred
15011 until resolution time. */
15013 if (!sym
->attr
.dummy
15014 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15016 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15020 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15022 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15023 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15027 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15029 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15030 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15032 gfc_error ("Character dummy variable %qs at %L with VALUE "
15033 "attribute must have constant length",
15034 sym
->name
, &sym
->declared_at
);
15038 if (sym
->ts
.is_c_interop
15039 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15041 gfc_error ("C interoperable character dummy variable %qs at %L "
15042 "with VALUE attribute must have length one",
15043 sym
->name
, &sym
->declared_at
);
15048 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15049 && sym
->ts
.u
.derived
->attr
.generic
)
15051 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15052 if (!sym
->ts
.u
.derived
)
15054 gfc_error ("The derived type %qs at %L is of type %qs, "
15055 "which has not been defined", sym
->name
,
15056 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15057 sym
->ts
.type
= BT_UNKNOWN
;
15062 /* Use the same constraints as TYPE(*), except for the type check
15063 and that only scalars and assumed-size arrays are permitted. */
15064 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15066 if (!sym
->attr
.dummy
)
15068 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15069 "a dummy argument", sym
->name
, &sym
->declared_at
);
15073 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15074 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15075 && sym
->ts
.type
!= BT_COMPLEX
)
15077 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15078 "of type TYPE(*) or of an numeric intrinsic type",
15079 sym
->name
, &sym
->declared_at
);
15083 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15084 || sym
->attr
.pointer
|| sym
->attr
.value
)
15086 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15087 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15088 "attribute", sym
->name
, &sym
->declared_at
);
15092 if (sym
->attr
.intent
== INTENT_OUT
)
15094 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15095 "have the INTENT(OUT) attribute",
15096 sym
->name
, &sym
->declared_at
);
15099 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15101 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15102 "either be a scalar or an assumed-size array",
15103 sym
->name
, &sym
->declared_at
);
15107 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15108 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15110 sym
->ts
.type
= BT_ASSUMED
;
15111 sym
->as
= gfc_get_array_spec ();
15112 sym
->as
->type
= AS_ASSUMED_SIZE
;
15114 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15116 else if (sym
->ts
.type
== BT_ASSUMED
)
15118 /* TS 29113, C407a. */
15119 if (!sym
->attr
.dummy
)
15121 gfc_error ("Assumed type of variable %s at %L is only permitted "
15122 "for dummy variables", sym
->name
, &sym
->declared_at
);
15125 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15126 || sym
->attr
.pointer
|| sym
->attr
.value
)
15128 gfc_error ("Assumed-type variable %s at %L may not have the "
15129 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15130 sym
->name
, &sym
->declared_at
);
15133 if (sym
->attr
.intent
== INTENT_OUT
)
15135 gfc_error ("Assumed-type variable %s at %L may not have the "
15136 "INTENT(OUT) attribute",
15137 sym
->name
, &sym
->declared_at
);
15140 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15142 gfc_error ("Assumed-type variable %s at %L shall not be an "
15143 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15148 /* If the symbol is marked as bind(c), that it is declared at module level
15149 scope and verify its type and kind. Do not do the latter for symbols
15150 that are implicitly typed because that is handled in
15151 gfc_set_default_type. Handle dummy arguments and procedure definitions
15152 separately. Also, anything that is use associated is not handled here
15153 but instead is handled in the module it is declared in. Finally, derived
15154 type definitions are allowed to be BIND(C) since that only implies that
15155 they're interoperable, and they are checked fully for interoperability
15156 when a variable is declared of that type. */
15157 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15158 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15159 && sym
->attr
.flavor
!= FL_DERIVED
)
15163 /* First, make sure the variable is declared at the
15164 module-level scope (J3/04-007, Section 15.3). */
15165 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15166 sym
->attr
.in_common
== 0)
15168 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15169 "is neither a COMMON block nor declared at the "
15170 "module level scope", sym
->name
, &(sym
->declared_at
));
15173 else if (sym
->ts
.type
== BT_CHARACTER
15174 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15175 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15176 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15178 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15179 sym
->name
, &sym
->declared_at
);
15182 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15184 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15186 else if (sym
->attr
.implicit_type
== 0)
15188 /* If type() declaration, we need to verify that the components
15189 of the given type are all C interoperable, etc. */
15190 if (sym
->ts
.type
== BT_DERIVED
&&
15191 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15193 /* Make sure the user marked the derived type as BIND(C). If
15194 not, call the verify routine. This could print an error
15195 for the derived type more than once if multiple variables
15196 of that type are declared. */
15197 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15198 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15202 /* Verify the variable itself as C interoperable if it
15203 is BIND(C). It is not possible for this to succeed if
15204 the verify_bind_c_derived_type failed, so don't have to handle
15205 any error returned by verify_bind_c_derived_type. */
15206 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15207 sym
->common_block
);
15212 /* clear the is_bind_c flag to prevent reporting errors more than
15213 once if something failed. */
15214 sym
->attr
.is_bind_c
= 0;
15219 /* If a derived type symbol has reached this point, without its
15220 type being declared, we have an error. Notice that most
15221 conditions that produce undefined derived types have already
15222 been dealt with. However, the likes of:
15223 implicit type(t) (t) ..... call foo (t) will get us here if
15224 the type is not declared in the scope of the implicit
15225 statement. Change the type to BT_UNKNOWN, both because it is so
15226 and to prevent an ICE. */
15227 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15228 && sym
->ts
.u
.derived
->components
== NULL
15229 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15231 gfc_error ("The derived type %qs at %L is of type %qs, "
15232 "which has not been defined", sym
->name
,
15233 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15234 sym
->ts
.type
= BT_UNKNOWN
;
15238 /* Make sure that the derived type has been resolved and that the
15239 derived type is visible in the symbol's namespace, if it is a
15240 module function and is not PRIVATE. */
15241 if (sym
->ts
.type
== BT_DERIVED
15242 && sym
->ts
.u
.derived
->attr
.use_assoc
15243 && sym
->ns
->proc_name
15244 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15245 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15248 /* Unless the derived-type declaration is use associated, Fortran 95
15249 does not allow public entries of private derived types.
15250 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15251 161 in 95-006r3. */
15252 if (sym
->ts
.type
== BT_DERIVED
15253 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15254 && !sym
->ts
.u
.derived
->attr
.use_assoc
15255 && gfc_check_symbol_access (sym
)
15256 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15257 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15258 "derived type %qs",
15259 (sym
->attr
.flavor
== FL_PARAMETER
)
15260 ? "parameter" : "variable",
15261 sym
->name
, &sym
->declared_at
,
15262 sym
->ts
.u
.derived
->name
))
15265 /* F2008, C1302. */
15266 if (sym
->ts
.type
== BT_DERIVED
15267 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15268 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15269 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15270 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15272 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15273 "type LOCK_TYPE must be a coarray", sym
->name
,
15274 &sym
->declared_at
);
15278 /* TS18508, C702/C703. */
15279 if (sym
->ts
.type
== BT_DERIVED
15280 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15281 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15282 || sym
->ts
.u
.derived
->attr
.event_comp
)
15283 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15285 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15286 "type EVENT_TYPE must be a coarray", sym
->name
,
15287 &sym
->declared_at
);
15291 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15292 default initialization is defined (5.1.2.4.4). */
15293 if (sym
->ts
.type
== BT_DERIVED
15295 && sym
->attr
.intent
== INTENT_OUT
15297 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15299 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15301 if (c
->initializer
)
15303 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15304 "ASSUMED SIZE and so cannot have a default initializer",
15305 sym
->name
, &sym
->declared_at
);
15312 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15313 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15315 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15316 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15321 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15322 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15324 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15325 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15330 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15331 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15332 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15333 || class_attr
.codimension
)
15334 && (sym
->attr
.result
|| sym
->result
== sym
))
15336 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15337 "a coarray component", sym
->name
, &sym
->declared_at
);
15342 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15343 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15345 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15346 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15351 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15352 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15353 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15354 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15355 || class_attr
.allocatable
))
15357 gfc_error ("Variable %qs at %L with coarray component shall be a "
15358 "nonpointer, nonallocatable scalar, which is not a coarray",
15359 sym
->name
, &sym
->declared_at
);
15363 /* F2008, C526. The function-result case was handled above. */
15364 if (class_attr
.codimension
15365 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15366 || sym
->attr
.select_type_temporary
15367 || sym
->attr
.associate_var
15368 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15369 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15370 || sym
->ns
->proc_name
->attr
.is_main_program
15371 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15373 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15374 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15378 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15379 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15381 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15382 "deferred shape", sym
->name
, &sym
->declared_at
);
15385 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15386 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15388 gfc_error ("Allocatable coarray variable %qs at %L must have "
15389 "deferred shape", sym
->name
, &sym
->declared_at
);
15394 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15395 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15396 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15397 || (class_attr
.codimension
&& class_attr
.allocatable
))
15398 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15400 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15401 "allocatable coarray or have coarray components",
15402 sym
->name
, &sym
->declared_at
);
15406 if (class_attr
.codimension
&& sym
->attr
.dummy
15407 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15409 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15410 "procedure %qs", sym
->name
, &sym
->declared_at
,
15411 sym
->ns
->proc_name
->name
);
15415 if (sym
->ts
.type
== BT_LOGICAL
15416 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15417 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15418 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15421 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15422 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15424 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15425 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15426 "%L with non-C_Bool kind in BIND(C) procedure "
15427 "%qs", sym
->name
, &sym
->declared_at
,
15428 sym
->ns
->proc_name
->name
))
15430 else if (!gfc_logical_kinds
[i
].c_bool
15431 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15432 "%qs at %L with non-C_Bool kind in "
15433 "BIND(C) procedure %qs", sym
->name
,
15435 sym
->attr
.function
? sym
->name
15436 : sym
->ns
->proc_name
->name
))
15440 switch (sym
->attr
.flavor
)
15443 if (!resolve_fl_variable (sym
, mp_flag
))
15448 if (sym
->formal
&& !sym
->formal_ns
)
15450 /* Check that none of the arguments are a namelist. */
15451 gfc_formal_arglist
*formal
= sym
->formal
;
15453 for (; formal
; formal
= formal
->next
)
15454 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15456 gfc_error ("Namelist %qs cannot be an argument to "
15457 "subroutine or function at %L",
15458 formal
->sym
->name
, &sym
->declared_at
);
15463 if (!resolve_fl_procedure (sym
, mp_flag
))
15468 if (!resolve_fl_namelist (sym
))
15473 if (!resolve_fl_parameter (sym
))
15481 /* Resolve array specifier. Check as well some constraints
15482 on COMMON blocks. */
15484 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15486 /* Set the formal_arg_flag so that check_conflict will not throw
15487 an error for host associated variables in the specification
15488 expression for an array_valued function. */
15489 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15490 formal_arg_flag
= true;
15492 saved_specification_expr
= specification_expr
;
15493 specification_expr
= true;
15494 gfc_resolve_array_spec (sym
->as
, check_constant
);
15495 specification_expr
= saved_specification_expr
;
15497 formal_arg_flag
= false;
15499 /* Resolve formal namespaces. */
15500 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15501 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15502 gfc_resolve (sym
->formal_ns
);
15504 /* Make sure the formal namespace is present. */
15505 if (sym
->formal
&& !sym
->formal_ns
)
15507 gfc_formal_arglist
*formal
= sym
->formal
;
15508 while (formal
&& !formal
->sym
)
15509 formal
= formal
->next
;
15513 sym
->formal_ns
= formal
->sym
->ns
;
15514 if (sym
->ns
!= formal
->sym
->ns
)
15515 sym
->formal_ns
->refs
++;
15519 /* Check threadprivate restrictions. */
15520 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15521 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15522 && (!sym
->attr
.in_common
15523 && sym
->module
== NULL
15524 && (sym
->ns
->proc_name
== NULL
15525 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15526 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15528 /* Check omp declare target restrictions. */
15529 if (sym
->attr
.omp_declare_target
15530 && sym
->attr
.flavor
== FL_VARIABLE
15532 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15533 && (!sym
->attr
.in_common
15534 && sym
->module
== NULL
15535 && (sym
->ns
->proc_name
== NULL
15536 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15537 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15538 sym
->name
, &sym
->declared_at
);
15540 /* If we have come this far we can apply default-initializers, as
15541 described in 14.7.5, to those variables that have not already
15542 been assigned one. */
15543 if (sym
->ts
.type
== BT_DERIVED
15545 && !sym
->attr
.allocatable
15546 && !sym
->attr
.alloc_comp
)
15548 symbol_attribute
*a
= &sym
->attr
;
15550 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15551 && !a
->in_common
&& !a
->use_assoc
15553 && !((a
->function
|| a
->result
)
15555 || sym
->ts
.u
.derived
->attr
.alloc_comp
15556 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15557 && !(a
->function
&& sym
!= sym
->result
))
15558 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15559 apply_default_init (sym
);
15560 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15561 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15562 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15563 /* Mark the result symbol to be referenced, when it has allocatable
15565 sym
->result
->attr
.referenced
= 1;
15568 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15569 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15570 && !CLASS_DATA (sym
)->attr
.class_pointer
15571 && !CLASS_DATA (sym
)->attr
.allocatable
)
15572 apply_default_init (sym
);
15574 /* If this symbol has a type-spec, check it. */
15575 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15576 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15577 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15580 if (sym
->param_list
)
15585 /************* Resolve DATA statements *************/
15589 gfc_data_value
*vnode
;
15595 /* Advance the values structure to point to the next value in the data list. */
15598 next_data_value (void)
15600 while (mpz_cmp_ui (values
.left
, 0) == 0)
15603 if (values
.vnode
->next
== NULL
)
15606 values
.vnode
= values
.vnode
->next
;
15607 mpz_set (values
.left
, values
.vnode
->repeat
);
15615 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15621 ar_type mark
= AR_UNKNOWN
;
15623 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15629 if (!gfc_resolve_expr (var
->expr
))
15633 mpz_init_set_si (offset
, 0);
15636 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15637 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15638 e
= e
->value
.function
.actual
->expr
;
15640 if (e
->expr_type
!= EXPR_VARIABLE
)
15642 gfc_error ("Expecting definable entity near %L", where
);
15646 sym
= e
->symtree
->n
.sym
;
15648 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15650 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15651 sym
->name
, &sym
->declared_at
);
15655 if (e
->ref
== NULL
&& sym
->as
)
15657 gfc_error ("DATA array %qs at %L must be specified in a previous"
15658 " declaration", sym
->name
, where
);
15662 has_pointer
= sym
->attr
.pointer
;
15664 if (gfc_is_coindexed (e
))
15666 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15671 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15673 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15677 && ref
->type
== REF_ARRAY
15678 && ref
->u
.ar
.type
!= AR_FULL
)
15680 gfc_error ("DATA element %qs at %L is a pointer and so must "
15681 "be a full array", sym
->name
, where
);
15686 if (e
->rank
== 0 || has_pointer
)
15688 mpz_init_set_ui (size
, 1);
15695 /* Find the array section reference. */
15696 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15698 if (ref
->type
!= REF_ARRAY
)
15700 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15706 /* Set marks according to the reference pattern. */
15707 switch (ref
->u
.ar
.type
)
15715 /* Get the start position of array section. */
15716 gfc_get_section_index (ar
, section_index
, &offset
);
15721 gcc_unreachable ();
15724 if (!gfc_array_size (e
, &size
))
15726 gfc_error ("Nonconstant array section at %L in DATA statement",
15728 mpz_clear (offset
);
15735 while (mpz_cmp_ui (size
, 0) > 0)
15737 if (!next_data_value ())
15739 gfc_error ("DATA statement at %L has more variables than values",
15745 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15749 /* If we have more than one element left in the repeat count,
15750 and we have more than one element left in the target variable,
15751 then create a range assignment. */
15752 /* FIXME: Only done for full arrays for now, since array sections
15754 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15755 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15759 if (mpz_cmp (size
, values
.left
) >= 0)
15761 mpz_init_set (range
, values
.left
);
15762 mpz_sub (size
, size
, values
.left
);
15763 mpz_set_ui (values
.left
, 0);
15767 mpz_init_set (range
, size
);
15768 mpz_sub (values
.left
, values
.left
, size
);
15769 mpz_set_ui (size
, 0);
15772 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15775 mpz_add (offset
, offset
, range
);
15782 /* Assign initial value to symbol. */
15785 mpz_sub_ui (values
.left
, values
.left
, 1);
15786 mpz_sub_ui (size
, size
, 1);
15788 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15793 if (mark
== AR_FULL
)
15794 mpz_add_ui (offset
, offset
, 1);
15796 /* Modify the array section indexes and recalculate the offset
15797 for next element. */
15798 else if (mark
== AR_SECTION
)
15799 gfc_advance_section (section_index
, ar
, &offset
);
15803 if (mark
== AR_SECTION
)
15805 for (i
= 0; i
< ar
->dimen
; i
++)
15806 mpz_clear (section_index
[i
]);
15810 mpz_clear (offset
);
15816 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15818 /* Iterate over a list of elements in a DATA statement. */
15821 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15824 iterator_stack frame
;
15825 gfc_expr
*e
, *start
, *end
, *step
;
15826 bool retval
= true;
15828 mpz_init (frame
.value
);
15831 start
= gfc_copy_expr (var
->iter
.start
);
15832 end
= gfc_copy_expr (var
->iter
.end
);
15833 step
= gfc_copy_expr (var
->iter
.step
);
15835 if (!gfc_simplify_expr (start
, 1)
15836 || start
->expr_type
!= EXPR_CONSTANT
)
15838 gfc_error ("start of implied-do loop at %L could not be "
15839 "simplified to a constant value", &start
->where
);
15843 if (!gfc_simplify_expr (end
, 1)
15844 || end
->expr_type
!= EXPR_CONSTANT
)
15846 gfc_error ("end of implied-do loop at %L could not be "
15847 "simplified to a constant value", &start
->where
);
15851 if (!gfc_simplify_expr (step
, 1)
15852 || step
->expr_type
!= EXPR_CONSTANT
)
15854 gfc_error ("step of implied-do loop at %L could not be "
15855 "simplified to a constant value", &start
->where
);
15860 mpz_set (trip
, end
->value
.integer
);
15861 mpz_sub (trip
, trip
, start
->value
.integer
);
15862 mpz_add (trip
, trip
, step
->value
.integer
);
15864 mpz_div (trip
, trip
, step
->value
.integer
);
15866 mpz_set (frame
.value
, start
->value
.integer
);
15868 frame
.prev
= iter_stack
;
15869 frame
.variable
= var
->iter
.var
->symtree
;
15870 iter_stack
= &frame
;
15872 while (mpz_cmp_ui (trip
, 0) > 0)
15874 if (!traverse_data_var (var
->list
, where
))
15880 e
= gfc_copy_expr (var
->expr
);
15881 if (!gfc_simplify_expr (e
, 1))
15888 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15890 mpz_sub_ui (trip
, trip
, 1);
15894 mpz_clear (frame
.value
);
15897 gfc_free_expr (start
);
15898 gfc_free_expr (end
);
15899 gfc_free_expr (step
);
15901 iter_stack
= frame
.prev
;
15906 /* Type resolve variables in the variable list of a DATA statement. */
15909 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15913 for (; var
; var
= var
->next
)
15915 if (var
->expr
== NULL
)
15916 t
= traverse_data_list (var
, where
);
15918 t
= check_data_variable (var
, where
);
15928 /* Resolve the expressions and iterators associated with a data statement.
15929 This is separate from the assignment checking because data lists should
15930 only be resolved once. */
15933 resolve_data_variables (gfc_data_variable
*d
)
15935 for (; d
; d
= d
->next
)
15937 if (d
->list
== NULL
)
15939 if (!gfc_resolve_expr (d
->expr
))
15944 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15947 if (!resolve_data_variables (d
->list
))
15956 /* Resolve a single DATA statement. We implement this by storing a pointer to
15957 the value list into static variables, and then recursively traversing the
15958 variables list, expanding iterators and such. */
15961 resolve_data (gfc_data
*d
)
15964 if (!resolve_data_variables (d
->var
))
15967 values
.vnode
= d
->value
;
15968 if (d
->value
== NULL
)
15969 mpz_set_ui (values
.left
, 0);
15971 mpz_set (values
.left
, d
->value
->repeat
);
15973 if (!traverse_data_var (d
->var
, &d
->where
))
15976 /* At this point, we better not have any values left. */
15978 if (next_data_value ())
15979 gfc_error ("DATA statement at %L has more values than variables",
15984 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15985 accessed by host or use association, is a dummy argument to a pure function,
15986 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15987 is storage associated with any such variable, shall not be used in the
15988 following contexts: (clients of this function). */
15990 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15991 procedure. Returns zero if assignment is OK, nonzero if there is a
15994 gfc_impure_variable (gfc_symbol
*sym
)
15999 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16002 /* Check if the symbol's ns is inside the pure procedure. */
16003 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16007 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16011 proc
= sym
->ns
->proc_name
;
16012 if (sym
->attr
.dummy
16013 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16014 || proc
->attr
.function
))
16017 /* TODO: Sort out what can be storage associated, if anything, and include
16018 it here. In principle equivalences should be scanned but it does not
16019 seem to be possible to storage associate an impure variable this way. */
16024 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16025 current namespace is inside a pure procedure. */
16028 gfc_pure (gfc_symbol
*sym
)
16030 symbol_attribute attr
;
16035 /* Check if the current namespace or one of its parents
16036 belongs to a pure procedure. */
16037 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16039 sym
= ns
->proc_name
;
16043 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16051 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16055 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16056 checks if the current namespace is implicitly pure. Note that this
16057 function returns false for a PURE procedure. */
16060 gfc_implicit_pure (gfc_symbol
*sym
)
16066 /* Check if the current procedure is implicit_pure. Walk up
16067 the procedure list until we find a procedure. */
16068 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16070 sym
= ns
->proc_name
;
16074 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16079 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16080 && !sym
->attr
.pure
;
16085 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16091 /* Check if the current procedure is implicit_pure. Walk up
16092 the procedure list until we find a procedure. */
16093 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16095 sym
= ns
->proc_name
;
16099 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16104 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16105 sym
->attr
.implicit_pure
= 0;
16107 sym
->attr
.pure
= 0;
16111 /* Test whether the current procedure is elemental or not. */
16114 gfc_elemental (gfc_symbol
*sym
)
16116 symbol_attribute attr
;
16119 sym
= gfc_current_ns
->proc_name
;
16124 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16128 /* Warn about unused labels. */
16131 warn_unused_fortran_label (gfc_st_label
*label
)
16136 warn_unused_fortran_label (label
->left
);
16138 if (label
->defined
== ST_LABEL_UNKNOWN
)
16141 switch (label
->referenced
)
16143 case ST_LABEL_UNKNOWN
:
16144 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16145 label
->value
, &label
->where
);
16148 case ST_LABEL_BAD_TARGET
:
16149 gfc_warning (OPT_Wunused_label
,
16150 "Label %d at %L defined but cannot be used",
16151 label
->value
, &label
->where
);
16158 warn_unused_fortran_label (label
->right
);
16162 /* Returns the sequence type of a symbol or sequence. */
16165 sequence_type (gfc_typespec ts
)
16174 if (ts
.u
.derived
->components
== NULL
)
16175 return SEQ_NONDEFAULT
;
16177 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16178 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16179 if (sequence_type (c
->ts
) != result
)
16185 if (ts
.kind
!= gfc_default_character_kind
)
16186 return SEQ_NONDEFAULT
;
16188 return SEQ_CHARACTER
;
16191 if (ts
.kind
!= gfc_default_integer_kind
)
16192 return SEQ_NONDEFAULT
;
16194 return SEQ_NUMERIC
;
16197 if (!(ts
.kind
== gfc_default_real_kind
16198 || ts
.kind
== gfc_default_double_kind
))
16199 return SEQ_NONDEFAULT
;
16201 return SEQ_NUMERIC
;
16204 if (ts
.kind
!= gfc_default_complex_kind
)
16205 return SEQ_NONDEFAULT
;
16207 return SEQ_NUMERIC
;
16210 if (ts
.kind
!= gfc_default_logical_kind
)
16211 return SEQ_NONDEFAULT
;
16213 return SEQ_NUMERIC
;
16216 return SEQ_NONDEFAULT
;
16221 /* Resolve derived type EQUIVALENCE object. */
16224 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16226 gfc_component
*c
= derived
->components
;
16231 /* Shall not be an object of nonsequence derived type. */
16232 if (!derived
->attr
.sequence
)
16234 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16235 "attribute to be an EQUIVALENCE object", sym
->name
,
16240 /* Shall not have allocatable components. */
16241 if (derived
->attr
.alloc_comp
)
16243 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16244 "components to be an EQUIVALENCE object",sym
->name
,
16249 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16251 gfc_error ("Derived type variable %qs at %L with default "
16252 "initialization cannot be in EQUIVALENCE with a variable "
16253 "in COMMON", sym
->name
, &e
->where
);
16257 for (; c
; c
= c
->next
)
16259 if (gfc_bt_struct (c
->ts
.type
)
16260 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16263 /* Shall not be an object of sequence derived type containing a pointer
16264 in the structure. */
16265 if (c
->attr
.pointer
)
16267 gfc_error ("Derived type variable %qs at %L with pointer "
16268 "component(s) cannot be an EQUIVALENCE object",
16269 sym
->name
, &e
->where
);
16277 /* Resolve equivalence object.
16278 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16279 an allocatable array, an object of nonsequence derived type, an object of
16280 sequence derived type containing a pointer at any level of component
16281 selection, an automatic object, a function name, an entry name, a result
16282 name, a named constant, a structure component, or a subobject of any of
16283 the preceding objects. A substring shall not have length zero. A
16284 derived type shall not have components with default initialization nor
16285 shall two objects of an equivalence group be initialized.
16286 Either all or none of the objects shall have an protected attribute.
16287 The simple constraints are done in symbol.c(check_conflict) and the rest
16288 are implemented here. */
16291 resolve_equivalence (gfc_equiv
*eq
)
16294 gfc_symbol
*first_sym
;
16297 locus
*last_where
= NULL
;
16298 seq_type eq_type
, last_eq_type
;
16299 gfc_typespec
*last_ts
;
16300 int object
, cnt_protected
;
16303 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16305 first_sym
= eq
->expr
->symtree
->n
.sym
;
16309 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16313 e
->ts
= e
->symtree
->n
.sym
->ts
;
16314 /* match_varspec might not know yet if it is seeing
16315 array reference or substring reference, as it doesn't
16317 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16319 gfc_ref
*ref
= e
->ref
;
16320 sym
= e
->symtree
->n
.sym
;
16322 if (sym
->attr
.dimension
)
16324 ref
->u
.ar
.as
= sym
->as
;
16328 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16329 if (e
->ts
.type
== BT_CHARACTER
16331 && ref
->type
== REF_ARRAY
16332 && ref
->u
.ar
.dimen
== 1
16333 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16334 && ref
->u
.ar
.stride
[0] == NULL
)
16336 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16337 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16340 /* Optimize away the (:) reference. */
16341 if (start
== NULL
&& end
== NULL
)
16344 e
->ref
= ref
->next
;
16346 e
->ref
->next
= ref
->next
;
16351 ref
->type
= REF_SUBSTRING
;
16353 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16355 ref
->u
.ss
.start
= start
;
16356 if (end
== NULL
&& e
->ts
.u
.cl
)
16357 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16358 ref
->u
.ss
.end
= end
;
16359 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16366 /* Any further ref is an error. */
16369 gcc_assert (ref
->type
== REF_ARRAY
);
16370 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16376 if (!gfc_resolve_expr (e
))
16379 sym
= e
->symtree
->n
.sym
;
16381 if (sym
->attr
.is_protected
)
16383 if (cnt_protected
> 0 && cnt_protected
!= object
)
16385 gfc_error ("Either all or none of the objects in the "
16386 "EQUIVALENCE set at %L shall have the "
16387 "PROTECTED attribute",
16392 /* Shall not equivalence common block variables in a PURE procedure. */
16393 if (sym
->ns
->proc_name
16394 && sym
->ns
->proc_name
->attr
.pure
16395 && sym
->attr
.in_common
)
16397 /* Need to check for symbols that may have entered the pure
16398 procedure via a USE statement. */
16399 bool saw_sym
= false;
16400 if (sym
->ns
->use_stmts
)
16403 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16404 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16410 gfc_error ("COMMON block member %qs at %L cannot be an "
16411 "EQUIVALENCE object in the pure procedure %qs",
16412 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16416 /* Shall not be a named constant. */
16417 if (e
->expr_type
== EXPR_CONSTANT
)
16419 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16420 "object", sym
->name
, &e
->where
);
16424 if (e
->ts
.type
== BT_DERIVED
16425 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16428 /* Check that the types correspond correctly:
16430 A numeric sequence structure may be equivalenced to another sequence
16431 structure, an object of default integer type, default real type, double
16432 precision real type, default logical type such that components of the
16433 structure ultimately only become associated to objects of the same
16434 kind. A character sequence structure may be equivalenced to an object
16435 of default character kind or another character sequence structure.
16436 Other objects may be equivalenced only to objects of the same type and
16437 kind parameters. */
16439 /* Identical types are unconditionally OK. */
16440 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16441 goto identical_types
;
16443 last_eq_type
= sequence_type (*last_ts
);
16444 eq_type
= sequence_type (sym
->ts
);
16446 /* Since the pair of objects is not of the same type, mixed or
16447 non-default sequences can be rejected. */
16449 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16450 "statement at %L with different type objects";
16452 && last_eq_type
== SEQ_MIXED
16453 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16454 || (eq_type
== SEQ_MIXED
16455 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16458 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16459 "statement at %L with objects of different type";
16461 && last_eq_type
== SEQ_NONDEFAULT
16462 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16463 || (eq_type
== SEQ_NONDEFAULT
16464 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16467 msg
="Non-CHARACTER object %qs in default CHARACTER "
16468 "EQUIVALENCE statement at %L";
16469 if (last_eq_type
== SEQ_CHARACTER
16470 && eq_type
!= SEQ_CHARACTER
16471 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16474 msg
="Non-NUMERIC object %qs in default NUMERIC "
16475 "EQUIVALENCE statement at %L";
16476 if (last_eq_type
== SEQ_NUMERIC
16477 && eq_type
!= SEQ_NUMERIC
16478 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16483 last_where
= &e
->where
;
16488 /* Shall not be an automatic array. */
16489 if (e
->ref
->type
== REF_ARRAY
16490 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16492 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16493 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16500 /* Shall not be a structure component. */
16501 if (r
->type
== REF_COMPONENT
)
16503 gfc_error ("Structure component %qs at %L cannot be an "
16504 "EQUIVALENCE object",
16505 r
->u
.c
.component
->name
, &e
->where
);
16509 /* A substring shall not have length zero. */
16510 if (r
->type
== REF_SUBSTRING
)
16512 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16514 gfc_error ("Substring at %L has length zero",
16515 &r
->u
.ss
.start
->where
);
16525 /* Function called by resolve_fntype to flag other symbol used in the
16526 length type parameter specification of function resuls. */
16529 flag_fn_result_spec (gfc_expr
*expr
,
16531 int *f ATTRIBUTE_UNUSED
)
16536 if (expr
->expr_type
== EXPR_VARIABLE
)
16538 s
= expr
->symtree
->n
.sym
;
16539 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16545 gfc_error ("Self reference in character length expression "
16546 "for %qs at %L", sym
->name
, &expr
->where
);
16550 if (!s
->fn_result_spec
16551 && s
->attr
.flavor
== FL_PARAMETER
)
16553 /* Function contained in a module.... */
16554 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16557 s
->fn_result_spec
= 1;
16558 /* Make sure that this symbol is translated as a module
16560 st
= gfc_get_unique_symtree (ns
);
16564 /* ... which is use associated and called. */
16565 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16567 /* External function matched with an interface. */
16570 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16571 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16572 && s
->ns
->proc_name
->attr
.function
))
16573 s
->fn_result_spec
= 1;
16580 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16583 resolve_fntype (gfc_namespace
*ns
)
16585 gfc_entry_list
*el
;
16588 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16591 /* If there are any entries, ns->proc_name is the entry master
16592 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16594 sym
= ns
->entries
->sym
;
16596 sym
= ns
->proc_name
;
16597 if (sym
->result
== sym
16598 && sym
->ts
.type
== BT_UNKNOWN
16599 && !gfc_set_default_type (sym
, 0, NULL
)
16600 && !sym
->attr
.untyped
)
16602 gfc_error ("Function %qs at %L has no IMPLICIT type",
16603 sym
->name
, &sym
->declared_at
);
16604 sym
->attr
.untyped
= 1;
16607 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16608 && !sym
->attr
.contained
16609 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16610 && gfc_check_symbol_access (sym
))
16612 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16613 "%L of PRIVATE type %qs", sym
->name
,
16614 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16618 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16620 if (el
->sym
->result
== el
->sym
16621 && el
->sym
->ts
.type
== BT_UNKNOWN
16622 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16623 && !el
->sym
->attr
.untyped
)
16625 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16626 el
->sym
->name
, &el
->sym
->declared_at
);
16627 el
->sym
->attr
.untyped
= 1;
16631 if (sym
->ts
.type
== BT_CHARACTER
)
16632 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16636 /* 12.3.2.1.1 Defined operators. */
16639 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16641 gfc_formal_arglist
*formal
;
16643 if (!sym
->attr
.function
)
16645 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16646 sym
->name
, &where
);
16650 if (sym
->ts
.type
== BT_CHARACTER
16651 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16652 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16653 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16655 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16656 "character length", sym
->name
, &where
);
16660 formal
= gfc_sym_get_dummy_args (sym
);
16661 if (!formal
|| !formal
->sym
)
16663 gfc_error ("User operator procedure %qs at %L must have at least "
16664 "one argument", sym
->name
, &where
);
16668 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16670 gfc_error ("First argument of operator interface at %L must be "
16671 "INTENT(IN)", &where
);
16675 if (formal
->sym
->attr
.optional
)
16677 gfc_error ("First argument of operator interface at %L cannot be "
16678 "optional", &where
);
16682 formal
= formal
->next
;
16683 if (!formal
|| !formal
->sym
)
16686 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16688 gfc_error ("Second argument of operator interface at %L must be "
16689 "INTENT(IN)", &where
);
16693 if (formal
->sym
->attr
.optional
)
16695 gfc_error ("Second argument of operator interface at %L cannot be "
16696 "optional", &where
);
16702 gfc_error ("Operator interface at %L must have, at most, two "
16703 "arguments", &where
);
16711 gfc_resolve_uops (gfc_symtree
*symtree
)
16713 gfc_interface
*itr
;
16715 if (symtree
== NULL
)
16718 gfc_resolve_uops (symtree
->left
);
16719 gfc_resolve_uops (symtree
->right
);
16721 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16722 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16726 /* Examine all of the expressions associated with a program unit,
16727 assign types to all intermediate expressions, make sure that all
16728 assignments are to compatible types and figure out which names
16729 refer to which functions or subroutines. It doesn't check code
16730 block, which is handled by gfc_resolve_code. */
16733 resolve_types (gfc_namespace
*ns
)
16739 gfc_namespace
* old_ns
= gfc_current_ns
;
16741 if (ns
->types_resolved
)
16744 /* Check that all IMPLICIT types are ok. */
16745 if (!ns
->seen_implicit_none
)
16748 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16749 if (ns
->set_flag
[letter
]
16750 && !resolve_typespec_used (&ns
->default_type
[letter
],
16751 &ns
->implicit_loc
[letter
], NULL
))
16755 gfc_current_ns
= ns
;
16757 resolve_entries (ns
);
16759 resolve_common_vars (&ns
->blank_common
, false);
16760 resolve_common_blocks (ns
->common_root
);
16762 resolve_contained_functions (ns
);
16764 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16765 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16766 resolve_formal_arglist (ns
->proc_name
);
16768 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16770 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16771 resolve_charlen (cl
);
16773 gfc_traverse_ns (ns
, resolve_symbol
);
16775 resolve_fntype (ns
);
16777 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16779 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16780 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16781 "also be PURE", n
->proc_name
->name
,
16782 &n
->proc_name
->declared_at
);
16788 gfc_do_concurrent_flag
= 0;
16789 gfc_check_interfaces (ns
);
16791 gfc_traverse_ns (ns
, resolve_values
);
16793 if (ns
->save_all
|| !flag_automatic
)
16797 for (d
= ns
->data
; d
; d
= d
->next
)
16801 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16803 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16805 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16806 resolve_equivalence (eq
);
16808 /* Warn about unused labels. */
16809 if (warn_unused_label
)
16810 warn_unused_fortran_label (ns
->st_labels
);
16812 gfc_resolve_uops (ns
->uop_root
);
16814 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16816 gfc_resolve_omp_declare_simd (ns
);
16818 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16820 ns
->types_resolved
= 1;
16822 gfc_current_ns
= old_ns
;
16826 /* Call gfc_resolve_code recursively. */
16829 resolve_codes (gfc_namespace
*ns
)
16832 bitmap_obstack old_obstack
;
16834 if (ns
->resolved
== 1)
16837 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16840 gfc_current_ns
= ns
;
16842 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16843 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16846 /* Set to an out of range value. */
16847 current_entry_id
= -1;
16849 old_obstack
= labels_obstack
;
16850 bitmap_obstack_initialize (&labels_obstack
);
16852 gfc_resolve_oacc_declare (ns
);
16853 gfc_resolve_oacc_routines (ns
);
16854 gfc_resolve_omp_local_vars (ns
);
16855 gfc_resolve_code (ns
->code
, ns
);
16857 bitmap_obstack_release (&labels_obstack
);
16858 labels_obstack
= old_obstack
;
16862 /* This function is called after a complete program unit has been compiled.
16863 Its purpose is to examine all of the expressions associated with a program
16864 unit, assign types to all intermediate expressions, make sure that all
16865 assignments are to compatible types and figure out which names refer to
16866 which functions or subroutines. */
16869 gfc_resolve (gfc_namespace
*ns
)
16871 gfc_namespace
*old_ns
;
16872 code_stack
*old_cs_base
;
16873 struct gfc_omp_saved_state old_omp_state
;
16879 old_ns
= gfc_current_ns
;
16880 old_cs_base
= cs_base
;
16882 /* As gfc_resolve can be called during resolution of an OpenMP construct
16883 body, we should clear any state associated to it, so that say NS's
16884 DO loops are not interpreted as OpenMP loops. */
16885 if (!ns
->construct_entities
)
16886 gfc_omp_save_and_clear_state (&old_omp_state
);
16888 resolve_types (ns
);
16889 component_assignment_level
= 0;
16890 resolve_codes (ns
);
16892 gfc_current_ns
= old_ns
;
16893 cs_base
= old_cs_base
;
16896 gfc_run_passes (ns
);
16898 if (!ns
->construct_entities
)
16899 gfc_omp_restore_state (&old_omp_state
);