1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2015 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"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and gfc_resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code
*head
, *current
;
47 struct code_stack
*prev
;
49 /* This bitmap keeps track of the targets valid for a branch from
50 inside this block except for END {IF|SELECT}s of enclosing
52 bitmap reachable_labels
;
56 static code_stack
*cs_base
= NULL
;
59 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
61 static int forall_flag
;
62 int gfc_do_concurrent_flag
;
64 /* True when we are resolving an expression that is an actual argument to
66 static bool actual_arg
= false;
67 /* True when we are resolving an expression that is the first actual argument
69 static bool first_actual_arg
= false;
72 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
74 static int omp_workshare_flag
;
76 /* Nonzero if we are processing a formal arglist. The corresponding function
77 resets the flag each time that it is read. */
78 static int formal_arg_flag
= 0;
80 /* True if we are resolving a specification expression. */
81 static bool specification_expr
= false;
83 /* The id of the last entry seen. */
84 static int current_entry_id
;
86 /* We use bitmaps to determine if a branch target is valid. */
87 static bitmap_obstack labels_obstack
;
89 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
90 static bool inquiry_argument
= false;
94 gfc_is_formal_arg (void)
96 return formal_arg_flag
;
99 /* Is the symbol host associated? */
101 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
103 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
112 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
113 an ABSTRACT derived-type. If where is not NULL, an error message with that
114 locus is printed, optionally using name. */
117 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
119 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
124 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
125 name
, where
, ts
->u
.derived
->name
);
127 gfc_error ("ABSTRACT type %qs used at %L",
128 ts
->u
.derived
->name
, where
);
139 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
141 /* Several checks for F08:C1216. */
142 if (ifc
->attr
.procedure
)
144 gfc_error ("Interface %qs at %L is declared "
145 "in a later PROCEDURE statement", ifc
->name
, where
);
150 /* For generic interfaces, check if there is
151 a specific procedure with the same name. */
152 gfc_interface
*gen
= ifc
->generic
;
153 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
157 gfc_error ("Interface %qs at %L may not be generic",
162 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
164 gfc_error ("Interface %qs at %L may not be a statement function",
168 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
169 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
170 ifc
->attr
.intrinsic
= 1;
171 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
173 gfc_error ("Intrinsic procedure %qs not allowed in "
174 "PROCEDURE statement at %L", ifc
->name
, where
);
177 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
179 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
186 static void resolve_symbol (gfc_symbol
*sym
);
189 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
192 resolve_procedure_interface (gfc_symbol
*sym
)
194 gfc_symbol
*ifc
= sym
->ts
.interface
;
201 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
202 sym
->name
, &sym
->declared_at
);
205 if (!check_proc_interface (ifc
, &sym
->declared_at
))
208 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
210 /* Resolve interface and copy attributes. */
211 resolve_symbol (ifc
);
212 if (ifc
->attr
.intrinsic
)
213 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
217 sym
->ts
= ifc
->result
->ts
;
222 sym
->ts
.interface
= ifc
;
223 sym
->attr
.function
= ifc
->attr
.function
;
224 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
226 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
227 sym
->attr
.pointer
= ifc
->attr
.pointer
;
228 sym
->attr
.pure
= ifc
->attr
.pure
;
229 sym
->attr
.elemental
= ifc
->attr
.elemental
;
230 sym
->attr
.dimension
= ifc
->attr
.dimension
;
231 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
232 sym
->attr
.recursive
= ifc
->attr
.recursive
;
233 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
234 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
235 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
236 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
237 /* Copy array spec. */
238 sym
->as
= gfc_copy_array_spec (ifc
->as
);
239 /* Copy char length. */
240 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
242 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
243 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
244 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
253 /* Resolve types of formal argument lists. These have to be done early so that
254 the formal argument lists of module procedures can be copied to the
255 containing module before the individual procedures are resolved
256 individually. We also resolve argument lists of procedures in interface
257 blocks because they are self-contained scoping units.
259 Since a dummy argument cannot be a non-dummy procedure, the only
260 resort left for untyped names are the IMPLICIT types. */
263 resolve_formal_arglist (gfc_symbol
*proc
)
265 gfc_formal_arglist
*f
;
267 bool saved_specification_expr
;
270 if (proc
->result
!= NULL
)
275 if (gfc_elemental (proc
)
276 || sym
->attr
.pointer
|| sym
->attr
.allocatable
277 || (sym
->as
&& sym
->as
->rank
!= 0))
279 proc
->attr
.always_explicit
= 1;
280 sym
->attr
.always_explicit
= 1;
285 for (f
= proc
->formal
; f
; f
= f
->next
)
293 /* Alternate return placeholder. */
294 if (gfc_elemental (proc
))
295 gfc_error ("Alternate return specifier in elemental subroutine "
296 "%qs at %L is not allowed", proc
->name
,
298 if (proc
->attr
.function
)
299 gfc_error ("Alternate return specifier in function "
300 "%qs at %L is not allowed", proc
->name
,
304 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
305 && !resolve_procedure_interface (sym
))
308 if (strcmp (proc
->name
, sym
->name
) == 0)
310 gfc_error ("Self-referential argument "
311 "%qs at %L is not allowed", sym
->name
,
316 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
317 resolve_formal_arglist (sym
);
319 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
321 if (sym
->attr
.flavor
== FL_UNKNOWN
)
322 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
326 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
327 && (!sym
->attr
.function
|| sym
->result
== sym
))
328 gfc_set_default_type (sym
, 1, sym
->ns
);
331 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
332 ? CLASS_DATA (sym
)->as
: sym
->as
;
334 saved_specification_expr
= specification_expr
;
335 specification_expr
= true;
336 gfc_resolve_array_spec (as
, 0);
337 specification_expr
= saved_specification_expr
;
339 /* We can't tell if an array with dimension (:) is assumed or deferred
340 shape until we know if it has the pointer or allocatable attributes.
342 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
343 && ((sym
->ts
.type
!= BT_CLASS
344 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
345 || (sym
->ts
.type
== BT_CLASS
346 && !(CLASS_DATA (sym
)->attr
.class_pointer
347 || CLASS_DATA (sym
)->attr
.allocatable
)))
348 && sym
->attr
.flavor
!= FL_PROCEDURE
)
350 as
->type
= AS_ASSUMED_SHAPE
;
351 for (i
= 0; i
< as
->rank
; i
++)
352 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
355 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
356 || (as
&& as
->type
== AS_ASSUMED_RANK
)
357 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
358 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
359 && (CLASS_DATA (sym
)->attr
.class_pointer
360 || CLASS_DATA (sym
)->attr
.allocatable
361 || CLASS_DATA (sym
)->attr
.target
))
362 || sym
->attr
.optional
)
364 proc
->attr
.always_explicit
= 1;
366 proc
->result
->attr
.always_explicit
= 1;
369 /* If the flavor is unknown at this point, it has to be a variable.
370 A procedure specification would have already set the type. */
372 if (sym
->attr
.flavor
== FL_UNKNOWN
)
373 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
377 if (sym
->attr
.flavor
== FL_PROCEDURE
)
382 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
383 "also be PURE", sym
->name
, &sym
->declared_at
);
387 else if (!sym
->attr
.pointer
)
389 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
392 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
393 " of pure function %qs at %L with VALUE "
394 "attribute but without INTENT(IN)",
395 sym
->name
, proc
->name
, &sym
->declared_at
);
397 gfc_error ("Argument %qs of pure function %qs at %L must "
398 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
402 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
405 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
406 " of pure subroutine %qs at %L with VALUE "
407 "attribute but without INTENT", sym
->name
,
408 proc
->name
, &sym
->declared_at
);
410 gfc_error ("Argument %qs of pure subroutine %qs at %L "
411 "must have its INTENT specified or have the "
412 "VALUE attribute", sym
->name
, proc
->name
,
418 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
420 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
421 " may not be polymorphic", sym
->name
, proc
->name
,
427 if (proc
->attr
.implicit_pure
)
429 if (sym
->attr
.flavor
== FL_PROCEDURE
)
432 proc
->attr
.implicit_pure
= 0;
434 else if (!sym
->attr
.pointer
)
436 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
438 proc
->attr
.implicit_pure
= 0;
440 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
442 proc
->attr
.implicit_pure
= 0;
446 if (gfc_elemental (proc
))
449 if (sym
->attr
.codimension
450 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
451 && CLASS_DATA (sym
)->attr
.codimension
))
453 gfc_error ("Coarray dummy argument %qs at %L to elemental "
454 "procedure", sym
->name
, &sym
->declared_at
);
458 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
459 && CLASS_DATA (sym
)->as
))
461 gfc_error ("Argument %qs of elemental procedure at %L must "
462 "be scalar", sym
->name
, &sym
->declared_at
);
466 if (sym
->attr
.allocatable
467 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
468 && CLASS_DATA (sym
)->attr
.allocatable
))
470 gfc_error ("Argument %qs of elemental procedure at %L cannot "
471 "have the ALLOCATABLE attribute", sym
->name
,
476 if (sym
->attr
.pointer
477 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
478 && CLASS_DATA (sym
)->attr
.class_pointer
))
480 gfc_error ("Argument %qs of elemental procedure at %L cannot "
481 "have the POINTER attribute", sym
->name
,
486 if (sym
->attr
.flavor
== FL_PROCEDURE
)
488 gfc_error ("Dummy procedure %qs not allowed in elemental "
489 "procedure %qs at %L", sym
->name
, proc
->name
,
494 /* Fortran 2008 Corrigendum 1, C1290a. */
495 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
497 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
498 "have its INTENT specified or have the VALUE "
499 "attribute", sym
->name
, proc
->name
,
505 /* Each dummy shall be specified to be scalar. */
506 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
510 gfc_error ("Argument %qs of statement function at %L must "
511 "be scalar", sym
->name
, &sym
->declared_at
);
515 if (sym
->ts
.type
== BT_CHARACTER
)
517 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
518 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
520 gfc_error ("Character-valued argument %qs of statement "
521 "function at %L must have constant length",
522 sym
->name
, &sym
->declared_at
);
532 /* Work function called when searching for symbols that have argument lists
533 associated with them. */
536 find_arglists (gfc_symbol
*sym
)
538 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
539 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
542 resolve_formal_arglist (sym
);
546 /* Given a namespace, resolve all formal argument lists within the namespace.
550 resolve_formal_arglists (gfc_namespace
*ns
)
555 gfc_traverse_ns (ns
, find_arglists
);
560 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
564 /* If this namespace is not a function or an entry master function,
566 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
567 || sym
->attr
.entry_master
)
570 /* Try to find out of what the return type is. */
571 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
573 t
= gfc_set_default_type (sym
->result
, 0, ns
);
575 if (!t
&& !sym
->result
->attr
.untyped
)
577 if (sym
->result
== sym
)
578 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
579 sym
->name
, &sym
->declared_at
);
580 else if (!sym
->result
->attr
.proc_pointer
)
581 gfc_error ("Result %qs of contained function %qs at %L has "
582 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
583 &sym
->result
->declared_at
);
584 sym
->result
->attr
.untyped
= 1;
588 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
589 type, lists the only ways a character length value of * can be used:
590 dummy arguments of procedures, named constants, and function results
591 in external functions. Internal function results and results of module
592 procedures are not on this list, ergo, not permitted. */
594 if (sym
->result
->ts
.type
== BT_CHARACTER
)
596 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
597 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
599 /* See if this is a module-procedure and adapt error message
602 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
603 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
605 gfc_error ("Character-valued %s %qs at %L must not be"
607 module_proc
? _("module procedure")
608 : _("internal function"),
609 sym
->name
, &sym
->declared_at
);
615 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
616 introduce duplicates. */
619 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
621 gfc_formal_arglist
*f
, *new_arglist
;
624 for (; new_args
!= NULL
; new_args
= new_args
->next
)
626 new_sym
= new_args
->sym
;
627 /* See if this arg is already in the formal argument list. */
628 for (f
= proc
->formal
; f
; f
= f
->next
)
630 if (new_sym
== f
->sym
)
637 /* Add a new argument. Argument order is not important. */
638 new_arglist
= gfc_get_formal_arglist ();
639 new_arglist
->sym
= new_sym
;
640 new_arglist
->next
= proc
->formal
;
641 proc
->formal
= new_arglist
;
646 /* Flag the arguments that are not present in all entries. */
649 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
651 gfc_formal_arglist
*f
, *head
;
654 for (f
= proc
->formal
; f
; f
= f
->next
)
659 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
661 if (new_args
->sym
== f
->sym
)
668 f
->sym
->attr
.not_always_present
= 1;
673 /* Resolve alternate entry points. If a symbol has multiple entry points we
674 create a new master symbol for the main routine, and turn the existing
675 symbol into an entry point. */
678 resolve_entries (gfc_namespace
*ns
)
680 gfc_namespace
*old_ns
;
684 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
685 static int master_count
= 0;
687 if (ns
->proc_name
== NULL
)
690 /* No need to do anything if this procedure doesn't have alternate entry
695 /* We may already have resolved alternate entry points. */
696 if (ns
->proc_name
->attr
.entry_master
)
699 /* If this isn't a procedure something has gone horribly wrong. */
700 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
702 /* Remember the current namespace. */
703 old_ns
= gfc_current_ns
;
707 /* Add the main entry point to the list of entry points. */
708 el
= gfc_get_entry_list ();
709 el
->sym
= ns
->proc_name
;
711 el
->next
= ns
->entries
;
713 ns
->proc_name
->attr
.entry
= 1;
715 /* If it is a module function, it needs to be in the right namespace
716 so that gfc_get_fake_result_decl can gather up the results. The
717 need for this arose in get_proc_name, where these beasts were
718 left in their own namespace, to keep prior references linked to
719 the entry declaration.*/
720 if (ns
->proc_name
->attr
.function
721 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
724 /* Do the same for entries where the master is not a module
725 procedure. These are retained in the module namespace because
726 of the module procedure declaration. */
727 for (el
= el
->next
; el
; el
= el
->next
)
728 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
729 && el
->sym
->attr
.mod_proc
)
733 /* Add an entry statement for it. */
734 c
= gfc_get_code (EXEC_ENTRY
);
739 /* Create a new symbol for the master function. */
740 /* Give the internal function a unique name (within this file).
741 Also include the function name so the user has some hope of figuring
742 out what is going on. */
743 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
744 master_count
++, ns
->proc_name
->name
);
745 gfc_get_ha_symbol (name
, &proc
);
746 gcc_assert (proc
!= NULL
);
748 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
749 if (ns
->proc_name
->attr
.subroutine
)
750 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
754 gfc_typespec
*ts
, *fts
;
755 gfc_array_spec
*as
, *fas
;
756 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
758 fas
= ns
->entries
->sym
->as
;
759 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
760 fts
= &ns
->entries
->sym
->result
->ts
;
761 if (fts
->type
== BT_UNKNOWN
)
762 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
763 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
765 ts
= &el
->sym
->result
->ts
;
767 as
= as
? as
: el
->sym
->result
->as
;
768 if (ts
->type
== BT_UNKNOWN
)
769 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
771 if (! gfc_compare_types (ts
, fts
)
772 || (el
->sym
->result
->attr
.dimension
773 != ns
->entries
->sym
->result
->attr
.dimension
)
774 || (el
->sym
->result
->attr
.pointer
775 != ns
->entries
->sym
->result
->attr
.pointer
))
777 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
778 && gfc_compare_array_spec (as
, fas
) == 0)
779 gfc_error ("Function %s at %L has entries with mismatched "
780 "array specifications", ns
->entries
->sym
->name
,
781 &ns
->entries
->sym
->declared_at
);
782 /* The characteristics need to match and thus both need to have
783 the same string length, i.e. both len=*, or both len=4.
784 Having both len=<variable> is also possible, but difficult to
785 check at compile time. */
786 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
787 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
788 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
790 && ts
->u
.cl
->length
->expr_type
791 != fts
->u
.cl
->length
->expr_type
)
793 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
794 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
795 fts
->u
.cl
->length
->value
.integer
) != 0)))
796 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
797 "entries returning variables of different "
798 "string lengths", ns
->entries
->sym
->name
,
799 &ns
->entries
->sym
->declared_at
);
804 sym
= ns
->entries
->sym
->result
;
805 /* All result types the same. */
807 if (sym
->attr
.dimension
)
808 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
809 if (sym
->attr
.pointer
)
810 gfc_add_pointer (&proc
->attr
, NULL
);
814 /* Otherwise the result will be passed through a union by
816 proc
->attr
.mixed_entry_master
= 1;
817 for (el
= ns
->entries
; el
; el
= el
->next
)
819 sym
= el
->sym
->result
;
820 if (sym
->attr
.dimension
)
822 if (el
== ns
->entries
)
823 gfc_error ("FUNCTION result %s can't be an array in "
824 "FUNCTION %s at %L", sym
->name
,
825 ns
->entries
->sym
->name
, &sym
->declared_at
);
827 gfc_error ("ENTRY result %s can't be an array in "
828 "FUNCTION %s at %L", sym
->name
,
829 ns
->entries
->sym
->name
, &sym
->declared_at
);
831 else if (sym
->attr
.pointer
)
833 if (el
== ns
->entries
)
834 gfc_error ("FUNCTION result %s can't be a POINTER in "
835 "FUNCTION %s at %L", sym
->name
,
836 ns
->entries
->sym
->name
, &sym
->declared_at
);
838 gfc_error ("ENTRY result %s can't be a POINTER in "
839 "FUNCTION %s at %L", sym
->name
,
840 ns
->entries
->sym
->name
, &sym
->declared_at
);
845 if (ts
->type
== BT_UNKNOWN
)
846 ts
= gfc_get_default_type (sym
->name
, NULL
);
850 if (ts
->kind
== gfc_default_integer_kind
)
854 if (ts
->kind
== gfc_default_real_kind
855 || ts
->kind
== gfc_default_double_kind
)
859 if (ts
->kind
== gfc_default_complex_kind
)
863 if (ts
->kind
== gfc_default_logical_kind
)
867 /* We will issue error elsewhere. */
875 if (el
== ns
->entries
)
876 gfc_error ("FUNCTION result %s can't be of type %s "
877 "in FUNCTION %s at %L", sym
->name
,
878 gfc_typename (ts
), ns
->entries
->sym
->name
,
881 gfc_error ("ENTRY result %s can't be of type %s "
882 "in FUNCTION %s at %L", sym
->name
,
883 gfc_typename (ts
), ns
->entries
->sym
->name
,
890 proc
->attr
.access
= ACCESS_PRIVATE
;
891 proc
->attr
.entry_master
= 1;
893 /* Merge all the entry point arguments. */
894 for (el
= ns
->entries
; el
; el
= el
->next
)
895 merge_argument_lists (proc
, el
->sym
->formal
);
897 /* Check the master formal arguments for any that are not
898 present in all entry points. */
899 for (el
= ns
->entries
; el
; el
= el
->next
)
900 check_argument_lists (proc
, el
->sym
->formal
);
902 /* Use the master function for the function body. */
903 ns
->proc_name
= proc
;
905 /* Finalize the new symbols. */
906 gfc_commit_symbols ();
908 /* Restore the original namespace. */
909 gfc_current_ns
= old_ns
;
913 /* Resolve common variables. */
915 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
917 gfc_symbol
*csym
= sym
;
919 for (; csym
; csym
= csym
->common_next
)
921 if (csym
->value
|| csym
->attr
.data
)
923 if (!csym
->ns
->is_block_data
)
924 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
925 "but only in BLOCK DATA initialization is "
926 "allowed", csym
->name
, &csym
->declared_at
);
927 else if (!named_common
)
928 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
929 "in a blank COMMON but initialization is only "
930 "allowed in named common blocks", csym
->name
,
934 if (UNLIMITED_POLY (csym
))
935 gfc_error_now ("%qs in cannot appear in COMMON at %L "
936 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
938 if (csym
->ts
.type
!= BT_DERIVED
)
941 if (!(csym
->ts
.u
.derived
->attr
.sequence
942 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
943 gfc_error_now ("Derived type variable %qs in COMMON at %L "
944 "has neither the SEQUENCE nor the BIND(C) "
945 "attribute", csym
->name
, &csym
->declared_at
);
946 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
947 gfc_error_now ("Derived type variable %qs in COMMON at %L "
948 "has an ultimate component that is "
949 "allocatable", csym
->name
, &csym
->declared_at
);
950 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
951 gfc_error_now ("Derived type variable %qs in COMMON at %L "
952 "may not have default initializer", csym
->name
,
955 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
956 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
960 /* Resolve common blocks. */
962 resolve_common_blocks (gfc_symtree
*common_root
)
967 if (common_root
== NULL
)
970 if (common_root
->left
)
971 resolve_common_blocks (common_root
->left
);
972 if (common_root
->right
)
973 resolve_common_blocks (common_root
->right
);
975 resolve_common_vars (common_root
->n
.common
->head
, true);
977 /* The common name is a global name - in Fortran 2003 also if it has a
978 C binding name, since Fortran 2008 only the C binding name is a global
980 if (!common_root
->n
.common
->binding_label
981 || gfc_notification_std (GFC_STD_F2008
))
983 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
984 common_root
->n
.common
->name
);
986 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
987 && gsym
->type
== GSYM_COMMON
988 && ((common_root
->n
.common
->binding_label
989 && (!gsym
->binding_label
990 || strcmp (common_root
->n
.common
->binding_label
,
991 gsym
->binding_label
) != 0))
992 || (!common_root
->n
.common
->binding_label
993 && gsym
->binding_label
)))
995 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
996 "identifier and must thus have the same binding name "
997 "as the same-named COMMON block at %L: %s vs %s",
998 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1000 common_root
->n
.common
->binding_label
1001 ? common_root
->n
.common
->binding_label
: "(blank)",
1002 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1006 if (gsym
&& gsym
->type
!= GSYM_COMMON
1007 && !common_root
->n
.common
->binding_label
)
1009 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1011 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1015 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1017 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1018 "%L sharing the identifier with global non-COMMON-block "
1019 "entity at %L", common_root
->n
.common
->name
,
1020 &common_root
->n
.common
->where
, &gsym
->where
);
1025 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1026 gsym
->type
= GSYM_COMMON
;
1027 gsym
->where
= common_root
->n
.common
->where
;
1033 if (common_root
->n
.common
->binding_label
)
1035 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1036 common_root
->n
.common
->binding_label
);
1037 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1039 gfc_error ("COMMON block at %L with binding label %s uses the same "
1040 "global identifier as entity at %L",
1041 &common_root
->n
.common
->where
,
1042 common_root
->n
.common
->binding_label
, &gsym
->where
);
1047 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1048 gsym
->type
= GSYM_COMMON
;
1049 gsym
->where
= common_root
->n
.common
->where
;
1055 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1059 if (sym
->attr
.flavor
== FL_PARAMETER
)
1060 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1061 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1063 if (sym
->attr
.external
)
1064 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1065 sym
->name
, &common_root
->n
.common
->where
);
1067 if (sym
->attr
.intrinsic
)
1068 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1069 sym
->name
, &common_root
->n
.common
->where
);
1070 else if (sym
->attr
.result
1071 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1072 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1073 "that is also a function result", sym
->name
,
1074 &common_root
->n
.common
->where
);
1075 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1076 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1077 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1078 "that is also a global procedure", sym
->name
,
1079 &common_root
->n
.common
->where
);
1083 /* Resolve contained function types. Because contained functions can call one
1084 another, they have to be worked out before any of the contained procedures
1087 The good news is that if a function doesn't already have a type, the only
1088 way it can get one is through an IMPLICIT type or a RESULT variable, because
1089 by definition contained functions are contained namespace they're contained
1090 in, not in a sibling or parent namespace. */
1093 resolve_contained_functions (gfc_namespace
*ns
)
1095 gfc_namespace
*child
;
1098 resolve_formal_arglists (ns
);
1100 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1102 /* Resolve alternate entry points first. */
1103 resolve_entries (child
);
1105 /* Then check function return types. */
1106 resolve_contained_fntype (child
->proc_name
, child
);
1107 for (el
= child
->entries
; el
; el
= el
->next
)
1108 resolve_contained_fntype (el
->sym
, child
);
1113 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1116 /* Resolve all of the elements of a structure constructor and make sure that
1117 the types are correct. The 'init' flag indicates that the given
1118 constructor is an initializer. */
1121 resolve_structure_cons (gfc_expr
*expr
, int init
)
1123 gfc_constructor
*cons
;
1124 gfc_component
*comp
;
1130 if (expr
->ts
.type
== BT_DERIVED
)
1131 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1133 cons
= gfc_constructor_first (expr
->value
.constructor
);
1135 /* A constructor may have references if it is the result of substituting a
1136 parameter variable. In this case we just pull out the component we
1139 comp
= expr
->ref
->u
.c
.sym
->components
;
1141 comp
= expr
->ts
.u
.derived
->components
;
1143 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1150 if (!gfc_resolve_expr (cons
->expr
))
1156 rank
= comp
->as
? comp
->as
->rank
: 0;
1157 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1158 rank
= CLASS_DATA (comp
)->as
->rank
;
1160 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1161 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1163 gfc_error ("The rank of the element in the structure "
1164 "constructor at %L does not match that of the "
1165 "component (%d/%d)", &cons
->expr
->where
,
1166 cons
->expr
->rank
, rank
);
1170 /* If we don't have the right type, try to convert it. */
1172 if (!comp
->attr
.proc_pointer
&&
1173 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1175 if (strcmp (comp
->name
, "_extends") == 0)
1177 /* Can afford to be brutal with the _extends initializer.
1178 The derived type can get lost because it is PRIVATE
1179 but it is not usage constrained by the standard. */
1180 cons
->expr
->ts
= comp
->ts
;
1182 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1184 gfc_error ("The element in the structure constructor at %L, "
1185 "for pointer component %qs, is %s but should be %s",
1186 &cons
->expr
->where
, comp
->name
,
1187 gfc_basic_typename (cons
->expr
->ts
.type
),
1188 gfc_basic_typename (comp
->ts
.type
));
1193 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1199 /* For strings, the length of the constructor should be the same as
1200 the one of the structure, ensure this if the lengths are known at
1201 compile time and when we are dealing with PARAMETER or structure
1203 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1204 && comp
->ts
.u
.cl
->length
1205 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1206 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1207 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1208 && cons
->expr
->rank
!= 0
1209 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1210 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1212 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1213 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1215 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1216 to make use of the gfc_resolve_character_array_constructor
1217 machinery. The expression is later simplified away to
1218 an array of string literals. */
1219 gfc_expr
*para
= cons
->expr
;
1220 cons
->expr
= gfc_get_expr ();
1221 cons
->expr
->ts
= para
->ts
;
1222 cons
->expr
->where
= para
->where
;
1223 cons
->expr
->expr_type
= EXPR_ARRAY
;
1224 cons
->expr
->rank
= para
->rank
;
1225 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1226 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1227 para
, &cons
->expr
->where
);
1229 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1232 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1233 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1235 gfc_charlen
*cl
, *cl2
;
1238 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1240 if (cl
== cons
->expr
->ts
.u
.cl
)
1248 cl2
->next
= cl
->next
;
1250 gfc_free_expr (cl
->length
);
1254 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1255 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1256 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1257 gfc_resolve_character_array_constructor (cons
->expr
);
1261 if (cons
->expr
->expr_type
== EXPR_NULL
1262 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1263 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1264 || (comp
->ts
.type
== BT_CLASS
1265 && (CLASS_DATA (comp
)->attr
.class_pointer
1266 || CLASS_DATA (comp
)->attr
.allocatable
))))
1269 gfc_error ("The NULL in the structure constructor at %L is "
1270 "being applied to component %qs, which is neither "
1271 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1275 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1277 /* Check procedure pointer interface. */
1278 gfc_symbol
*s2
= NULL
;
1283 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1286 s2
= c2
->ts
.interface
;
1289 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1291 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1292 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1294 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1296 s2
= cons
->expr
->symtree
->n
.sym
;
1297 name
= cons
->expr
->symtree
->n
.sym
->name
;
1300 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1301 err
, sizeof (err
), NULL
, NULL
))
1303 gfc_error ("Interface mismatch for procedure-pointer component "
1304 "%qs in structure constructor at %L: %s",
1305 comp
->name
, &cons
->expr
->where
, err
);
1310 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1311 || cons
->expr
->expr_type
== EXPR_NULL
)
1314 a
= gfc_expr_attr (cons
->expr
);
1316 if (!a
.pointer
&& !a
.target
)
1319 gfc_error ("The element in the structure constructor at %L, "
1320 "for pointer component %qs should be a POINTER or "
1321 "a TARGET", &cons
->expr
->where
, comp
->name
);
1326 /* F08:C461. Additional checks for pointer initialization. */
1330 gfc_error ("Pointer initialization target at %L "
1331 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1336 gfc_error ("Pointer initialization target at %L "
1337 "must have the SAVE attribute", &cons
->expr
->where
);
1341 /* F2003, C1272 (3). */
1342 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1343 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1344 || gfc_is_coindexed (cons
->expr
));
1345 if (impure
&& gfc_pure (NULL
))
1348 gfc_error ("Invalid expression in the structure constructor for "
1349 "pointer component %qs at %L in PURE procedure",
1350 comp
->name
, &cons
->expr
->where
);
1354 gfc_unset_implicit_pure (NULL
);
1361 /****************** Expression name resolution ******************/
1363 /* Returns 0 if a symbol was not declared with a type or
1364 attribute declaration statement, nonzero otherwise. */
1367 was_declared (gfc_symbol
*sym
)
1373 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1376 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1377 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1378 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1379 || a
.asynchronous
|| a
.codimension
)
1386 /* Determine if a symbol is generic or not. */
1389 generic_sym (gfc_symbol
*sym
)
1393 if (sym
->attr
.generic
||
1394 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1397 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1400 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1407 return generic_sym (s
);
1414 /* Determine if a symbol is specific or not. */
1417 specific_sym (gfc_symbol
*sym
)
1421 if (sym
->attr
.if_source
== IFSRC_IFBODY
1422 || sym
->attr
.proc
== PROC_MODULE
1423 || sym
->attr
.proc
== PROC_INTERNAL
1424 || sym
->attr
.proc
== PROC_ST_FUNCTION
1425 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1426 || sym
->attr
.external
)
1429 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1432 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1434 return (s
== NULL
) ? 0 : specific_sym (s
);
1438 /* Figure out if the procedure is specific, generic or unknown. */
1441 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1444 procedure_kind (gfc_symbol
*sym
)
1446 if (generic_sym (sym
))
1447 return PTYPE_GENERIC
;
1449 if (specific_sym (sym
))
1450 return PTYPE_SPECIFIC
;
1452 return PTYPE_UNKNOWN
;
1455 /* Check references to assumed size arrays. The flag need_full_assumed_size
1456 is nonzero when matching actual arguments. */
1458 static int need_full_assumed_size
= 0;
1461 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1463 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1466 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1467 What should it be? */
1468 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1469 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1470 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1472 gfc_error ("The upper bound in the last dimension must "
1473 "appear in the reference to the assumed size "
1474 "array %qs at %L", sym
->name
, &e
->where
);
1481 /* Look for bad assumed size array references in argument expressions
1482 of elemental and array valued intrinsic procedures. Since this is
1483 called from procedure resolution functions, it only recurses at
1487 resolve_assumed_size_actual (gfc_expr
*e
)
1492 switch (e
->expr_type
)
1495 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1500 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1501 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1512 /* Check a generic procedure, passed as an actual argument, to see if
1513 there is a matching specific name. If none, it is an error, and if
1514 more than one, the reference is ambiguous. */
1516 count_specific_procs (gfc_expr
*e
)
1523 sym
= e
->symtree
->n
.sym
;
1525 for (p
= sym
->generic
; p
; p
= p
->next
)
1526 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1528 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1534 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1538 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1539 "argument at %L", sym
->name
, &e
->where
);
1545 /* See if a call to sym could possibly be a not allowed RECURSION because of
1546 a missing RECURSIVE declaration. This means that either sym is the current
1547 context itself, or sym is the parent of a contained procedure calling its
1548 non-RECURSIVE containing procedure.
1549 This also works if sym is an ENTRY. */
1552 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1554 gfc_symbol
* proc_sym
;
1555 gfc_symbol
* context_proc
;
1556 gfc_namespace
* real_context
;
1558 if (sym
->attr
.flavor
== FL_PROGRAM
1559 || sym
->attr
.flavor
== FL_DERIVED
)
1562 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1564 /* If we've got an ENTRY, find real procedure. */
1565 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1566 proc_sym
= sym
->ns
->entries
->sym
;
1570 /* If sym is RECURSIVE, all is well of course. */
1571 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1574 /* Find the context procedure's "real" symbol if it has entries.
1575 We look for a procedure symbol, so recurse on the parents if we don't
1576 find one (like in case of a BLOCK construct). */
1577 for (real_context
= context
; ; real_context
= real_context
->parent
)
1579 /* We should find something, eventually! */
1580 gcc_assert (real_context
);
1582 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1583 : real_context
->proc_name
);
1585 /* In some special cases, there may not be a proc_name, like for this
1587 real(bad_kind()) function foo () ...
1588 when checking the call to bad_kind ().
1589 In these cases, we simply return here and assume that the
1594 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1598 /* A call from sym's body to itself is recursion, of course. */
1599 if (context_proc
== proc_sym
)
1602 /* The same is true if context is a contained procedure and sym the
1604 if (context_proc
->attr
.contained
)
1606 gfc_symbol
* parent_proc
;
1608 gcc_assert (context
->parent
);
1609 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1610 : context
->parent
->proc_name
);
1612 if (parent_proc
== proc_sym
)
1620 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1621 its typespec and formal argument list. */
1624 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1626 gfc_intrinsic_sym
* isym
= NULL
;
1632 /* Already resolved. */
1633 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1636 /* We already know this one is an intrinsic, so we don't call
1637 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1638 gfc_find_subroutine directly to check whether it is a function or
1641 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1643 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1644 isym
= gfc_intrinsic_subroutine_by_id (id
);
1646 else if (sym
->intmod_sym_id
)
1648 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1649 isym
= gfc_intrinsic_function_by_id (id
);
1651 else if (!sym
->attr
.subroutine
)
1652 isym
= gfc_find_function (sym
->name
);
1654 if (isym
&& !sym
->attr
.subroutine
)
1656 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1657 && !sym
->attr
.implicit_type
)
1658 gfc_warning (OPT_Wsurprising
,
1659 "Type specified for intrinsic function %qs at %L is"
1660 " ignored", sym
->name
, &sym
->declared_at
);
1662 if (!sym
->attr
.function
&&
1663 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1668 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1670 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1672 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1673 " specifier", sym
->name
, &sym
->declared_at
);
1677 if (!sym
->attr
.subroutine
&&
1678 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1683 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1688 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1690 sym
->attr
.pure
= isym
->pure
;
1691 sym
->attr
.elemental
= isym
->elemental
;
1693 /* Check it is actually available in the standard settings. */
1694 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1696 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1697 "available in the current standard settings but %s. Use "
1698 "an appropriate %<-std=*%> option or enable "
1699 "%<-fall-intrinsics%> in order to use it.",
1700 sym
->name
, &sym
->declared_at
, symstd
);
1708 /* Resolve a procedure expression, like passing it to a called procedure or as
1709 RHS for a procedure pointer assignment. */
1712 resolve_procedure_expression (gfc_expr
* expr
)
1716 if (expr
->expr_type
!= EXPR_VARIABLE
)
1718 gcc_assert (expr
->symtree
);
1720 sym
= expr
->symtree
->n
.sym
;
1722 if (sym
->attr
.intrinsic
)
1723 gfc_resolve_intrinsic (sym
, &expr
->where
);
1725 if (sym
->attr
.flavor
!= FL_PROCEDURE
1726 || (sym
->attr
.function
&& sym
->result
== sym
))
1729 /* A non-RECURSIVE procedure that is used as procedure expression within its
1730 own body is in danger of being called recursively. */
1731 if (is_illegal_recursion (sym
, gfc_current_ns
))
1732 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1733 " itself recursively. Declare it RECURSIVE or use"
1734 " %<-frecursive%>", sym
->name
, &expr
->where
);
1740 /* Resolve an actual argument list. Most of the time, this is just
1741 resolving the expressions in the list.
1742 The exception is that we sometimes have to decide whether arguments
1743 that look like procedure arguments are really simple variable
1747 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1748 bool no_formal_args
)
1751 gfc_symtree
*parent_st
;
1753 gfc_component
*comp
;
1754 int save_need_full_assumed_size
;
1755 bool return_value
= false;
1756 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1759 first_actual_arg
= true;
1761 for (; arg
; arg
= arg
->next
)
1766 /* Check the label is a valid branching target. */
1769 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1771 gfc_error ("Label %d referenced at %L is never defined",
1772 arg
->label
->value
, &arg
->label
->where
);
1776 first_actual_arg
= false;
1780 if (e
->expr_type
== EXPR_VARIABLE
1781 && e
->symtree
->n
.sym
->attr
.generic
1783 && count_specific_procs (e
) != 1)
1786 if (e
->ts
.type
!= BT_PROCEDURE
)
1788 save_need_full_assumed_size
= need_full_assumed_size
;
1789 if (e
->expr_type
!= EXPR_VARIABLE
)
1790 need_full_assumed_size
= 0;
1791 if (!gfc_resolve_expr (e
))
1793 need_full_assumed_size
= save_need_full_assumed_size
;
1797 /* See if the expression node should really be a variable reference. */
1799 sym
= e
->symtree
->n
.sym
;
1801 if (sym
->attr
.flavor
== FL_PROCEDURE
1802 || sym
->attr
.intrinsic
1803 || sym
->attr
.external
)
1807 /* If a procedure is not already determined to be something else
1808 check if it is intrinsic. */
1809 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1810 sym
->attr
.intrinsic
= 1;
1812 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1814 gfc_error ("Statement function %qs at %L is not allowed as an "
1815 "actual argument", sym
->name
, &e
->where
);
1818 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1819 sym
->attr
.subroutine
);
1820 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1822 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1823 "actual argument", sym
->name
, &e
->where
);
1826 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1827 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1829 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1830 " used as actual argument at %L",
1831 sym
->name
, &e
->where
))
1835 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1837 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1838 "allowed as an actual argument at %L", sym
->name
,
1842 /* Check if a generic interface has a specific procedure
1843 with the same name before emitting an error. */
1844 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1847 /* Just in case a specific was found for the expression. */
1848 sym
= e
->symtree
->n
.sym
;
1850 /* If the symbol is the function that names the current (or
1851 parent) scope, then we really have a variable reference. */
1853 if (gfc_is_function_return_value (sym
, sym
->ns
))
1856 /* If all else fails, see if we have a specific intrinsic. */
1857 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1859 gfc_intrinsic_sym
*isym
;
1861 isym
= gfc_find_function (sym
->name
);
1862 if (isym
== NULL
|| !isym
->specific
)
1864 gfc_error ("Unable to find a specific INTRINSIC procedure "
1865 "for the reference %qs at %L", sym
->name
,
1870 sym
->attr
.intrinsic
= 1;
1871 sym
->attr
.function
= 1;
1874 if (!gfc_resolve_expr (e
))
1879 /* See if the name is a module procedure in a parent unit. */
1881 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1884 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1886 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1890 if (parent_st
== NULL
)
1893 sym
= parent_st
->n
.sym
;
1894 e
->symtree
= parent_st
; /* Point to the right thing. */
1896 if (sym
->attr
.flavor
== FL_PROCEDURE
1897 || sym
->attr
.intrinsic
1898 || sym
->attr
.external
)
1900 if (!gfc_resolve_expr (e
))
1906 e
->expr_type
= EXPR_VARIABLE
;
1908 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1909 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1910 && CLASS_DATA (sym
)->as
))
1912 e
->rank
= sym
->ts
.type
== BT_CLASS
1913 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1914 e
->ref
= gfc_get_ref ();
1915 e
->ref
->type
= REF_ARRAY
;
1916 e
->ref
->u
.ar
.type
= AR_FULL
;
1917 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1918 ? CLASS_DATA (sym
)->as
: sym
->as
;
1921 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1922 primary.c (match_actual_arg). If above code determines that it
1923 is a variable instead, it needs to be resolved as it was not
1924 done at the beginning of this function. */
1925 save_need_full_assumed_size
= need_full_assumed_size
;
1926 if (e
->expr_type
!= EXPR_VARIABLE
)
1927 need_full_assumed_size
= 0;
1928 if (!gfc_resolve_expr (e
))
1930 need_full_assumed_size
= save_need_full_assumed_size
;
1933 /* Check argument list functions %VAL, %LOC and %REF. There is
1934 nothing to do for %REF. */
1935 if (arg
->name
&& arg
->name
[0] == '%')
1937 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1939 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1941 gfc_error ("By-value argument at %L is not of numeric "
1948 gfc_error ("By-value argument at %L cannot be an array or "
1949 "an array section", &e
->where
);
1953 /* Intrinsics are still PROC_UNKNOWN here. However,
1954 since same file external procedures are not resolvable
1955 in gfortran, it is a good deal easier to leave them to
1957 if (ptype
!= PROC_UNKNOWN
1958 && ptype
!= PROC_DUMMY
1959 && ptype
!= PROC_EXTERNAL
1960 && ptype
!= PROC_MODULE
)
1962 gfc_error ("By-value argument at %L is not allowed "
1963 "in this context", &e
->where
);
1968 /* Statement functions have already been excluded above. */
1969 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1970 && e
->ts
.type
== BT_PROCEDURE
)
1972 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1974 gfc_error ("Passing internal procedure at %L by location "
1975 "not allowed", &e
->where
);
1981 comp
= gfc_get_proc_ptr_comp(e
);
1982 if (e
->expr_type
== EXPR_VARIABLE
1983 && comp
&& comp
->attr
.elemental
)
1985 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1986 "allowed as an actual argument at %L", comp
->name
,
1990 /* Fortran 2008, C1237. */
1991 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1992 && gfc_has_ultimate_pointer (e
))
1994 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1995 "component", &e
->where
);
1999 first_actual_arg
= false;
2002 return_value
= true;
2005 actual_arg
= actual_arg_sav
;
2006 first_actual_arg
= first_actual_arg_sav
;
2008 return return_value
;
2012 /* Do the checks of the actual argument list that are specific to elemental
2013 procedures. If called with c == NULL, we have a function, otherwise if
2014 expr == NULL, we have a subroutine. */
2017 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2019 gfc_actual_arglist
*arg0
;
2020 gfc_actual_arglist
*arg
;
2021 gfc_symbol
*esym
= NULL
;
2022 gfc_intrinsic_sym
*isym
= NULL
;
2024 gfc_intrinsic_arg
*iformal
= NULL
;
2025 gfc_formal_arglist
*eformal
= NULL
;
2026 bool formal_optional
= false;
2027 bool set_by_optional
= false;
2031 /* Is this an elemental procedure? */
2032 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2034 if (expr
->value
.function
.esym
!= NULL
2035 && expr
->value
.function
.esym
->attr
.elemental
)
2037 arg0
= expr
->value
.function
.actual
;
2038 esym
= expr
->value
.function
.esym
;
2040 else if (expr
->value
.function
.isym
!= NULL
2041 && expr
->value
.function
.isym
->elemental
)
2043 arg0
= expr
->value
.function
.actual
;
2044 isym
= expr
->value
.function
.isym
;
2049 else if (c
&& c
->ext
.actual
!= NULL
)
2051 arg0
= c
->ext
.actual
;
2053 if (c
->resolved_sym
)
2054 esym
= c
->resolved_sym
;
2056 esym
= c
->symtree
->n
.sym
;
2059 if (!esym
->attr
.elemental
)
2065 /* The rank of an elemental is the rank of its array argument(s). */
2066 for (arg
= arg0
; arg
; arg
= arg
->next
)
2068 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2070 rank
= arg
->expr
->rank
;
2071 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2072 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2073 set_by_optional
= true;
2075 /* Function specific; set the result rank and shape. */
2079 if (!expr
->shape
&& arg
->expr
->shape
)
2081 expr
->shape
= gfc_get_shape (rank
);
2082 for (i
= 0; i
< rank
; i
++)
2083 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2090 /* If it is an array, it shall not be supplied as an actual argument
2091 to an elemental procedure unless an array of the same rank is supplied
2092 as an actual argument corresponding to a nonoptional dummy argument of
2093 that elemental procedure(12.4.1.5). */
2094 formal_optional
= false;
2096 iformal
= isym
->formal
;
2098 eformal
= esym
->formal
;
2100 for (arg
= arg0
; arg
; arg
= arg
->next
)
2104 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2105 formal_optional
= true;
2106 eformal
= eformal
->next
;
2108 else if (isym
&& iformal
)
2110 if (iformal
->optional
)
2111 formal_optional
= true;
2112 iformal
= iformal
->next
;
2115 formal_optional
= true;
2117 if (pedantic
&& arg
->expr
!= NULL
2118 && arg
->expr
->expr_type
== EXPR_VARIABLE
2119 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2122 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2123 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2125 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2126 "MISSING, it cannot be the actual argument of an "
2127 "ELEMENTAL procedure unless there is a non-optional "
2128 "argument with the same rank (12.4.1.5)",
2129 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2133 for (arg
= arg0
; arg
; arg
= arg
->next
)
2135 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2138 /* Being elemental, the last upper bound of an assumed size array
2139 argument must be present. */
2140 if (resolve_assumed_size_actual (arg
->expr
))
2143 /* Elemental procedure's array actual arguments must conform. */
2146 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2153 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2154 is an array, the intent inout/out variable needs to be also an array. */
2155 if (rank
> 0 && esym
&& expr
== NULL
)
2156 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2157 arg
= arg
->next
, eformal
= eformal
->next
)
2158 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2159 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2160 && arg
->expr
&& arg
->expr
->rank
== 0)
2162 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2163 "ELEMENTAL subroutine %qs is a scalar, but another "
2164 "actual argument is an array", &arg
->expr
->where
,
2165 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2166 : "INOUT", eformal
->sym
->name
, esym
->name
);
2173 /* This function does the checking of references to global procedures
2174 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2175 77 and 95 standards. It checks for a gsymbol for the name, making
2176 one if it does not already exist. If it already exists, then the
2177 reference being resolved must correspond to the type of gsymbol.
2178 Otherwise, the new symbol is equipped with the attributes of the
2179 reference. The corresponding code that is called in creating
2180 global entities is parse.c.
2182 In addition, for all but -std=legacy, the gsymbols are used to
2183 check the interfaces of external procedures from the same file.
2184 The namespace of the gsymbol is resolved and then, once this is
2185 done the interface is checked. */
2189 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2191 if (!gsym_ns
->proc_name
->attr
.recursive
)
2194 if (sym
->ns
== gsym_ns
)
2197 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2204 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2206 if (gsym_ns
->entries
)
2208 gfc_entry_list
*entry
= gsym_ns
->entries
;
2210 for (; entry
; entry
= entry
->next
)
2212 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2214 if (strcmp (gsym_ns
->proc_name
->name
,
2215 sym
->ns
->proc_name
->name
) == 0)
2219 && strcmp (gsym_ns
->proc_name
->name
,
2220 sym
->ns
->parent
->proc_name
->name
) == 0)
2229 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2232 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2234 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2236 for ( ; arg
; arg
= arg
->next
)
2241 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2243 strncpy (errmsg
, _("allocatable argument"), err_len
);
2246 else if (arg
->sym
->attr
.asynchronous
)
2248 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2251 else if (arg
->sym
->attr
.optional
)
2253 strncpy (errmsg
, _("optional argument"), err_len
);
2256 else if (arg
->sym
->attr
.pointer
)
2258 strncpy (errmsg
, _("pointer argument"), err_len
);
2261 else if (arg
->sym
->attr
.target
)
2263 strncpy (errmsg
, _("target argument"), err_len
);
2266 else if (arg
->sym
->attr
.value
)
2268 strncpy (errmsg
, _("value argument"), err_len
);
2271 else if (arg
->sym
->attr
.volatile_
)
2273 strncpy (errmsg
, _("volatile argument"), err_len
);
2276 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2278 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2281 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2283 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2286 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2288 strncpy (errmsg
, _("coarray argument"), err_len
);
2291 else if (false) /* (2d) TODO: parametrized derived type */
2293 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2296 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2298 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2301 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2303 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2306 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2308 /* As assumed-type is unlimited polymorphic (cf. above).
2309 See also TS 29113, Note 6.1. */
2310 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2315 if (sym
->attr
.function
)
2317 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2319 if (res
->attr
.dimension
) /* (3a) */
2321 strncpy (errmsg
, _("array result"), err_len
);
2324 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2326 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2329 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2330 && res
->ts
.u
.cl
->length
2331 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2333 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2338 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2340 strncpy (errmsg
, _("elemental procedure"), err_len
);
2343 else if (sym
->attr
.is_bind_c
) /* (5) */
2345 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2354 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2355 gfc_actual_arglist
**actual
, int sub
)
2359 enum gfc_symbol_type type
;
2362 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2364 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2366 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2367 gfc_global_used (gsym
, where
);
2369 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2370 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2371 && gsym
->type
!= GSYM_UNKNOWN
2372 && !gsym
->binding_label
2374 && gsym
->ns
->resolved
!= -1
2375 && gsym
->ns
->proc_name
2376 && not_in_recursive (sym
, gsym
->ns
)
2377 && not_entry_self_reference (sym
, gsym
->ns
))
2379 gfc_symbol
*def_sym
;
2381 /* Resolve the gsymbol namespace if needed. */
2382 if (!gsym
->ns
->resolved
)
2384 gfc_dt_list
*old_dt_list
;
2386 /* Stash away derived types so that the backend_decls do not
2388 old_dt_list
= gfc_derived_types
;
2389 gfc_derived_types
= NULL
;
2391 gfc_resolve (gsym
->ns
);
2393 /* Store the new derived types with the global namespace. */
2394 if (gfc_derived_types
)
2395 gsym
->ns
->derived_types
= gfc_derived_types
;
2397 /* Restore the derived types of this namespace. */
2398 gfc_derived_types
= old_dt_list
;
2401 /* Make sure that translation for the gsymbol occurs before
2402 the procedure currently being resolved. */
2403 ns
= gfc_global_ns_list
;
2404 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2406 if (ns
->sibling
== gsym
->ns
)
2408 ns
->sibling
= gsym
->ns
->sibling
;
2409 gsym
->ns
->sibling
= gfc_global_ns_list
;
2410 gfc_global_ns_list
= gsym
->ns
;
2415 def_sym
= gsym
->ns
->proc_name
;
2417 /* This can happen if a binding name has been specified. */
2418 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2419 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2421 if (def_sym
->attr
.entry_master
)
2423 gfc_entry_list
*entry
;
2424 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2425 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2427 def_sym
= entry
->sym
;
2432 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2434 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2435 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2436 gfc_typename (&def_sym
->ts
));
2440 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2441 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2443 gfc_error ("Explicit interface required for %qs at %L: %s",
2444 sym
->name
, &sym
->declared_at
, reason
);
2448 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2449 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2450 gfc_errors_to_warnings (true);
2452 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2453 reason
, sizeof(reason
), NULL
, NULL
))
2455 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2456 sym
->name
, &sym
->declared_at
, reason
);
2461 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2462 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2463 gfc_errors_to_warnings (true);
2465 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2466 gfc_procedure_use (def_sym
, actual
, where
);
2470 gfc_errors_to_warnings (false);
2472 if (gsym
->type
== GSYM_UNKNOWN
)
2475 gsym
->where
= *where
;
2482 /************* Function resolution *************/
2484 /* Resolve a function call known to be generic.
2485 Section 14.1.2.4.1. */
2488 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2492 if (sym
->attr
.generic
)
2494 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2497 expr
->value
.function
.name
= s
->name
;
2498 expr
->value
.function
.esym
= s
;
2500 if (s
->ts
.type
!= BT_UNKNOWN
)
2502 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2503 expr
->ts
= s
->result
->ts
;
2506 expr
->rank
= s
->as
->rank
;
2507 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2508 expr
->rank
= s
->result
->as
->rank
;
2510 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2515 /* TODO: Need to search for elemental references in generic
2519 if (sym
->attr
.intrinsic
)
2520 return gfc_intrinsic_func_interface (expr
, 0);
2527 resolve_generic_f (gfc_expr
*expr
)
2531 gfc_interface
*intr
= NULL
;
2533 sym
= expr
->symtree
->n
.sym
;
2537 m
= resolve_generic_f0 (expr
, sym
);
2540 else if (m
== MATCH_ERROR
)
2545 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2546 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2549 if (sym
->ns
->parent
== NULL
)
2551 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2555 if (!generic_sym (sym
))
2559 /* Last ditch attempt. See if the reference is to an intrinsic
2560 that possesses a matching interface. 14.1.2.4 */
2561 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2563 gfc_error ("There is no specific function for the generic %qs "
2564 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2570 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2573 return resolve_structure_cons (expr
, 0);
2576 m
= gfc_intrinsic_func_interface (expr
, 0);
2581 gfc_error ("Generic function %qs at %L is not consistent with a "
2582 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2589 /* Resolve a function call known to be specific. */
2592 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2596 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2598 if (sym
->attr
.dummy
)
2600 sym
->attr
.proc
= PROC_DUMMY
;
2604 sym
->attr
.proc
= PROC_EXTERNAL
;
2608 if (sym
->attr
.proc
== PROC_MODULE
2609 || sym
->attr
.proc
== PROC_ST_FUNCTION
2610 || sym
->attr
.proc
== PROC_INTERNAL
)
2613 if (sym
->attr
.intrinsic
)
2615 m
= gfc_intrinsic_func_interface (expr
, 1);
2619 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2620 "with an intrinsic", sym
->name
, &expr
->where
);
2628 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2631 expr
->ts
= sym
->result
->ts
;
2634 expr
->value
.function
.name
= sym
->name
;
2635 expr
->value
.function
.esym
= sym
;
2636 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2638 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2640 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2641 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2642 else if (sym
->as
!= NULL
)
2643 expr
->rank
= sym
->as
->rank
;
2650 resolve_specific_f (gfc_expr
*expr
)
2655 sym
= expr
->symtree
->n
.sym
;
2659 m
= resolve_specific_f0 (sym
, expr
);
2662 if (m
== MATCH_ERROR
)
2665 if (sym
->ns
->parent
== NULL
)
2668 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2674 gfc_error ("Unable to resolve the specific function %qs at %L",
2675 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2681 /* Resolve a procedure call not known to be generic nor specific. */
2684 resolve_unknown_f (gfc_expr
*expr
)
2689 sym
= expr
->symtree
->n
.sym
;
2691 if (sym
->attr
.dummy
)
2693 sym
->attr
.proc
= PROC_DUMMY
;
2694 expr
->value
.function
.name
= sym
->name
;
2698 /* See if we have an intrinsic function reference. */
2700 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2702 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2707 /* The reference is to an external name. */
2709 sym
->attr
.proc
= PROC_EXTERNAL
;
2710 expr
->value
.function
.name
= sym
->name
;
2711 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2713 if (sym
->as
!= NULL
)
2714 expr
->rank
= sym
->as
->rank
;
2716 /* Type of the expression is either the type of the symbol or the
2717 default type of the symbol. */
2720 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2722 if (sym
->ts
.type
!= BT_UNKNOWN
)
2726 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2728 if (ts
->type
== BT_UNKNOWN
)
2730 gfc_error ("Function %qs at %L has no IMPLICIT type",
2731 sym
->name
, &expr
->where
);
2742 /* Return true, if the symbol is an external procedure. */
2744 is_external_proc (gfc_symbol
*sym
)
2746 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2747 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2748 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2749 && !sym
->attr
.proc_pointer
2750 && !sym
->attr
.use_assoc
2758 /* Figure out if a function reference is pure or not. Also set the name
2759 of the function for a potential error message. Return nonzero if the
2760 function is PURE, zero if not. */
2762 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2765 pure_function (gfc_expr
*e
, const char **name
)
2768 gfc_component
*comp
;
2772 if (e
->symtree
!= NULL
2773 && e
->symtree
->n
.sym
!= NULL
2774 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2775 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2777 comp
= gfc_get_proc_ptr_comp (e
);
2780 pure
= gfc_pure (comp
->ts
.interface
);
2783 else if (e
->value
.function
.esym
)
2785 pure
= gfc_pure (e
->value
.function
.esym
);
2786 *name
= e
->value
.function
.esym
->name
;
2788 else if (e
->value
.function
.isym
)
2790 pure
= e
->value
.function
.isym
->pure
2791 || e
->value
.function
.isym
->elemental
;
2792 *name
= e
->value
.function
.isym
->name
;
2796 /* Implicit functions are not pure. */
2798 *name
= e
->value
.function
.name
;
2806 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2807 int *f ATTRIBUTE_UNUSED
)
2811 /* Don't bother recursing into other statement functions
2812 since they will be checked individually for purity. */
2813 if (e
->expr_type
!= EXPR_FUNCTION
2815 || e
->symtree
->n
.sym
== sym
2816 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2819 return pure_function (e
, &name
) ? false : true;
2824 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2826 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2830 /* Check if an impure function is allowed in the current context. */
2832 static bool check_pure_function (gfc_expr
*e
)
2834 const char *name
= NULL
;
2835 if (!pure_function (e
, &name
) && name
)
2839 gfc_error ("Reference to impure function %qs at %L inside a "
2840 "FORALL %s", name
, &e
->where
,
2841 forall_flag
== 2 ? "mask" : "block");
2844 else if (gfc_do_concurrent_flag
)
2846 gfc_error ("Reference to impure function %qs at %L inside a "
2847 "DO CONCURRENT %s", name
, &e
->where
,
2848 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2851 else if (gfc_pure (NULL
))
2853 gfc_error ("Reference to impure function %qs at %L "
2854 "within a PURE procedure", name
, &e
->where
);
2857 gfc_unset_implicit_pure (NULL
);
2863 /* Update current procedure's array_outer_dependency flag, considering
2864 a call to procedure SYM. */
2867 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2869 /* Check to see if this is a sibling function that has not yet
2871 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2872 for (; sibling
; sibling
= sibling
->sibling
)
2874 if (sibling
->proc_name
== sym
)
2876 gfc_resolve (sibling
);
2881 /* If SYM has references to outer arrays, so has the procedure calling
2882 SYM. If SYM is a procedure pointer, we can assume the worst. */
2883 if (sym
->attr
.array_outer_dependency
2884 || sym
->attr
.proc_pointer
)
2885 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2889 /* Resolve a function call, which means resolving the arguments, then figuring
2890 out which entity the name refers to. */
2893 resolve_function (gfc_expr
*expr
)
2895 gfc_actual_arglist
*arg
;
2899 procedure_type p
= PROC_INTRINSIC
;
2900 bool no_formal_args
;
2904 sym
= expr
->symtree
->n
.sym
;
2906 /* If this is a procedure pointer component, it has already been resolved. */
2907 if (gfc_is_proc_ptr_comp (expr
))
2910 if (sym
&& sym
->attr
.intrinsic
2911 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2914 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2916 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2920 /* If this ia a deferred TBP with an abstract interface (which may
2921 of course be referenced), expr->value.function.esym will be set. */
2922 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2924 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2925 sym
->name
, &expr
->where
);
2929 /* Switch off assumed size checking and do this again for certain kinds
2930 of procedure, once the procedure itself is resolved. */
2931 need_full_assumed_size
++;
2933 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2934 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2936 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2937 inquiry_argument
= true;
2938 no_formal_args
= sym
&& is_external_proc (sym
)
2939 && gfc_sym_get_dummy_args (sym
) == NULL
;
2941 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2944 inquiry_argument
= false;
2948 inquiry_argument
= false;
2950 /* Resume assumed_size checking. */
2951 need_full_assumed_size
--;
2953 /* If the procedure is external, check for usage. */
2954 if (sym
&& is_external_proc (sym
))
2955 resolve_global_procedure (sym
, &expr
->where
,
2956 &expr
->value
.function
.actual
, 0);
2958 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2960 && sym
->ts
.u
.cl
->length
== NULL
2962 && !sym
->ts
.deferred
2963 && expr
->value
.function
.esym
== NULL
2964 && !sym
->attr
.contained
)
2966 /* Internal procedures are taken care of in resolve_contained_fntype. */
2967 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2968 "be used at %L since it is not a dummy argument",
2969 sym
->name
, &expr
->where
);
2973 /* See if function is already resolved. */
2975 if (expr
->value
.function
.name
!= NULL
2976 || expr
->value
.function
.isym
!= NULL
)
2978 if (expr
->ts
.type
== BT_UNKNOWN
)
2984 /* Apply the rules of section 14.1.2. */
2986 switch (procedure_kind (sym
))
2989 t
= resolve_generic_f (expr
);
2992 case PTYPE_SPECIFIC
:
2993 t
= resolve_specific_f (expr
);
2997 t
= resolve_unknown_f (expr
);
3001 gfc_internal_error ("resolve_function(): bad function type");
3005 /* If the expression is still a function (it might have simplified),
3006 then we check to see if we are calling an elemental function. */
3008 if (expr
->expr_type
!= EXPR_FUNCTION
)
3011 temp
= need_full_assumed_size
;
3012 need_full_assumed_size
= 0;
3014 if (!resolve_elemental_actual (expr
, NULL
))
3017 if (omp_workshare_flag
3018 && expr
->value
.function
.esym
3019 && ! gfc_elemental (expr
->value
.function
.esym
))
3021 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3022 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3027 #define GENERIC_ID expr->value.function.isym->id
3028 else if (expr
->value
.function
.actual
!= NULL
3029 && expr
->value
.function
.isym
!= NULL
3030 && GENERIC_ID
!= GFC_ISYM_LBOUND
3031 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3032 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3033 && GENERIC_ID
!= GFC_ISYM_LEN
3034 && GENERIC_ID
!= GFC_ISYM_LOC
3035 && GENERIC_ID
!= GFC_ISYM_C_LOC
3036 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3038 /* Array intrinsics must also have the last upper bound of an
3039 assumed size array argument. UBOUND and SIZE have to be
3040 excluded from the check if the second argument is anything
3043 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3045 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3046 && arg
== expr
->value
.function
.actual
3047 && arg
->next
!= NULL
&& arg
->next
->expr
)
3049 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3052 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3055 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3060 if (arg
->expr
!= NULL
3061 && arg
->expr
->rank
> 0
3062 && resolve_assumed_size_actual (arg
->expr
))
3068 need_full_assumed_size
= temp
;
3070 if (!check_pure_function(expr
))
3073 /* Functions without the RECURSIVE attribution are not allowed to
3074 * call themselves. */
3075 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3078 esym
= expr
->value
.function
.esym
;
3080 if (is_illegal_recursion (esym
, gfc_current_ns
))
3082 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3083 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3084 " function %qs is not RECURSIVE",
3085 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3087 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3088 " is not RECURSIVE", esym
->name
, &expr
->where
);
3094 /* Character lengths of use associated functions may contains references to
3095 symbols not referenced from the current program unit otherwise. Make sure
3096 those symbols are marked as referenced. */
3098 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3099 && expr
->value
.function
.esym
->attr
.use_assoc
)
3101 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3104 /* Make sure that the expression has a typespec that works. */
3105 if (expr
->ts
.type
== BT_UNKNOWN
)
3107 if (expr
->symtree
->n
.sym
->result
3108 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3109 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3110 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3113 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3115 if (expr
->value
.function
.esym
)
3116 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3118 update_current_proc_array_outer_dependency (sym
);
3121 /* typebound procedure: Assume the worst. */
3122 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3128 /************* Subroutine resolution *************/
3131 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3138 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3142 else if (gfc_do_concurrent_flag
)
3144 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3148 else if (gfc_pure (NULL
))
3150 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3154 gfc_unset_implicit_pure (NULL
);
3160 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3164 if (sym
->attr
.generic
)
3166 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3169 c
->resolved_sym
= s
;
3170 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3175 /* TODO: Need to search for elemental references in generic interface. */
3178 if (sym
->attr
.intrinsic
)
3179 return gfc_intrinsic_sub_interface (c
, 0);
3186 resolve_generic_s (gfc_code
*c
)
3191 sym
= c
->symtree
->n
.sym
;
3195 m
= resolve_generic_s0 (c
, sym
);
3198 else if (m
== MATCH_ERROR
)
3202 if (sym
->ns
->parent
== NULL
)
3204 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3208 if (!generic_sym (sym
))
3212 /* Last ditch attempt. See if the reference is to an intrinsic
3213 that possesses a matching interface. 14.1.2.4 */
3214 sym
= c
->symtree
->n
.sym
;
3216 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3218 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3219 sym
->name
, &c
->loc
);
3223 m
= gfc_intrinsic_sub_interface (c
, 0);
3227 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3228 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3234 /* Resolve a subroutine call known to be specific. */
3237 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3241 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3243 if (sym
->attr
.dummy
)
3245 sym
->attr
.proc
= PROC_DUMMY
;
3249 sym
->attr
.proc
= PROC_EXTERNAL
;
3253 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3256 if (sym
->attr
.intrinsic
)
3258 m
= gfc_intrinsic_sub_interface (c
, 1);
3262 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3263 "with an intrinsic", sym
->name
, &c
->loc
);
3271 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3273 c
->resolved_sym
= sym
;
3274 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3282 resolve_specific_s (gfc_code
*c
)
3287 sym
= c
->symtree
->n
.sym
;
3291 m
= resolve_specific_s0 (c
, sym
);
3294 if (m
== MATCH_ERROR
)
3297 if (sym
->ns
->parent
== NULL
)
3300 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3306 sym
= c
->symtree
->n
.sym
;
3307 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3308 sym
->name
, &c
->loc
);
3314 /* Resolve a subroutine call not known to be generic nor specific. */
3317 resolve_unknown_s (gfc_code
*c
)
3321 sym
= c
->symtree
->n
.sym
;
3323 if (sym
->attr
.dummy
)
3325 sym
->attr
.proc
= PROC_DUMMY
;
3329 /* See if we have an intrinsic function reference. */
3331 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3333 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3338 /* The reference is to an external name. */
3341 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3343 c
->resolved_sym
= sym
;
3345 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3349 /* Resolve a subroutine call. Although it was tempting to use the same code
3350 for functions, subroutines and functions are stored differently and this
3351 makes things awkward. */
3354 resolve_call (gfc_code
*c
)
3357 procedure_type ptype
= PROC_INTRINSIC
;
3358 gfc_symbol
*csym
, *sym
;
3359 bool no_formal_args
;
3361 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3363 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3365 gfc_error ("%qs at %L has a type, which is not consistent with "
3366 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3370 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3373 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3374 sym
= st
? st
->n
.sym
: NULL
;
3375 if (sym
&& csym
!= sym
3376 && sym
->ns
== gfc_current_ns
3377 && sym
->attr
.flavor
== FL_PROCEDURE
3378 && sym
->attr
.contained
)
3381 if (csym
->attr
.generic
)
3382 c
->symtree
->n
.sym
= sym
;
3385 csym
= c
->symtree
->n
.sym
;
3389 /* If this ia a deferred TBP, c->expr1 will be set. */
3390 if (!c
->expr1
&& csym
)
3392 if (csym
->attr
.abstract
)
3394 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3395 csym
->name
, &c
->loc
);
3399 /* Subroutines without the RECURSIVE attribution are not allowed to
3401 if (is_illegal_recursion (csym
, gfc_current_ns
))
3403 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3404 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3405 "as subroutine %qs is not RECURSIVE",
3406 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3408 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3409 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3415 /* Switch off assumed size checking and do this again for certain kinds
3416 of procedure, once the procedure itself is resolved. */
3417 need_full_assumed_size
++;
3420 ptype
= csym
->attr
.proc
;
3422 no_formal_args
= csym
&& is_external_proc (csym
)
3423 && gfc_sym_get_dummy_args (csym
) == NULL
;
3424 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3427 /* Resume assumed_size checking. */
3428 need_full_assumed_size
--;
3430 /* If external, check for usage. */
3431 if (csym
&& is_external_proc (csym
))
3432 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3435 if (c
->resolved_sym
== NULL
)
3437 c
->resolved_isym
= NULL
;
3438 switch (procedure_kind (csym
))
3441 t
= resolve_generic_s (c
);
3444 case PTYPE_SPECIFIC
:
3445 t
= resolve_specific_s (c
);
3449 t
= resolve_unknown_s (c
);
3453 gfc_internal_error ("resolve_subroutine(): bad function type");
3457 /* Some checks of elemental subroutine actual arguments. */
3458 if (!resolve_elemental_actual (NULL
, c
))
3462 update_current_proc_array_outer_dependency (csym
);
3464 /* Typebound procedure: Assume the worst. */
3465 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3471 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3472 op1->shape and op2->shape are non-NULL return true if their shapes
3473 match. If both op1->shape and op2->shape are non-NULL return false
3474 if their shapes do not match. If either op1->shape or op2->shape is
3475 NULL, return true. */
3478 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3485 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3487 for (i
= 0; i
< op1
->rank
; i
++)
3489 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3491 gfc_error ("Shapes for operands at %L and %L are not conformable",
3492 &op1
->where
, &op2
->where
);
3503 /* Resolve an operator expression node. This can involve replacing the
3504 operation with a user defined function call. */
3507 resolve_operator (gfc_expr
*e
)
3509 gfc_expr
*op1
, *op2
;
3511 bool dual_locus_error
;
3514 /* Resolve all subnodes-- give them types. */
3516 switch (e
->value
.op
.op
)
3519 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3522 /* Fall through... */
3525 case INTRINSIC_UPLUS
:
3526 case INTRINSIC_UMINUS
:
3527 case INTRINSIC_PARENTHESES
:
3528 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3533 /* Typecheck the new node. */
3535 op1
= e
->value
.op
.op1
;
3536 op2
= e
->value
.op
.op2
;
3537 dual_locus_error
= false;
3539 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3540 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3542 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3546 switch (e
->value
.op
.op
)
3548 case INTRINSIC_UPLUS
:
3549 case INTRINSIC_UMINUS
:
3550 if (op1
->ts
.type
== BT_INTEGER
3551 || op1
->ts
.type
== BT_REAL
3552 || op1
->ts
.type
== BT_COMPLEX
)
3558 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3559 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3562 case INTRINSIC_PLUS
:
3563 case INTRINSIC_MINUS
:
3564 case INTRINSIC_TIMES
:
3565 case INTRINSIC_DIVIDE
:
3566 case INTRINSIC_POWER
:
3567 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3569 gfc_type_convert_binary (e
, 1);
3574 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3575 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3576 gfc_typename (&op2
->ts
));
3579 case INTRINSIC_CONCAT
:
3580 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3581 && op1
->ts
.kind
== op2
->ts
.kind
)
3583 e
->ts
.type
= BT_CHARACTER
;
3584 e
->ts
.kind
= op1
->ts
.kind
;
3589 _("Operands of string concatenation operator at %%L are %s/%s"),
3590 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3596 case INTRINSIC_NEQV
:
3597 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3599 e
->ts
.type
= BT_LOGICAL
;
3600 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3601 if (op1
->ts
.kind
< e
->ts
.kind
)
3602 gfc_convert_type (op1
, &e
->ts
, 2);
3603 else if (op2
->ts
.kind
< e
->ts
.kind
)
3604 gfc_convert_type (op2
, &e
->ts
, 2);
3608 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3609 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3610 gfc_typename (&op2
->ts
));
3615 if (op1
->ts
.type
== BT_LOGICAL
)
3617 e
->ts
.type
= BT_LOGICAL
;
3618 e
->ts
.kind
= op1
->ts
.kind
;
3622 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3623 gfc_typename (&op1
->ts
));
3627 case INTRINSIC_GT_OS
:
3629 case INTRINSIC_GE_OS
:
3631 case INTRINSIC_LT_OS
:
3633 case INTRINSIC_LE_OS
:
3634 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3636 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3640 /* Fall through... */
3643 case INTRINSIC_EQ_OS
:
3645 case INTRINSIC_NE_OS
:
3646 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3647 && op1
->ts
.kind
== op2
->ts
.kind
)
3649 e
->ts
.type
= BT_LOGICAL
;
3650 e
->ts
.kind
= gfc_default_logical_kind
;
3654 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3656 gfc_type_convert_binary (e
, 1);
3658 e
->ts
.type
= BT_LOGICAL
;
3659 e
->ts
.kind
= gfc_default_logical_kind
;
3661 if (warn_compare_reals
)
3663 gfc_intrinsic_op op
= e
->value
.op
.op
;
3665 /* Type conversion has made sure that the types of op1 and op2
3666 agree, so it is only necessary to check the first one. */
3667 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3668 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3669 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3673 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3674 msg
= "Equality comparison for %s at %L";
3676 msg
= "Inequality comparison for %s at %L";
3678 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3685 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3687 _("Logicals at %%L must be compared with %s instead of %s"),
3688 (e
->value
.op
.op
== INTRINSIC_EQ
3689 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3690 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3693 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3694 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3695 gfc_typename (&op2
->ts
));
3699 case INTRINSIC_USER
:
3700 if (e
->value
.op
.uop
->op
== NULL
)
3701 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3702 else if (op2
== NULL
)
3703 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3704 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3707 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3708 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3709 gfc_typename (&op2
->ts
));
3710 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3715 case INTRINSIC_PARENTHESES
:
3717 if (e
->ts
.type
== BT_CHARACTER
)
3718 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3722 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3725 /* Deal with arrayness of an operand through an operator. */
3729 switch (e
->value
.op
.op
)
3731 case INTRINSIC_PLUS
:
3732 case INTRINSIC_MINUS
:
3733 case INTRINSIC_TIMES
:
3734 case INTRINSIC_DIVIDE
:
3735 case INTRINSIC_POWER
:
3736 case INTRINSIC_CONCAT
:
3740 case INTRINSIC_NEQV
:
3742 case INTRINSIC_EQ_OS
:
3744 case INTRINSIC_NE_OS
:
3746 case INTRINSIC_GT_OS
:
3748 case INTRINSIC_GE_OS
:
3750 case INTRINSIC_LT_OS
:
3752 case INTRINSIC_LE_OS
:
3754 if (op1
->rank
== 0 && op2
->rank
== 0)
3757 if (op1
->rank
== 0 && op2
->rank
!= 0)
3759 e
->rank
= op2
->rank
;
3761 if (e
->shape
== NULL
)
3762 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3765 if (op1
->rank
!= 0 && op2
->rank
== 0)
3767 e
->rank
= op1
->rank
;
3769 if (e
->shape
== NULL
)
3770 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3773 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3775 if (op1
->rank
== op2
->rank
)
3777 e
->rank
= op1
->rank
;
3778 if (e
->shape
== NULL
)
3780 t
= compare_shapes (op1
, op2
);
3784 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3789 /* Allow higher level expressions to work. */
3792 /* Try user-defined operators, and otherwise throw an error. */
3793 dual_locus_error
= true;
3795 _("Inconsistent ranks for operator at %%L and %%L"));
3802 case INTRINSIC_PARENTHESES
:
3804 case INTRINSIC_UPLUS
:
3805 case INTRINSIC_UMINUS
:
3806 /* Simply copy arrayness attribute */
3807 e
->rank
= op1
->rank
;
3809 if (e
->shape
== NULL
)
3810 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3818 /* Attempt to simplify the expression. */
3821 t
= gfc_simplify_expr (e
, 0);
3822 /* Some calls do not succeed in simplification and return false
3823 even though there is no error; e.g. variable references to
3824 PARAMETER arrays. */
3825 if (!gfc_is_constant_expr (e
))
3833 match m
= gfc_extend_expr (e
);
3836 if (m
== MATCH_ERROR
)
3840 if (dual_locus_error
)
3841 gfc_error (msg
, &op1
->where
, &op2
->where
);
3843 gfc_error (msg
, &e
->where
);
3849 /************** Array resolution subroutines **************/
3852 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
3854 /* Compare two integer expressions. */
3856 static compare_result
3857 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3861 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3862 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3865 /* If either of the types isn't INTEGER, we must have
3866 raised an error earlier. */
3868 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3871 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3881 /* Compare an integer expression with an integer. */
3883 static compare_result
3884 compare_bound_int (gfc_expr
*a
, int b
)
3888 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3891 if (a
->ts
.type
!= BT_INTEGER
)
3892 gfc_internal_error ("compare_bound_int(): Bad expression");
3894 i
= mpz_cmp_si (a
->value
.integer
, b
);
3904 /* Compare an integer expression with a mpz_t. */
3906 static compare_result
3907 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3911 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3914 if (a
->ts
.type
!= BT_INTEGER
)
3915 gfc_internal_error ("compare_bound_int(): Bad expression");
3917 i
= mpz_cmp (a
->value
.integer
, b
);
3927 /* Compute the last value of a sequence given by a triplet.
3928 Return 0 if it wasn't able to compute the last value, or if the
3929 sequence if empty, and 1 otherwise. */
3932 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3933 gfc_expr
*stride
, mpz_t last
)
3937 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3938 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3939 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3942 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3943 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3946 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3948 if (compare_bound (start
, end
) == CMP_GT
)
3950 mpz_set (last
, end
->value
.integer
);
3954 if (compare_bound_int (stride
, 0) == CMP_GT
)
3956 /* Stride is positive */
3957 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3962 /* Stride is negative */
3963 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3968 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3969 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3970 mpz_sub (last
, end
->value
.integer
, rem
);
3977 /* Compare a single dimension of an array reference to the array
3981 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3985 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3987 gcc_assert (ar
->stride
[i
] == NULL
);
3988 /* This implies [*] as [*:] and [*:3] are not possible. */
3989 if (ar
->start
[i
] == NULL
)
3991 gcc_assert (ar
->end
[i
] == NULL
);
3996 /* Given start, end and stride values, calculate the minimum and
3997 maximum referenced indexes. */
3999 switch (ar
->dimen_type
[i
])
4002 case DIMEN_THIS_IMAGE
:
4007 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4010 gfc_warning (0, "Array reference at %L is out of bounds "
4011 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4012 mpz_get_si (ar
->start
[i
]->value
.integer
),
4013 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4015 gfc_warning (0, "Array reference at %L is out of bounds "
4016 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4017 mpz_get_si (ar
->start
[i
]->value
.integer
),
4018 mpz_get_si (as
->lower
[i
]->value
.integer
),
4022 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4025 gfc_warning (0, "Array reference at %L is out of bounds "
4026 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4027 mpz_get_si (ar
->start
[i
]->value
.integer
),
4028 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4030 gfc_warning (0, "Array reference at %L is out of bounds "
4031 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4032 mpz_get_si (ar
->start
[i
]->value
.integer
),
4033 mpz_get_si (as
->upper
[i
]->value
.integer
),
4042 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4043 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4045 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4047 /* Check for zero stride, which is not allowed. */
4048 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4050 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4054 /* if start == len || (stride > 0 && start < len)
4055 || (stride < 0 && start > len),
4056 then the array section contains at least one element. In this
4057 case, there is an out-of-bounds access if
4058 (start < lower || start > upper). */
4059 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4060 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4061 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4062 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4063 && comp_start_end
== CMP_GT
))
4065 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4067 gfc_warning (0, "Lower array reference at %L is out of bounds "
4068 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4069 mpz_get_si (AR_START
->value
.integer
),
4070 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4073 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4075 gfc_warning (0, "Lower array reference at %L is out of bounds "
4076 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4077 mpz_get_si (AR_START
->value
.integer
),
4078 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4083 /* If we can compute the highest index of the array section,
4084 then it also has to be between lower and upper. */
4085 mpz_init (last_value
);
4086 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4089 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4091 gfc_warning (0, "Upper array reference at %L is out of bounds "
4092 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4093 mpz_get_si (last_value
),
4094 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4095 mpz_clear (last_value
);
4098 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4100 gfc_warning (0, "Upper array reference at %L is out of bounds "
4101 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4102 mpz_get_si (last_value
),
4103 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4104 mpz_clear (last_value
);
4108 mpz_clear (last_value
);
4116 gfc_internal_error ("check_dimension(): Bad array reference");
4123 /* Compare an array reference with an array specification. */
4126 compare_spec_to_ref (gfc_array_ref
*ar
)
4133 /* TODO: Full array sections are only allowed as actual parameters. */
4134 if (as
->type
== AS_ASSUMED_SIZE
4135 && (/*ar->type == AR_FULL
4136 ||*/ (ar
->type
== AR_SECTION
4137 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4139 gfc_error ("Rightmost upper bound of assumed size array section "
4140 "not specified at %L", &ar
->where
);
4144 if (ar
->type
== AR_FULL
)
4147 if (as
->rank
!= ar
->dimen
)
4149 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4150 &ar
->where
, ar
->dimen
, as
->rank
);
4154 /* ar->codimen == 0 is a local array. */
4155 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4157 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4158 &ar
->where
, ar
->codimen
, as
->corank
);
4162 for (i
= 0; i
< as
->rank
; i
++)
4163 if (!check_dimension (i
, ar
, as
))
4166 /* Local access has no coarray spec. */
4167 if (ar
->codimen
!= 0)
4168 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4170 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4171 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4173 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4174 i
+ 1 - as
->rank
, &ar
->where
);
4177 if (!check_dimension (i
, ar
, as
))
4185 /* Resolve one part of an array index. */
4188 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4189 int force_index_integer_kind
)
4196 if (!gfc_resolve_expr (index
))
4199 if (check_scalar
&& index
->rank
!= 0)
4201 gfc_error ("Array index at %L must be scalar", &index
->where
);
4205 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4207 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4208 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4212 if (index
->ts
.type
== BT_REAL
)
4213 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4217 if ((index
->ts
.kind
!= gfc_index_integer_kind
4218 && force_index_integer_kind
)
4219 || index
->ts
.type
!= BT_INTEGER
)
4222 ts
.type
= BT_INTEGER
;
4223 ts
.kind
= gfc_index_integer_kind
;
4225 gfc_convert_type_warn (index
, &ts
, 2, 0);
4231 /* Resolve one part of an array index. */
4234 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4236 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4239 /* Resolve a dim argument to an intrinsic function. */
4242 gfc_resolve_dim_arg (gfc_expr
*dim
)
4247 if (!gfc_resolve_expr (dim
))
4252 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4257 if (dim
->ts
.type
!= BT_INTEGER
)
4259 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4263 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4268 ts
.type
= BT_INTEGER
;
4269 ts
.kind
= gfc_index_integer_kind
;
4271 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4277 /* Given an expression that contains array references, update those array
4278 references to point to the right array specifications. While this is
4279 filled in during matching, this information is difficult to save and load
4280 in a module, so we take care of it here.
4282 The idea here is that the original array reference comes from the
4283 base symbol. We traverse the list of reference structures, setting
4284 the stored reference to references. Component references can
4285 provide an additional array specification. */
4288 find_array_spec (gfc_expr
*e
)
4294 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4295 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4297 as
= e
->symtree
->n
.sym
->as
;
4299 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4304 gfc_internal_error ("find_array_spec(): Missing spec");
4311 c
= ref
->u
.c
.component
;
4312 if (c
->attr
.dimension
)
4315 gfc_internal_error ("find_array_spec(): unused as(1)");
4326 gfc_internal_error ("find_array_spec(): unused as(2)");
4330 /* Resolve an array reference. */
4333 resolve_array_ref (gfc_array_ref
*ar
)
4335 int i
, check_scalar
;
4338 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4340 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4342 /* Do not force gfc_index_integer_kind for the start. We can
4343 do fine with any integer kind. This avoids temporary arrays
4344 created for indexing with a vector. */
4345 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4347 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4349 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4354 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4358 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4362 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4363 if (e
->expr_type
== EXPR_VARIABLE
4364 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4365 ar
->start
[i
] = gfc_get_parentheses (e
);
4369 gfc_error ("Array index at %L is an array of rank %d",
4370 &ar
->c_where
[i
], e
->rank
);
4374 /* Fill in the upper bound, which may be lower than the
4375 specified one for something like a(2:10:5), which is
4376 identical to a(2:7:5). Only relevant for strides not equal
4377 to one. Don't try a division by zero. */
4378 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4379 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4380 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4381 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4385 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4387 if (ar
->end
[i
] == NULL
)
4390 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4392 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4394 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4395 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4397 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4408 if (ar
->type
== AR_FULL
)
4410 if (ar
->as
->rank
== 0)
4411 ar
->type
= AR_ELEMENT
;
4413 /* Make sure array is the same as array(:,:), this way
4414 we don't need to special case all the time. */
4415 ar
->dimen
= ar
->as
->rank
;
4416 for (i
= 0; i
< ar
->dimen
; i
++)
4418 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4420 gcc_assert (ar
->start
[i
] == NULL
);
4421 gcc_assert (ar
->end
[i
] == NULL
);
4422 gcc_assert (ar
->stride
[i
] == NULL
);
4426 /* If the reference type is unknown, figure out what kind it is. */
4428 if (ar
->type
== AR_UNKNOWN
)
4430 ar
->type
= AR_ELEMENT
;
4431 for (i
= 0; i
< ar
->dimen
; i
++)
4432 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4433 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4435 ar
->type
= AR_SECTION
;
4440 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4443 if (ar
->as
->corank
&& ar
->codimen
== 0)
4446 ar
->codimen
= ar
->as
->corank
;
4447 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4448 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4456 resolve_substring (gfc_ref
*ref
)
4458 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4460 if (ref
->u
.ss
.start
!= NULL
)
4462 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4465 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4467 gfc_error ("Substring start index at %L must be of type INTEGER",
4468 &ref
->u
.ss
.start
->where
);
4472 if (ref
->u
.ss
.start
->rank
!= 0)
4474 gfc_error ("Substring start index at %L must be scalar",
4475 &ref
->u
.ss
.start
->where
);
4479 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4480 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4481 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4483 gfc_error ("Substring start index at %L is less than one",
4484 &ref
->u
.ss
.start
->where
);
4489 if (ref
->u
.ss
.end
!= NULL
)
4491 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4494 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4496 gfc_error ("Substring end index at %L must be of type INTEGER",
4497 &ref
->u
.ss
.end
->where
);
4501 if (ref
->u
.ss
.end
->rank
!= 0)
4503 gfc_error ("Substring end index at %L must be scalar",
4504 &ref
->u
.ss
.end
->where
);
4508 if (ref
->u
.ss
.length
!= NULL
4509 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4510 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4511 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4513 gfc_error ("Substring end index at %L exceeds the string length",
4514 &ref
->u
.ss
.start
->where
);
4518 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4519 gfc_integer_kinds
[k
].huge
) == CMP_GT
4520 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4521 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4523 gfc_error ("Substring end index at %L is too large",
4524 &ref
->u
.ss
.end
->where
);
4533 /* This function supplies missing substring charlens. */
4536 gfc_resolve_substring_charlen (gfc_expr
*e
)
4539 gfc_expr
*start
, *end
;
4541 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4542 if (char_ref
->type
== REF_SUBSTRING
)
4548 gcc_assert (char_ref
->next
== NULL
);
4552 if (e
->ts
.u
.cl
->length
)
4553 gfc_free_expr (e
->ts
.u
.cl
->length
);
4554 else if (e
->expr_type
== EXPR_VARIABLE
4555 && e
->symtree
->n
.sym
->attr
.dummy
)
4559 e
->ts
.type
= BT_CHARACTER
;
4560 e
->ts
.kind
= gfc_default_character_kind
;
4563 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4565 if (char_ref
->u
.ss
.start
)
4566 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4568 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4570 if (char_ref
->u
.ss
.end
)
4571 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4572 else if (e
->expr_type
== EXPR_VARIABLE
)
4573 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4579 gfc_free_expr (start
);
4580 gfc_free_expr (end
);
4584 /* Length = (end - start +1). */
4585 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4586 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4587 gfc_get_int_expr (gfc_default_integer_kind
,
4590 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4591 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4593 /* Make sure that the length is simplified. */
4594 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4595 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4599 /* Resolve subtype references. */
4602 resolve_ref (gfc_expr
*expr
)
4604 int current_part_dimension
, n_components
, seen_part_dimension
;
4607 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4608 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4610 find_array_spec (expr
);
4614 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4618 if (!resolve_array_ref (&ref
->u
.ar
))
4626 if (!resolve_substring (ref
))
4631 /* Check constraints on part references. */
4633 current_part_dimension
= 0;
4634 seen_part_dimension
= 0;
4637 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4642 switch (ref
->u
.ar
.type
)
4645 /* Coarray scalar. */
4646 if (ref
->u
.ar
.as
->rank
== 0)
4648 current_part_dimension
= 0;
4653 current_part_dimension
= 1;
4657 current_part_dimension
= 0;
4661 gfc_internal_error ("resolve_ref(): Bad array reference");
4667 if (current_part_dimension
|| seen_part_dimension
)
4670 if (ref
->u
.c
.component
->attr
.pointer
4671 || ref
->u
.c
.component
->attr
.proc_pointer
4672 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4673 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4675 gfc_error ("Component to the right of a part reference "
4676 "with nonzero rank must not have the POINTER "
4677 "attribute at %L", &expr
->where
);
4680 else if (ref
->u
.c
.component
->attr
.allocatable
4681 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4682 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4685 gfc_error ("Component to the right of a part reference "
4686 "with nonzero rank must not have the ALLOCATABLE "
4687 "attribute at %L", &expr
->where
);
4699 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4700 || ref
->next
== NULL
)
4701 && current_part_dimension
4702 && seen_part_dimension
)
4704 gfc_error ("Two or more part references with nonzero rank must "
4705 "not be specified at %L", &expr
->where
);
4709 if (ref
->type
== REF_COMPONENT
)
4711 if (current_part_dimension
)
4712 seen_part_dimension
= 1;
4714 /* reset to make sure */
4715 current_part_dimension
= 0;
4723 /* Given an expression, determine its shape. This is easier than it sounds.
4724 Leaves the shape array NULL if it is not possible to determine the shape. */
4727 expression_shape (gfc_expr
*e
)
4729 mpz_t array
[GFC_MAX_DIMENSIONS
];
4732 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4735 for (i
= 0; i
< e
->rank
; i
++)
4736 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4739 e
->shape
= gfc_get_shape (e
->rank
);
4741 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4746 for (i
--; i
>= 0; i
--)
4747 mpz_clear (array
[i
]);
4751 /* Given a variable expression node, compute the rank of the expression by
4752 examining the base symbol and any reference structures it may have. */
4755 expression_rank (gfc_expr
*e
)
4760 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4761 could lead to serious confusion... */
4762 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4766 if (e
->expr_type
== EXPR_ARRAY
)
4768 /* Constructors can have a rank different from one via RESHAPE(). */
4770 if (e
->symtree
== NULL
)
4776 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4777 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4783 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4785 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4786 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4787 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4789 if (ref
->type
!= REF_ARRAY
)
4792 if (ref
->u
.ar
.type
== AR_FULL
)
4794 rank
= ref
->u
.ar
.as
->rank
;
4798 if (ref
->u
.ar
.type
== AR_SECTION
)
4800 /* Figure out the rank of the section. */
4802 gfc_internal_error ("expression_rank(): Two array specs");
4804 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4805 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4806 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4816 expression_shape (e
);
4821 add_caf_get_intrinsic (gfc_expr
*e
)
4823 gfc_expr
*wrapper
, *tmp_expr
;
4827 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4828 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4833 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4834 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4837 tmp_expr
= XCNEW (gfc_expr
);
4839 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4840 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4841 wrapper
->ts
= e
->ts
;
4842 wrapper
->rank
= e
->rank
;
4844 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4851 remove_caf_get_intrinsic (gfc_expr
*e
)
4853 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4854 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4855 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4856 e
->value
.function
.actual
->expr
= NULL
;
4857 gfc_free_actual_arglist (e
->value
.function
.actual
);
4858 gfc_free_shape (&e
->shape
, e
->rank
);
4864 /* Resolve a variable expression. */
4867 resolve_variable (gfc_expr
*e
)
4874 if (e
->symtree
== NULL
)
4876 sym
= e
->symtree
->n
.sym
;
4878 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4879 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4880 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4882 if (!actual_arg
|| inquiry_argument
)
4884 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4885 "be used as actual argument", sym
->name
, &e
->where
);
4889 /* TS 29113, 407b. */
4890 else if (e
->ts
.type
== BT_ASSUMED
)
4894 gfc_error ("Assumed-type variable %s at %L may only be used "
4895 "as actual argument", sym
->name
, &e
->where
);
4898 else if (inquiry_argument
&& !first_actual_arg
)
4900 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4901 for all inquiry functions in resolve_function; the reason is
4902 that the function-name resolution happens too late in that
4904 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4905 "an inquiry function shall be the first argument",
4906 sym
->name
, &e
->where
);
4910 /* TS 29113, C535b. */
4911 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4912 && CLASS_DATA (sym
)->as
4913 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4914 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4915 && sym
->as
->type
== AS_ASSUMED_RANK
))
4919 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4920 "actual argument", sym
->name
, &e
->where
);
4923 else if (inquiry_argument
&& !first_actual_arg
)
4925 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4926 for all inquiry functions in resolve_function; the reason is
4927 that the function-name resolution happens too late in that
4929 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4930 "to an inquiry function shall be the first argument",
4931 sym
->name
, &e
->where
);
4936 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4937 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4938 && e
->ref
->next
== NULL
))
4940 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4941 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4944 /* TS 29113, 407b. */
4945 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4946 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4947 && e
->ref
->next
== NULL
))
4949 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4950 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4954 /* TS 29113, C535b. */
4955 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4956 && CLASS_DATA (sym
)->as
4957 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4958 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4959 && sym
->as
->type
== AS_ASSUMED_RANK
))
4961 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4962 && e
->ref
->next
== NULL
))
4964 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4965 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4969 /* For variables that are used in an associate (target => object) where
4970 the object's basetype is array valued while the target is scalar,
4971 the ts' type of the component refs is still array valued, which
4972 can't be translated that way. */
4973 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
4974 && sym
->assoc
->target
->ts
.type
== BT_CLASS
4975 && CLASS_DATA (sym
->assoc
->target
)->as
)
4977 gfc_ref
*ref
= e
->ref
;
4983 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
4984 /* Stop the loop. */
4994 /* If this is an associate-name, it may be parsed with an array reference
4995 in error even though the target is scalar. Fail directly in this case.
4996 TODO Understand why class scalar expressions must be excluded. */
4997 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4999 if (sym
->ts
.type
== BT_CLASS
)
5000 gfc_fix_class_refs (e
);
5001 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5005 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5006 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5008 /* On the other hand, the parser may not have known this is an array;
5009 in this case, we have to add a FULL reference. */
5010 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5012 e
->ref
= gfc_get_ref ();
5013 e
->ref
->type
= REF_ARRAY
;
5014 e
->ref
->u
.ar
.type
= AR_FULL
;
5015 e
->ref
->u
.ar
.dimen
= 0;
5018 /* Like above, but for class types, where the checking whether an array
5019 ref is present is more complicated. Furthermore make sure not to add
5020 the full array ref to _vptr or _len refs. */
5021 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5022 && CLASS_DATA (sym
)->attr
.dimension
5023 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5025 gfc_ref
*ref
, *newref
;
5027 newref
= gfc_get_ref ();
5028 newref
->type
= REF_ARRAY
;
5029 newref
->u
.ar
.type
= AR_FULL
;
5030 newref
->u
.ar
.dimen
= 0;
5031 /* Because this is an associate var and the first ref either is a ref to
5032 the _data component or not, no traversal of the ref chain is
5033 needed. The array ref needs to be inserted after the _data ref,
5034 or when that is not present, which may happend for polymorphic
5035 types, then at the first position. */
5039 else if (ref
->type
== REF_COMPONENT
5040 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5042 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5044 newref
->next
= ref
->next
;
5048 /* Array ref present already. */
5049 gfc_free_ref_list (newref
);
5051 else if (ref
->type
== REF_ARRAY
)
5052 /* Array ref present already. */
5053 gfc_free_ref_list (newref
);
5061 if (e
->ref
&& !resolve_ref (e
))
5064 if (sym
->attr
.flavor
== FL_PROCEDURE
5065 && (!sym
->attr
.function
5066 || (sym
->attr
.function
&& sym
->result
5067 && sym
->result
->attr
.proc_pointer
5068 && !sym
->result
->attr
.function
)))
5070 e
->ts
.type
= BT_PROCEDURE
;
5071 goto resolve_procedure
;
5074 if (sym
->ts
.type
!= BT_UNKNOWN
)
5075 gfc_variable_attr (e
, &e
->ts
);
5078 /* Must be a simple variable reference. */
5079 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5084 if (check_assumed_size_reference (sym
, e
))
5087 /* Deal with forward references to entries during gfc_resolve_code, to
5088 satisfy, at least partially, 12.5.2.5. */
5089 if (gfc_current_ns
->entries
5090 && current_entry_id
== sym
->entry_id
5093 && cs_base
->current
->op
!= EXEC_ENTRY
)
5095 gfc_entry_list
*entry
;
5096 gfc_formal_arglist
*formal
;
5098 bool seen
, saved_specification_expr
;
5100 /* If the symbol is a dummy... */
5101 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5103 entry
= gfc_current_ns
->entries
;
5106 /* ...test if the symbol is a parameter of previous entries. */
5107 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5108 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5110 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5117 /* If it has not been seen as a dummy, this is an error. */
5120 if (specification_expr
)
5121 gfc_error ("Variable %qs, used in a specification expression"
5122 ", is referenced at %L before the ENTRY statement "
5123 "in which it is a parameter",
5124 sym
->name
, &cs_base
->current
->loc
);
5126 gfc_error ("Variable %qs is used at %L before the ENTRY "
5127 "statement in which it is a parameter",
5128 sym
->name
, &cs_base
->current
->loc
);
5133 /* Now do the same check on the specification expressions. */
5134 saved_specification_expr
= specification_expr
;
5135 specification_expr
= true;
5136 if (sym
->ts
.type
== BT_CHARACTER
5137 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5141 for (n
= 0; n
< sym
->as
->rank
; n
++)
5143 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5145 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5148 specification_expr
= saved_specification_expr
;
5151 /* Update the symbol's entry level. */
5152 sym
->entry_id
= current_entry_id
+ 1;
5155 /* If a symbol has been host_associated mark it. This is used latter,
5156 to identify if aliasing is possible via host association. */
5157 if (sym
->attr
.flavor
== FL_VARIABLE
5158 && gfc_current_ns
->parent
5159 && (gfc_current_ns
->parent
== sym
->ns
5160 || (gfc_current_ns
->parent
->parent
5161 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5162 sym
->attr
.host_assoc
= 1;
5164 if (gfc_current_ns
->proc_name
5165 && sym
->attr
.dimension
5166 && (sym
->ns
!= gfc_current_ns
5167 || sym
->attr
.use_assoc
5168 || sym
->attr
.in_common
))
5169 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5172 if (t
&& !resolve_procedure_expression (e
))
5175 /* F2008, C617 and C1229. */
5176 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5177 && gfc_is_coindexed (e
))
5179 gfc_ref
*ref
, *ref2
= NULL
;
5181 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5183 if (ref
->type
== REF_COMPONENT
)
5185 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5189 for ( ; ref
; ref
= ref
->next
)
5190 if (ref
->type
== REF_COMPONENT
)
5193 /* Expression itself is not coindexed object. */
5194 if (ref
&& e
->ts
.type
== BT_CLASS
)
5196 gfc_error ("Polymorphic subobject of coindexed object at %L",
5201 /* Expression itself is coindexed object. */
5205 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5206 for ( ; c
; c
= c
->next
)
5207 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5209 gfc_error ("Coindexed object with polymorphic allocatable "
5210 "subcomponent at %L", &e
->where
);
5218 expression_rank (e
);
5220 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5221 add_caf_get_intrinsic (e
);
5227 /* Checks to see that the correct symbol has been host associated.
5228 The only situation where this arises is that in which a twice
5229 contained function is parsed after the host association is made.
5230 Therefore, on detecting this, change the symbol in the expression
5231 and convert the array reference into an actual arglist if the old
5232 symbol is a variable. */
5234 check_host_association (gfc_expr
*e
)
5236 gfc_symbol
*sym
, *old_sym
;
5240 gfc_actual_arglist
*arg
, *tail
= NULL
;
5241 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5243 /* If the expression is the result of substitution in
5244 interface.c(gfc_extend_expr) because there is no way in
5245 which the host association can be wrong. */
5246 if (e
->symtree
== NULL
5247 || e
->symtree
->n
.sym
== NULL
5248 || e
->user_operator
)
5251 old_sym
= e
->symtree
->n
.sym
;
5253 if (gfc_current_ns
->parent
5254 && old_sym
->ns
!= gfc_current_ns
)
5256 /* Use the 'USE' name so that renamed module symbols are
5257 correctly handled. */
5258 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5260 if (sym
&& old_sym
!= sym
5261 && sym
->ts
.type
== old_sym
->ts
.type
5262 && sym
->attr
.flavor
== FL_PROCEDURE
5263 && sym
->attr
.contained
)
5265 /* Clear the shape, since it might not be valid. */
5266 gfc_free_shape (&e
->shape
, e
->rank
);
5268 /* Give the expression the right symtree! */
5269 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5270 gcc_assert (st
!= NULL
);
5272 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5273 || e
->expr_type
== EXPR_FUNCTION
)
5275 /* Original was function so point to the new symbol, since
5276 the actual argument list is already attached to the
5278 e
->value
.function
.esym
= NULL
;
5283 /* Original was variable so convert array references into
5284 an actual arglist. This does not need any checking now
5285 since resolve_function will take care of it. */
5286 e
->value
.function
.actual
= NULL
;
5287 e
->expr_type
= EXPR_FUNCTION
;
5290 /* Ambiguity will not arise if the array reference is not
5291 the last reference. */
5292 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5293 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5296 gcc_assert (ref
->type
== REF_ARRAY
);
5298 /* Grab the start expressions from the array ref and
5299 copy them into actual arguments. */
5300 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5302 arg
= gfc_get_actual_arglist ();
5303 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5304 if (e
->value
.function
.actual
== NULL
)
5305 tail
= e
->value
.function
.actual
= arg
;
5313 /* Dump the reference list and set the rank. */
5314 gfc_free_ref_list (e
->ref
);
5316 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5319 gfc_resolve_expr (e
);
5323 /* This might have changed! */
5324 return e
->expr_type
== EXPR_FUNCTION
;
5329 gfc_resolve_character_operator (gfc_expr
*e
)
5331 gfc_expr
*op1
= e
->value
.op
.op1
;
5332 gfc_expr
*op2
= e
->value
.op
.op2
;
5333 gfc_expr
*e1
= NULL
;
5334 gfc_expr
*e2
= NULL
;
5336 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5338 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5339 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5340 else if (op1
->expr_type
== EXPR_CONSTANT
)
5341 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5342 op1
->value
.character
.length
);
5344 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5345 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5346 else if (op2
->expr_type
== EXPR_CONSTANT
)
5347 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5348 op2
->value
.character
.length
);
5350 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5360 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5361 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5362 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5363 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5364 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5370 /* Ensure that an character expression has a charlen and, if possible, a
5371 length expression. */
5374 fixup_charlen (gfc_expr
*e
)
5376 /* The cases fall through so that changes in expression type and the need
5377 for multiple fixes are picked up. In all circumstances, a charlen should
5378 be available for the middle end to hang a backend_decl on. */
5379 switch (e
->expr_type
)
5382 gfc_resolve_character_operator (e
);
5385 if (e
->expr_type
== EXPR_ARRAY
)
5386 gfc_resolve_character_array_constructor (e
);
5388 case EXPR_SUBSTRING
:
5389 if (!e
->ts
.u
.cl
&& e
->ref
)
5390 gfc_resolve_substring_charlen (e
);
5394 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5401 /* Update an actual argument to include the passed-object for type-bound
5402 procedures at the right position. */
5404 static gfc_actual_arglist
*
5405 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5408 gcc_assert (argpos
> 0);
5412 gfc_actual_arglist
* result
;
5414 result
= gfc_get_actual_arglist ();
5418 result
->name
= name
;
5424 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5426 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5431 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5434 extract_compcall_passed_object (gfc_expr
* e
)
5438 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5440 if (e
->value
.compcall
.base_object
)
5441 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5444 po
= gfc_get_expr ();
5445 po
->expr_type
= EXPR_VARIABLE
;
5446 po
->symtree
= e
->symtree
;
5447 po
->ref
= gfc_copy_ref (e
->ref
);
5448 po
->where
= e
->where
;
5451 if (!gfc_resolve_expr (po
))
5458 /* Update the arglist of an EXPR_COMPCALL expression to include the
5462 update_compcall_arglist (gfc_expr
* e
)
5465 gfc_typebound_proc
* tbp
;
5467 tbp
= e
->value
.compcall
.tbp
;
5472 po
= extract_compcall_passed_object (e
);
5476 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5482 gcc_assert (tbp
->pass_arg_num
> 0);
5483 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5491 /* Extract the passed object from a PPC call (a copy of it). */
5494 extract_ppc_passed_object (gfc_expr
*e
)
5499 po
= gfc_get_expr ();
5500 po
->expr_type
= EXPR_VARIABLE
;
5501 po
->symtree
= e
->symtree
;
5502 po
->ref
= gfc_copy_ref (e
->ref
);
5503 po
->where
= e
->where
;
5505 /* Remove PPC reference. */
5507 while ((*ref
)->next
)
5508 ref
= &(*ref
)->next
;
5509 gfc_free_ref_list (*ref
);
5512 if (!gfc_resolve_expr (po
))
5519 /* Update the actual arglist of a procedure pointer component to include the
5523 update_ppc_arglist (gfc_expr
* e
)
5527 gfc_typebound_proc
* tb
;
5529 ppc
= gfc_get_proc_ptr_comp (e
);
5537 else if (tb
->nopass
)
5540 po
= extract_ppc_passed_object (e
);
5547 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5552 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5554 gfc_error ("Base object for procedure-pointer component call at %L is of"
5555 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5559 gcc_assert (tb
->pass_arg_num
> 0);
5560 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5568 /* Check that the object a TBP is called on is valid, i.e. it must not be
5569 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5572 check_typebound_baseobject (gfc_expr
* e
)
5575 bool return_value
= false;
5577 base
= extract_compcall_passed_object (e
);
5581 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5583 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5587 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5589 gfc_error ("Base object for type-bound procedure call at %L is of"
5590 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5594 /* F08:C1230. If the procedure called is NOPASS,
5595 the base object must be scalar. */
5596 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5598 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5599 " be scalar", &e
->where
);
5603 return_value
= true;
5606 gfc_free_expr (base
);
5607 return return_value
;
5611 /* Resolve a call to a type-bound procedure, either function or subroutine,
5612 statically from the data in an EXPR_COMPCALL expression. The adapted
5613 arglist and the target-procedure symtree are returned. */
5616 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5617 gfc_actual_arglist
** actual
)
5619 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5620 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5622 /* Update the actual arglist for PASS. */
5623 if (!update_compcall_arglist (e
))
5626 *actual
= e
->value
.compcall
.actual
;
5627 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5629 gfc_free_ref_list (e
->ref
);
5631 e
->value
.compcall
.actual
= NULL
;
5633 /* If we find a deferred typebound procedure, check for derived types
5634 that an overriding typebound procedure has not been missed. */
5635 if (e
->value
.compcall
.name
5636 && !e
->value
.compcall
.tbp
->non_overridable
5637 && e
->value
.compcall
.base_object
5638 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5641 gfc_symbol
*derived
;
5643 /* Use the derived type of the base_object. */
5644 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5647 /* If necessary, go through the inheritance chain. */
5648 while (!st
&& derived
)
5650 /* Look for the typebound procedure 'name'. */
5651 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5652 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5653 e
->value
.compcall
.name
);
5655 derived
= gfc_get_derived_super_type (derived
);
5658 /* Now find the specific name in the derived type namespace. */
5659 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5660 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5661 derived
->ns
, 1, &st
);
5669 /* Get the ultimate declared type from an expression. In addition,
5670 return the last class/derived type reference and the copy of the
5671 reference list. If check_types is set true, derived types are
5672 identified as well as class references. */
5674 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5675 gfc_expr
*e
, bool check_types
)
5677 gfc_symbol
*declared
;
5684 *new_ref
= gfc_copy_ref (e
->ref
);
5686 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5688 if (ref
->type
!= REF_COMPONENT
)
5691 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5692 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5693 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5695 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5701 if (declared
== NULL
)
5702 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5708 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5709 which of the specific bindings (if any) matches the arglist and transform
5710 the expression into a call of that binding. */
5713 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5715 gfc_typebound_proc
* genproc
;
5716 const char* genname
;
5718 gfc_symbol
*derived
;
5720 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5721 genname
= e
->value
.compcall
.name
;
5722 genproc
= e
->value
.compcall
.tbp
;
5724 if (!genproc
->is_generic
)
5727 /* Try the bindings on this type and in the inheritance hierarchy. */
5728 for (; genproc
; genproc
= genproc
->overridden
)
5732 gcc_assert (genproc
->is_generic
);
5733 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5736 gfc_actual_arglist
* args
;
5739 gcc_assert (g
->specific
);
5741 if (g
->specific
->error
)
5744 target
= g
->specific
->u
.specific
->n
.sym
;
5746 /* Get the right arglist by handling PASS/NOPASS. */
5747 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5748 if (!g
->specific
->nopass
)
5751 po
= extract_compcall_passed_object (e
);
5754 gfc_free_actual_arglist (args
);
5758 gcc_assert (g
->specific
->pass_arg_num
> 0);
5759 gcc_assert (!g
->specific
->error
);
5760 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5761 g
->specific
->pass_arg
);
5763 resolve_actual_arglist (args
, target
->attr
.proc
,
5764 is_external_proc (target
)
5765 && gfc_sym_get_dummy_args (target
) == NULL
);
5767 /* Check if this arglist matches the formal. */
5768 matches
= gfc_arglist_matches_symbol (&args
, target
);
5770 /* Clean up and break out of the loop if we've found it. */
5771 gfc_free_actual_arglist (args
);
5774 e
->value
.compcall
.tbp
= g
->specific
;
5775 genname
= g
->specific_st
->name
;
5776 /* Pass along the name for CLASS methods, where the vtab
5777 procedure pointer component has to be referenced. */
5785 /* Nothing matching found! */
5786 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5787 " %qs at %L", genname
, &e
->where
);
5791 /* Make sure that we have the right specific instance for the name. */
5792 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5794 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5796 e
->value
.compcall
.tbp
= st
->n
.tb
;
5802 /* Resolve a call to a type-bound subroutine. */
5805 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5807 gfc_actual_arglist
* newactual
;
5808 gfc_symtree
* target
;
5810 /* Check that's really a SUBROUTINE. */
5811 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5813 gfc_error ("%qs at %L should be a SUBROUTINE",
5814 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5818 if (!check_typebound_baseobject (c
->expr1
))
5821 /* Pass along the name for CLASS methods, where the vtab
5822 procedure pointer component has to be referenced. */
5824 *name
= c
->expr1
->value
.compcall
.name
;
5826 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5829 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5831 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5833 /* Transform into an ordinary EXEC_CALL for now. */
5835 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5838 c
->ext
.actual
= newactual
;
5839 c
->symtree
= target
;
5840 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5842 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5844 gfc_free_expr (c
->expr1
);
5845 c
->expr1
= gfc_get_expr ();
5846 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5847 c
->expr1
->symtree
= target
;
5848 c
->expr1
->where
= c
->loc
;
5850 return resolve_call (c
);
5854 /* Resolve a component-call expression. */
5856 resolve_compcall (gfc_expr
* e
, const char **name
)
5858 gfc_actual_arglist
* newactual
;
5859 gfc_symtree
* target
;
5861 /* Check that's really a FUNCTION. */
5862 if (!e
->value
.compcall
.tbp
->function
)
5864 gfc_error ("%qs at %L should be a FUNCTION",
5865 e
->value
.compcall
.name
, &e
->where
);
5869 /* These must not be assign-calls! */
5870 gcc_assert (!e
->value
.compcall
.assign
);
5872 if (!check_typebound_baseobject (e
))
5875 /* Pass along the name for CLASS methods, where the vtab
5876 procedure pointer component has to be referenced. */
5878 *name
= e
->value
.compcall
.name
;
5880 if (!resolve_typebound_generic_call (e
, name
))
5882 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5884 /* Take the rank from the function's symbol. */
5885 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5886 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5888 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5889 arglist to the TBP's binding target. */
5891 if (!resolve_typebound_static (e
, &target
, &newactual
))
5894 e
->value
.function
.actual
= newactual
;
5895 e
->value
.function
.name
= NULL
;
5896 e
->value
.function
.esym
= target
->n
.sym
;
5897 e
->value
.function
.isym
= NULL
;
5898 e
->symtree
= target
;
5899 e
->ts
= target
->n
.sym
->ts
;
5900 e
->expr_type
= EXPR_FUNCTION
;
5902 /* Resolution is not necessary if this is a class subroutine; this
5903 function only has to identify the specific proc. Resolution of
5904 the call will be done next in resolve_typebound_call. */
5905 return gfc_resolve_expr (e
);
5909 static bool resolve_fl_derived (gfc_symbol
*sym
);
5912 /* Resolve a typebound function, or 'method'. First separate all
5913 the non-CLASS references by calling resolve_compcall directly. */
5916 resolve_typebound_function (gfc_expr
* e
)
5918 gfc_symbol
*declared
;
5930 /* Deal with typebound operators for CLASS objects. */
5931 expr
= e
->value
.compcall
.base_object
;
5932 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5933 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5935 /* If the base_object is not a variable, the corresponding actual
5936 argument expression must be stored in e->base_expression so
5937 that the corresponding tree temporary can be used as the base
5938 object in gfc_conv_procedure_call. */
5939 if (expr
->expr_type
!= EXPR_VARIABLE
)
5941 gfc_actual_arglist
*args
;
5943 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5945 if (expr
== args
->expr
)
5950 /* Since the typebound operators are generic, we have to ensure
5951 that any delays in resolution are corrected and that the vtab
5954 declared
= ts
.u
.derived
;
5955 c
= gfc_find_component (declared
, "_vptr", true, true);
5956 if (c
->ts
.u
.derived
== NULL
)
5957 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5959 if (!resolve_compcall (e
, &name
))
5962 /* Use the generic name if it is there. */
5963 name
= name
? name
: e
->value
.function
.esym
->name
;
5964 e
->symtree
= expr
->symtree
;
5965 e
->ref
= gfc_copy_ref (expr
->ref
);
5966 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5968 /* Trim away the extraneous references that emerge from nested
5969 use of interface.c (extend_expr). */
5970 if (class_ref
&& class_ref
->next
)
5972 gfc_free_ref_list (class_ref
->next
);
5973 class_ref
->next
= NULL
;
5975 else if (e
->ref
&& !class_ref
)
5977 gfc_free_ref_list (e
->ref
);
5981 gfc_add_vptr_component (e
);
5982 gfc_add_component_ref (e
, name
);
5983 e
->value
.function
.esym
= NULL
;
5984 if (expr
->expr_type
!= EXPR_VARIABLE
)
5985 e
->base_expr
= expr
;
5990 return resolve_compcall (e
, NULL
);
5992 if (!resolve_ref (e
))
5995 /* Get the CLASS declared type. */
5996 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5998 if (!resolve_fl_derived (declared
))
6001 /* Weed out cases of the ultimate component being a derived type. */
6002 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6003 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6005 gfc_free_ref_list (new_ref
);
6006 return resolve_compcall (e
, NULL
);
6009 c
= gfc_find_component (declared
, "_data", true, true);
6010 declared
= c
->ts
.u
.derived
;
6012 /* Treat the call as if it is a typebound procedure, in order to roll
6013 out the correct name for the specific function. */
6014 if (!resolve_compcall (e
, &name
))
6016 gfc_free_ref_list (new_ref
);
6023 /* Convert the expression to a procedure pointer component call. */
6024 e
->value
.function
.esym
= NULL
;
6030 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6031 gfc_add_vptr_component (e
);
6032 gfc_add_component_ref (e
, name
);
6034 /* Recover the typespec for the expression. This is really only
6035 necessary for generic procedures, where the additional call
6036 to gfc_add_component_ref seems to throw the collection of the
6037 correct typespec. */
6041 gfc_free_ref_list (new_ref
);
6046 /* Resolve a typebound subroutine, or 'method'. First separate all
6047 the non-CLASS references by calling resolve_typebound_call
6051 resolve_typebound_subroutine (gfc_code
*code
)
6053 gfc_symbol
*declared
;
6063 st
= code
->expr1
->symtree
;
6065 /* Deal with typebound operators for CLASS objects. */
6066 expr
= code
->expr1
->value
.compcall
.base_object
;
6067 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6068 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6070 /* If the base_object is not a variable, the corresponding actual
6071 argument expression must be stored in e->base_expression so
6072 that the corresponding tree temporary can be used as the base
6073 object in gfc_conv_procedure_call. */
6074 if (expr
->expr_type
!= EXPR_VARIABLE
)
6076 gfc_actual_arglist
*args
;
6078 args
= code
->expr1
->value
.function
.actual
;
6079 for (; args
; args
= args
->next
)
6080 if (expr
== args
->expr
)
6084 /* Since the typebound operators are generic, we have to ensure
6085 that any delays in resolution are corrected and that the vtab
6087 declared
= expr
->ts
.u
.derived
;
6088 c
= gfc_find_component (declared
, "_vptr", true, true);
6089 if (c
->ts
.u
.derived
== NULL
)
6090 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6092 if (!resolve_typebound_call (code
, &name
, NULL
))
6095 /* Use the generic name if it is there. */
6096 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6097 code
->expr1
->symtree
= expr
->symtree
;
6098 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6100 /* Trim away the extraneous references that emerge from nested
6101 use of interface.c (extend_expr). */
6102 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6103 if (class_ref
&& class_ref
->next
)
6105 gfc_free_ref_list (class_ref
->next
);
6106 class_ref
->next
= NULL
;
6108 else if (code
->expr1
->ref
&& !class_ref
)
6110 gfc_free_ref_list (code
->expr1
->ref
);
6111 code
->expr1
->ref
= NULL
;
6114 /* Now use the procedure in the vtable. */
6115 gfc_add_vptr_component (code
->expr1
);
6116 gfc_add_component_ref (code
->expr1
, name
);
6117 code
->expr1
->value
.function
.esym
= NULL
;
6118 if (expr
->expr_type
!= EXPR_VARIABLE
)
6119 code
->expr1
->base_expr
= expr
;
6124 return resolve_typebound_call (code
, NULL
, NULL
);
6126 if (!resolve_ref (code
->expr1
))
6129 /* Get the CLASS declared type. */
6130 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6132 /* Weed out cases of the ultimate component being a derived type. */
6133 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6134 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6136 gfc_free_ref_list (new_ref
);
6137 return resolve_typebound_call (code
, NULL
, NULL
);
6140 if (!resolve_typebound_call (code
, &name
, &overridable
))
6142 gfc_free_ref_list (new_ref
);
6145 ts
= code
->expr1
->ts
;
6149 /* Convert the expression to a procedure pointer component call. */
6150 code
->expr1
->value
.function
.esym
= NULL
;
6151 code
->expr1
->symtree
= st
;
6154 code
->expr1
->ref
= new_ref
;
6156 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6157 gfc_add_vptr_component (code
->expr1
);
6158 gfc_add_component_ref (code
->expr1
, name
);
6160 /* Recover the typespec for the expression. This is really only
6161 necessary for generic procedures, where the additional call
6162 to gfc_add_component_ref seems to throw the collection of the
6163 correct typespec. */
6164 code
->expr1
->ts
= ts
;
6167 gfc_free_ref_list (new_ref
);
6173 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6176 resolve_ppc_call (gfc_code
* c
)
6178 gfc_component
*comp
;
6180 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6181 gcc_assert (comp
!= NULL
);
6183 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6184 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6186 if (!comp
->attr
.subroutine
)
6187 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6189 if (!resolve_ref (c
->expr1
))
6192 if (!update_ppc_arglist (c
->expr1
))
6195 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6197 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6198 !(comp
->ts
.interface
6199 && comp
->ts
.interface
->formal
)))
6202 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6205 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6211 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6214 resolve_expr_ppc (gfc_expr
* e
)
6216 gfc_component
*comp
;
6218 comp
= gfc_get_proc_ptr_comp (e
);
6219 gcc_assert (comp
!= NULL
);
6221 /* Convert to EXPR_FUNCTION. */
6222 e
->expr_type
= EXPR_FUNCTION
;
6223 e
->value
.function
.isym
= NULL
;
6224 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6226 if (comp
->as
!= NULL
)
6227 e
->rank
= comp
->as
->rank
;
6229 if (!comp
->attr
.function
)
6230 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6232 if (!resolve_ref (e
))
6235 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6236 !(comp
->ts
.interface
6237 && comp
->ts
.interface
->formal
)))
6240 if (!update_ppc_arglist (e
))
6243 if (!check_pure_function(e
))
6246 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6253 gfc_is_expandable_expr (gfc_expr
*e
)
6255 gfc_constructor
*con
;
6257 if (e
->expr_type
== EXPR_ARRAY
)
6259 /* Traverse the constructor looking for variables that are flavor
6260 parameter. Parameters must be expanded since they are fully used at
6262 con
= gfc_constructor_first (e
->value
.constructor
);
6263 for (; con
; con
= gfc_constructor_next (con
))
6265 if (con
->expr
->expr_type
== EXPR_VARIABLE
6266 && con
->expr
->symtree
6267 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6268 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6270 if (con
->expr
->expr_type
== EXPR_ARRAY
6271 && gfc_is_expandable_expr (con
->expr
))
6279 /* Resolve an expression. That is, make sure that types of operands agree
6280 with their operators, intrinsic operators are converted to function calls
6281 for overloaded types and unresolved function references are resolved. */
6284 gfc_resolve_expr (gfc_expr
*e
)
6287 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6292 /* inquiry_argument only applies to variables. */
6293 inquiry_save
= inquiry_argument
;
6294 actual_arg_save
= actual_arg
;
6295 first_actual_arg_save
= first_actual_arg
;
6297 if (e
->expr_type
!= EXPR_VARIABLE
)
6299 inquiry_argument
= false;
6301 first_actual_arg
= false;
6304 switch (e
->expr_type
)
6307 t
= resolve_operator (e
);
6313 if (check_host_association (e
))
6314 t
= resolve_function (e
);
6316 t
= resolve_variable (e
);
6318 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6319 && e
->ref
->type
!= REF_SUBSTRING
)
6320 gfc_resolve_substring_charlen (e
);
6325 t
= resolve_typebound_function (e
);
6328 case EXPR_SUBSTRING
:
6329 t
= resolve_ref (e
);
6338 t
= resolve_expr_ppc (e
);
6343 if (!resolve_ref (e
))
6346 t
= gfc_resolve_array_constructor (e
);
6347 /* Also try to expand a constructor. */
6350 expression_rank (e
);
6351 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6352 gfc_expand_constructor (e
, false);
6355 /* This provides the opportunity for the length of constructors with
6356 character valued function elements to propagate the string length
6357 to the expression. */
6358 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6360 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6361 here rather then add a duplicate test for it above. */
6362 gfc_expand_constructor (e
, false);
6363 t
= gfc_resolve_character_array_constructor (e
);
6368 case EXPR_STRUCTURE
:
6369 t
= resolve_ref (e
);
6373 t
= resolve_structure_cons (e
, 0);
6377 t
= gfc_simplify_expr (e
, 0);
6381 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6384 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6387 inquiry_argument
= inquiry_save
;
6388 actual_arg
= actual_arg_save
;
6389 first_actual_arg
= first_actual_arg_save
;
6395 /* Resolve an expression from an iterator. They must be scalar and have
6396 INTEGER or (optionally) REAL type. */
6399 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6400 const char *name_msgid
)
6402 if (!gfc_resolve_expr (expr
))
6405 if (expr
->rank
!= 0)
6407 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6411 if (expr
->ts
.type
!= BT_INTEGER
)
6413 if (expr
->ts
.type
== BT_REAL
)
6416 return gfc_notify_std (GFC_STD_F95_DEL
,
6417 "%s at %L must be integer",
6418 _(name_msgid
), &expr
->where
);
6421 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6428 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6436 /* Resolve the expressions in an iterator structure. If REAL_OK is
6437 false allow only INTEGER type iterators, otherwise allow REAL types.
6438 Set own_scope to true for ac-implied-do and data-implied-do as those
6439 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6442 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6444 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6447 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6448 _("iterator variable")))
6451 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6452 "Start expression in DO loop"))
6455 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6456 "End expression in DO loop"))
6459 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6460 "Step expression in DO loop"))
6463 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6465 if ((iter
->step
->ts
.type
== BT_INTEGER
6466 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6467 || (iter
->step
->ts
.type
== BT_REAL
6468 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6470 gfc_error ("Step expression in DO loop at %L cannot be zero",
6471 &iter
->step
->where
);
6476 /* Convert start, end, and step to the same type as var. */
6477 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6478 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6479 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6481 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6482 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6483 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6485 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6486 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6487 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6489 if (iter
->start
->expr_type
== EXPR_CONSTANT
6490 && iter
->end
->expr_type
== EXPR_CONSTANT
6491 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6494 if (iter
->start
->ts
.type
== BT_INTEGER
)
6496 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6497 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6501 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6502 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6504 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6505 gfc_warning (OPT_Wzerotrip
,
6506 "DO loop at %L will be executed zero times",
6507 &iter
->step
->where
);
6514 /* Traversal function for find_forall_index. f == 2 signals that
6515 that variable itself is not to be checked - only the references. */
6518 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6520 if (expr
->expr_type
!= EXPR_VARIABLE
)
6523 /* A scalar assignment */
6524 if (!expr
->ref
|| *f
== 1)
6526 if (expr
->symtree
->n
.sym
== sym
)
6538 /* Check whether the FORALL index appears in the expression or not.
6539 Returns true if SYM is found in EXPR. */
6542 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6544 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6551 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6552 to be a scalar INTEGER variable. The subscripts and stride are scalar
6553 INTEGERs, and if stride is a constant it must be nonzero.
6554 Furthermore "A subscript or stride in a forall-triplet-spec shall
6555 not contain a reference to any index-name in the
6556 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6559 resolve_forall_iterators (gfc_forall_iterator
*it
)
6561 gfc_forall_iterator
*iter
, *iter2
;
6563 for (iter
= it
; iter
; iter
= iter
->next
)
6565 if (gfc_resolve_expr (iter
->var
)
6566 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6567 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6570 if (gfc_resolve_expr (iter
->start
)
6571 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6572 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6573 &iter
->start
->where
);
6574 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6575 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6577 if (gfc_resolve_expr (iter
->end
)
6578 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6579 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6581 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6582 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6584 if (gfc_resolve_expr (iter
->stride
))
6586 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6587 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6588 &iter
->stride
->where
, "INTEGER");
6590 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6591 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6592 gfc_error ("FORALL stride expression at %L cannot be zero",
6593 &iter
->stride
->where
);
6595 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6596 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6599 for (iter
= it
; iter
; iter
= iter
->next
)
6600 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6602 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6603 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6604 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6605 gfc_error ("FORALL index %qs may not appear in triplet "
6606 "specification at %L", iter
->var
->symtree
->name
,
6607 &iter2
->start
->where
);
6612 /* Given a pointer to a symbol that is a derived type, see if it's
6613 inaccessible, i.e. if it's defined in another module and the components are
6614 PRIVATE. The search is recursive if necessary. Returns zero if no
6615 inaccessible components are found, nonzero otherwise. */
6618 derived_inaccessible (gfc_symbol
*sym
)
6622 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6625 for (c
= sym
->components
; c
; c
= c
->next
)
6627 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6635 /* Resolve the argument of a deallocate expression. The expression must be
6636 a pointer or a full array. */
6639 resolve_deallocate_expr (gfc_expr
*e
)
6641 symbol_attribute attr
;
6642 int allocatable
, pointer
;
6648 if (!gfc_resolve_expr (e
))
6651 if (e
->expr_type
!= EXPR_VARIABLE
)
6654 sym
= e
->symtree
->n
.sym
;
6655 unlimited
= UNLIMITED_POLY(sym
);
6657 if (sym
->ts
.type
== BT_CLASS
)
6659 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6660 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6664 allocatable
= sym
->attr
.allocatable
;
6665 pointer
= sym
->attr
.pointer
;
6667 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6672 if (ref
->u
.ar
.type
!= AR_FULL
6673 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6674 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6679 c
= ref
->u
.c
.component
;
6680 if (c
->ts
.type
== BT_CLASS
)
6682 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6683 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6687 allocatable
= c
->attr
.allocatable
;
6688 pointer
= c
->attr
.pointer
;
6698 attr
= gfc_expr_attr (e
);
6700 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6703 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6709 if (gfc_is_coindexed (e
))
6711 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6716 && !gfc_check_vardef_context (e
, true, true, false,
6717 _("DEALLOCATE object")))
6719 if (!gfc_check_vardef_context (e
, false, true, false,
6720 _("DEALLOCATE object")))
6727 /* Returns true if the expression e contains a reference to the symbol sym. */
6729 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6731 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6738 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6740 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6744 /* Given the expression node e for an allocatable/pointer of derived type to be
6745 allocated, get the expression node to be initialized afterwards (needed for
6746 derived types with default initializers, and derived types with allocatable
6747 components that need nullification.) */
6750 gfc_expr_to_initialize (gfc_expr
*e
)
6756 result
= gfc_copy_expr (e
);
6758 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6759 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6760 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6762 ref
->u
.ar
.type
= AR_FULL
;
6764 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6765 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6770 gfc_free_shape (&result
->shape
, result
->rank
);
6772 /* Recalculate rank, shape, etc. */
6773 gfc_resolve_expr (result
);
6778 /* If the last ref of an expression is an array ref, return a copy of the
6779 expression with that one removed. Otherwise, a copy of the original
6780 expression. This is used for allocate-expressions and pointer assignment
6781 LHS, where there may be an array specification that needs to be stripped
6782 off when using gfc_check_vardef_context. */
6785 remove_last_array_ref (gfc_expr
* e
)
6790 e2
= gfc_copy_expr (e
);
6791 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6792 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6794 gfc_free_ref_list (*r
);
6803 /* Used in resolve_allocate_expr to check that a allocation-object and
6804 a source-expr are conformable. This does not catch all possible
6805 cases; in particular a runtime checking is needed. */
6808 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6811 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6813 /* First compare rank. */
6814 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6815 || (!tail
&& e1
->rank
!= e2
->rank
))
6817 gfc_error ("Source-expr at %L must be scalar or have the "
6818 "same rank as the allocate-object at %L",
6819 &e1
->where
, &e2
->where
);
6830 for (i
= 0; i
< e1
->rank
; i
++)
6832 if (tail
->u
.ar
.start
[i
] == NULL
)
6835 if (tail
->u
.ar
.end
[i
])
6837 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6838 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6839 mpz_add_ui (s
, s
, 1);
6843 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6846 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6848 gfc_error ("Source-expr at %L and allocate-object at %L must "
6849 "have the same shape", &e1
->where
, &e2
->where
);
6862 /* Resolve the expression in an ALLOCATE statement, doing the additional
6863 checks to see whether the expression is OK or not. The expression must
6864 have a trailing array reference that gives the size of the array. */
6867 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
6869 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6873 symbol_attribute attr
;
6874 gfc_ref
*ref
, *ref2
;
6877 gfc_symbol
*sym
= NULL
;
6882 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6883 checking of coarrays. */
6884 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6885 if (ref
->next
== NULL
)
6888 if (ref
&& ref
->type
== REF_ARRAY
)
6889 ref
->u
.ar
.in_allocate
= true;
6891 if (!gfc_resolve_expr (e
))
6894 /* Make sure the expression is allocatable or a pointer. If it is
6895 pointer, the next-to-last reference must be a pointer. */
6899 sym
= e
->symtree
->n
.sym
;
6901 /* Check whether ultimate component is abstract and CLASS. */
6904 /* Is the allocate-object unlimited polymorphic? */
6905 unlimited
= UNLIMITED_POLY(e
);
6907 if (e
->expr_type
!= EXPR_VARIABLE
)
6910 attr
= gfc_expr_attr (e
);
6911 pointer
= attr
.pointer
;
6912 dimension
= attr
.dimension
;
6913 codimension
= attr
.codimension
;
6917 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6919 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6920 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6921 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6922 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6923 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6927 allocatable
= sym
->attr
.allocatable
;
6928 pointer
= sym
->attr
.pointer
;
6929 dimension
= sym
->attr
.dimension
;
6930 codimension
= sym
->attr
.codimension
;
6935 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6940 if (ref
->u
.ar
.codimen
> 0)
6943 for (n
= ref
->u
.ar
.dimen
;
6944 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6945 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6952 if (ref
->next
!= NULL
)
6960 gfc_error ("Coindexed allocatable object at %L",
6965 c
= ref
->u
.c
.component
;
6966 if (c
->ts
.type
== BT_CLASS
)
6968 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6969 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6970 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6971 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6972 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6976 allocatable
= c
->attr
.allocatable
;
6977 pointer
= c
->attr
.pointer
;
6978 dimension
= c
->attr
.dimension
;
6979 codimension
= c
->attr
.codimension
;
6980 is_abstract
= c
->attr
.abstract
;
6992 /* Check for F08:C628. */
6993 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6995 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7000 /* Some checks for the SOURCE tag. */
7003 /* Check F03:C631. */
7004 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7006 gfc_error ("Type of entity at %L is type incompatible with "
7007 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7011 /* Check F03:C632 and restriction following Note 6.18. */
7012 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7015 /* Check F03:C633. */
7016 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7018 gfc_error ("The allocate-object at %L and the source-expr at %L "
7019 "shall have the same kind type parameter",
7020 &e
->where
, &code
->expr3
->where
);
7024 /* Check F2008, C642. */
7025 if (code
->expr3
->ts
.type
== BT_DERIVED
7026 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7027 || (code
->expr3
->ts
.u
.derived
->from_intmod
7028 == INTMOD_ISO_FORTRAN_ENV
7029 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7030 == ISOFORTRAN_LOCK_TYPE
)))
7032 gfc_error ("The source-expr at %L shall neither be of type "
7033 "LOCK_TYPE nor have a LOCK_TYPE component if "
7034 "allocate-object at %L is a coarray",
7035 &code
->expr3
->where
, &e
->where
);
7040 /* Check F08:C629. */
7041 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7044 gcc_assert (e
->ts
.type
== BT_CLASS
);
7045 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7046 "type-spec or source-expr", sym
->name
, &e
->where
);
7050 /* Check F08:C632. */
7051 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7052 && !UNLIMITED_POLY (e
))
7054 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7055 code
->ext
.alloc
.ts
.u
.cl
->length
);
7056 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7058 gfc_error ("Allocating %s at %L with type-spec requires the same "
7059 "character-length parameter as in the declaration",
7060 sym
->name
, &e
->where
);
7065 /* In the variable definition context checks, gfc_expr_attr is used
7066 on the expression. This is fooled by the array specification
7067 present in e, thus we have to eliminate that one temporarily. */
7068 e2
= remove_last_array_ref (e
);
7071 t
= gfc_check_vardef_context (e2
, true, true, false,
7072 _("ALLOCATE object"));
7074 t
= gfc_check_vardef_context (e2
, false, true, false,
7075 _("ALLOCATE object"));
7080 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7081 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7083 /* For class arrays, the initialization with SOURCE is done
7084 using _copy and trans_call. It is convenient to exploit that
7085 when the allocated type is different from the declared type but
7086 no SOURCE exists by setting expr3. */
7087 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7089 else if (!code
->expr3
)
7091 /* Set up default initializer if needed. */
7095 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7096 ts
= code
->ext
.alloc
.ts
;
7100 if (ts
.type
== BT_CLASS
)
7101 ts
= ts
.u
.derived
->components
->ts
;
7103 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7105 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
7106 init_st
->loc
= code
->loc
;
7107 init_st
->expr1
= gfc_expr_to_initialize (e
);
7108 init_st
->expr2
= init_e
;
7109 init_st
->next
= code
->next
;
7110 code
->next
= init_st
;
7113 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7115 /* Default initialization via MOLD (non-polymorphic). */
7116 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7119 gfc_resolve_expr (rhs
);
7120 gfc_free_expr (code
->expr3
);
7125 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7127 /* Make sure the vtab symbol is present when
7128 the module variables are generated. */
7129 gfc_typespec ts
= e
->ts
;
7131 ts
= code
->expr3
->ts
;
7132 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7133 ts
= code
->ext
.alloc
.ts
;
7135 gfc_find_derived_vtab (ts
.u
.derived
);
7138 e
= gfc_expr_to_initialize (e
);
7140 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7142 /* Again, make sure the vtab symbol is present when
7143 the module variables are generated. */
7144 gfc_typespec
*ts
= NULL
;
7146 ts
= &code
->expr3
->ts
;
7148 ts
= &code
->ext
.alloc
.ts
;
7155 e
= gfc_expr_to_initialize (e
);
7158 if (dimension
== 0 && codimension
== 0)
7161 /* Make sure the last reference node is an array specification. */
7163 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7164 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7169 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7170 "in ALLOCATE statement at %L", &e
->where
))
7172 *array_alloc_wo_spec
= true;
7176 gfc_error ("Array specification required in ALLOCATE statement "
7177 "at %L", &e
->where
);
7182 /* Make sure that the array section reference makes sense in the
7183 context of an ALLOCATE specification. */
7188 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7189 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7191 gfc_error ("Coarray specification required in ALLOCATE statement "
7192 "at %L", &e
->where
);
7196 for (i
= 0; i
< ar
->dimen
; i
++)
7198 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7201 switch (ar
->dimen_type
[i
])
7207 if (ar
->start
[i
] != NULL
7208 && ar
->end
[i
] != NULL
7209 && ar
->stride
[i
] == NULL
)
7212 /* Fall Through... */
7217 case DIMEN_THIS_IMAGE
:
7218 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7224 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7226 sym
= a
->expr
->symtree
->n
.sym
;
7228 /* TODO - check derived type components. */
7229 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7232 if ((ar
->start
[i
] != NULL
7233 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7234 || (ar
->end
[i
] != NULL
7235 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7237 gfc_error ("%qs must not appear in the array specification at "
7238 "%L in the same ALLOCATE statement where it is "
7239 "itself allocated", sym
->name
, &ar
->where
);
7245 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7247 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7248 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7250 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7252 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7253 "statement at %L", &e
->where
);
7259 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7260 && ar
->stride
[i
] == NULL
)
7263 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7277 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7279 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7280 gfc_alloc
*a
, *p
, *q
;
7283 errmsg
= code
->expr2
;
7285 /* Check the stat variable. */
7288 gfc_check_vardef_context (stat
, false, false, false,
7289 _("STAT variable"));
7291 if ((stat
->ts
.type
!= BT_INTEGER
7292 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7293 || stat
->ref
->type
== REF_COMPONENT
)))
7295 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7296 "variable", &stat
->where
);
7298 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7299 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7301 gfc_ref
*ref1
, *ref2
;
7304 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7305 ref1
= ref1
->next
, ref2
= ref2
->next
)
7307 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7309 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7318 gfc_error ("Stat-variable at %L shall not be %sd within "
7319 "the same %s statement", &stat
->where
, fcn
, fcn
);
7325 /* Check the errmsg variable. */
7329 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7332 gfc_check_vardef_context (errmsg
, false, false, false,
7333 _("ERRMSG variable"));
7335 if ((errmsg
->ts
.type
!= BT_CHARACTER
7337 && (errmsg
->ref
->type
== REF_ARRAY
7338 || errmsg
->ref
->type
== REF_COMPONENT
)))
7339 || errmsg
->rank
> 0 )
7340 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7341 "variable", &errmsg
->where
);
7343 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7344 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7346 gfc_ref
*ref1
, *ref2
;
7349 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7350 ref1
= ref1
->next
, ref2
= ref2
->next
)
7352 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7354 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7363 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7364 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7370 /* Check that an allocate-object appears only once in the statement. */
7372 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7375 for (q
= p
->next
; q
; q
= q
->next
)
7378 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7380 /* This is a potential collision. */
7381 gfc_ref
*pr
= pe
->ref
;
7382 gfc_ref
*qr
= qe
->ref
;
7384 /* Follow the references until
7385 a) They start to differ, in which case there is no error;
7386 you can deallocate a%b and a%c in a single statement
7387 b) Both of them stop, which is an error
7388 c) One of them stops, which is also an error. */
7391 if (pr
== NULL
&& qr
== NULL
)
7393 gfc_error ("Allocate-object at %L also appears at %L",
7394 &pe
->where
, &qe
->where
);
7397 else if (pr
!= NULL
&& qr
== NULL
)
7399 gfc_error ("Allocate-object at %L is subobject of"
7400 " object at %L", &pe
->where
, &qe
->where
);
7403 else if (pr
== NULL
&& qr
!= NULL
)
7405 gfc_error ("Allocate-object at %L is subobject of"
7406 " object at %L", &qe
->where
, &pe
->where
);
7409 /* Here, pr != NULL && qr != NULL */
7410 gcc_assert(pr
->type
== qr
->type
);
7411 if (pr
->type
== REF_ARRAY
)
7413 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7415 gcc_assert (qr
->type
== REF_ARRAY
);
7417 if (pr
->next
&& qr
->next
)
7420 gfc_array_ref
*par
= &(pr
->u
.ar
);
7421 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7423 for (i
=0; i
<par
->dimen
; i
++)
7425 if ((par
->start
[i
] != NULL
7426 || qar
->start
[i
] != NULL
)
7427 && gfc_dep_compare_expr (par
->start
[i
],
7428 qar
->start
[i
]) != 0)
7435 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7448 if (strcmp (fcn
, "ALLOCATE") == 0)
7450 bool arr_alloc_wo_spec
= false;
7451 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7452 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7454 if (arr_alloc_wo_spec
&& code
->expr3
)
7456 /* Mark the allocate to have to take the array specification
7458 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7463 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7464 resolve_deallocate_expr (a
->expr
);
7469 /************ SELECT CASE resolution subroutines ************/
7471 /* Callback function for our mergesort variant. Determines interval
7472 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7473 op1 > op2. Assumes we're not dealing with the default case.
7474 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7475 There are nine situations to check. */
7478 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7482 if (op1
->low
== NULL
) /* op1 = (:L) */
7484 /* op2 = (:N), so overlap. */
7486 /* op2 = (M:) or (M:N), L < M */
7487 if (op2
->low
!= NULL
7488 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7491 else if (op1
->high
== NULL
) /* op1 = (K:) */
7493 /* op2 = (M:), so overlap. */
7495 /* op2 = (:N) or (M:N), K > N */
7496 if (op2
->high
!= NULL
7497 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7500 else /* op1 = (K:L) */
7502 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7503 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7505 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7506 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7508 else /* op2 = (M:N) */
7512 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7515 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7524 /* Merge-sort a double linked case list, detecting overlap in the
7525 process. LIST is the head of the double linked case list before it
7526 is sorted. Returns the head of the sorted list if we don't see any
7527 overlap, or NULL otherwise. */
7530 check_case_overlap (gfc_case
*list
)
7532 gfc_case
*p
, *q
, *e
, *tail
;
7533 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7535 /* If the passed list was empty, return immediately. */
7542 /* Loop unconditionally. The only exit from this loop is a return
7543 statement, when we've finished sorting the case list. */
7550 /* Count the number of merges we do in this pass. */
7553 /* Loop while there exists a merge to be done. */
7558 /* Count this merge. */
7561 /* Cut the list in two pieces by stepping INSIZE places
7562 forward in the list, starting from P. */
7565 for (i
= 0; i
< insize
; i
++)
7574 /* Now we have two lists. Merge them! */
7575 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7577 /* See from which the next case to merge comes from. */
7580 /* P is empty so the next case must come from Q. */
7585 else if (qsize
== 0 || q
== NULL
)
7594 cmp
= compare_cases (p
, q
);
7597 /* The whole case range for P is less than the
7605 /* The whole case range for Q is greater than
7606 the case range for P. */
7613 /* The cases overlap, or they are the same
7614 element in the list. Either way, we must
7615 issue an error and get the next case from P. */
7616 /* FIXME: Sort P and Q by line number. */
7617 gfc_error ("CASE label at %L overlaps with CASE "
7618 "label at %L", &p
->where
, &q
->where
);
7626 /* Add the next element to the merged list. */
7635 /* P has now stepped INSIZE places along, and so has Q. So
7636 they're the same. */
7641 /* If we have done only one merge or none at all, we've
7642 finished sorting the cases. */
7651 /* Otherwise repeat, merging lists twice the size. */
7657 /* Check to see if an expression is suitable for use in a CASE statement.
7658 Makes sure that all case expressions are scalar constants of the same
7659 type. Return false if anything is wrong. */
7662 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7664 if (e
== NULL
) return true;
7666 if (e
->ts
.type
!= case_expr
->ts
.type
)
7668 gfc_error ("Expression in CASE statement at %L must be of type %s",
7669 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7673 /* C805 (R808) For a given case-construct, each case-value shall be of
7674 the same type as case-expr. For character type, length differences
7675 are allowed, but the kind type parameters shall be the same. */
7677 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7679 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7680 &e
->where
, case_expr
->ts
.kind
);
7684 /* Convert the case value kind to that of case expression kind,
7687 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7688 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7692 gfc_error ("Expression in CASE statement at %L must be scalar",
7701 /* Given a completely parsed select statement, we:
7703 - Validate all expressions and code within the SELECT.
7704 - Make sure that the selection expression is not of the wrong type.
7705 - Make sure that no case ranges overlap.
7706 - Eliminate unreachable cases and unreachable code resulting from
7707 removing case labels.
7709 The standard does allow unreachable cases, e.g. CASE (5:3). But
7710 they are a hassle for code generation, and to prevent that, we just
7711 cut them out here. This is not necessary for overlapping cases
7712 because they are illegal and we never even try to generate code.
7714 We have the additional caveat that a SELECT construct could have
7715 been a computed GOTO in the source code. Fortunately we can fairly
7716 easily work around that here: The case_expr for a "real" SELECT CASE
7717 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7718 we have to do is make sure that the case_expr is a scalar integer
7722 resolve_select (gfc_code
*code
, bool select_type
)
7725 gfc_expr
*case_expr
;
7726 gfc_case
*cp
, *default_case
, *tail
, *head
;
7727 int seen_unreachable
;
7733 if (code
->expr1
== NULL
)
7735 /* This was actually a computed GOTO statement. */
7736 case_expr
= code
->expr2
;
7737 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7738 gfc_error ("Selection expression in computed GOTO statement "
7739 "at %L must be a scalar integer expression",
7742 /* Further checking is not necessary because this SELECT was built
7743 by the compiler, so it should always be OK. Just move the
7744 case_expr from expr2 to expr so that we can handle computed
7745 GOTOs as normal SELECTs from here on. */
7746 code
->expr1
= code
->expr2
;
7751 case_expr
= code
->expr1
;
7752 type
= case_expr
->ts
.type
;
7755 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7757 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7758 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7760 /* Punt. Going on here just produce more garbage error messages. */
7765 if (!select_type
&& case_expr
->rank
!= 0)
7767 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7768 "expression", &case_expr
->where
);
7774 /* Raise a warning if an INTEGER case value exceeds the range of
7775 the case-expr. Later, all expressions will be promoted to the
7776 largest kind of all case-labels. */
7778 if (type
== BT_INTEGER
)
7779 for (body
= code
->block
; body
; body
= body
->block
)
7780 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7783 && gfc_check_integer_range (cp
->low
->value
.integer
,
7784 case_expr
->ts
.kind
) != ARITH_OK
)
7785 gfc_warning (0, "Expression in CASE statement at %L is "
7786 "not in the range of %s", &cp
->low
->where
,
7787 gfc_typename (&case_expr
->ts
));
7790 && cp
->low
!= cp
->high
7791 && gfc_check_integer_range (cp
->high
->value
.integer
,
7792 case_expr
->ts
.kind
) != ARITH_OK
)
7793 gfc_warning (0, "Expression in CASE statement at %L is "
7794 "not in the range of %s", &cp
->high
->where
,
7795 gfc_typename (&case_expr
->ts
));
7798 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7799 of the SELECT CASE expression and its CASE values. Walk the lists
7800 of case values, and if we find a mismatch, promote case_expr to
7801 the appropriate kind. */
7803 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7805 for (body
= code
->block
; body
; body
= body
->block
)
7807 /* Walk the case label list. */
7808 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7810 /* Intercept the DEFAULT case. It does not have a kind. */
7811 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7814 /* Unreachable case ranges are discarded, so ignore. */
7815 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7816 && cp
->low
!= cp
->high
7817 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7821 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7822 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7824 if (cp
->high
!= NULL
7825 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7826 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7831 /* Assume there is no DEFAULT case. */
7832 default_case
= NULL
;
7837 for (body
= code
->block
; body
; body
= body
->block
)
7839 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7841 seen_unreachable
= 0;
7843 /* Walk the case label list, making sure that all case labels
7845 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7847 /* Count the number of cases in the whole construct. */
7850 /* Intercept the DEFAULT case. */
7851 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7853 if (default_case
!= NULL
)
7855 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7856 "by a second DEFAULT CASE at %L",
7857 &default_case
->where
, &cp
->where
);
7868 /* Deal with single value cases and case ranges. Errors are
7869 issued from the validation function. */
7870 if (!validate_case_label_expr (cp
->low
, case_expr
)
7871 || !validate_case_label_expr (cp
->high
, case_expr
))
7877 if (type
== BT_LOGICAL
7878 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7879 || cp
->low
!= cp
->high
))
7881 gfc_error ("Logical range in CASE statement at %L is not "
7882 "allowed", &cp
->low
->where
);
7887 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7890 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7891 if (value
& seen_logical
)
7893 gfc_error ("Constant logical value in CASE statement "
7894 "is repeated at %L",
7899 seen_logical
|= value
;
7902 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7903 && cp
->low
!= cp
->high
7904 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7906 if (warn_surprising
)
7907 gfc_warning (OPT_Wsurprising
,
7908 "Range specification at %L can never be matched",
7911 cp
->unreachable
= 1;
7912 seen_unreachable
= 1;
7916 /* If the case range can be matched, it can also overlap with
7917 other cases. To make sure it does not, we put it in a
7918 double linked list here. We sort that with a merge sort
7919 later on to detect any overlapping cases. */
7923 head
->right
= head
->left
= NULL
;
7928 tail
->right
->left
= tail
;
7935 /* It there was a failure in the previous case label, give up
7936 for this case label list. Continue with the next block. */
7940 /* See if any case labels that are unreachable have been seen.
7941 If so, we eliminate them. This is a bit of a kludge because
7942 the case lists for a single case statement (label) is a
7943 single forward linked lists. */
7944 if (seen_unreachable
)
7946 /* Advance until the first case in the list is reachable. */
7947 while (body
->ext
.block
.case_list
!= NULL
7948 && body
->ext
.block
.case_list
->unreachable
)
7950 gfc_case
*n
= body
->ext
.block
.case_list
;
7951 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7953 gfc_free_case_list (n
);
7956 /* Strip all other unreachable cases. */
7957 if (body
->ext
.block
.case_list
)
7959 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7961 if (cp
->next
->unreachable
)
7963 gfc_case
*n
= cp
->next
;
7964 cp
->next
= cp
->next
->next
;
7966 gfc_free_case_list (n
);
7973 /* See if there were overlapping cases. If the check returns NULL,
7974 there was overlap. In that case we don't do anything. If head
7975 is non-NULL, we prepend the DEFAULT case. The sorted list can
7976 then used during code generation for SELECT CASE constructs with
7977 a case expression of a CHARACTER type. */
7980 head
= check_case_overlap (head
);
7982 /* Prepend the default_case if it is there. */
7983 if (head
!= NULL
&& default_case
)
7985 default_case
->left
= NULL
;
7986 default_case
->right
= head
;
7987 head
->left
= default_case
;
7991 /* Eliminate dead blocks that may be the result if we've seen
7992 unreachable case labels for a block. */
7993 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7995 if (body
->block
->ext
.block
.case_list
== NULL
)
7997 /* Cut the unreachable block from the code chain. */
7998 gfc_code
*c
= body
->block
;
7999 body
->block
= c
->block
;
8001 /* Kill the dead block, but not the blocks below it. */
8003 gfc_free_statements (c
);
8007 /* More than two cases is legal but insane for logical selects.
8008 Issue a warning for it. */
8009 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8010 gfc_warning (OPT_Wsurprising
,
8011 "Logical SELECT CASE block at %L has more that two cases",
8016 /* Check if a derived type is extensible. */
8019 gfc_type_is_extensible (gfc_symbol
*sym
)
8021 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8022 || (sym
->attr
.is_class
8023 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8028 resolve_types (gfc_namespace
*ns
);
8030 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8031 correct as well as possibly the array-spec. */
8034 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8038 gcc_assert (sym
->assoc
);
8039 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8041 /* If this is for SELECT TYPE, the target may not yet be set. In that
8042 case, return. Resolution will be called later manually again when
8044 target
= sym
->assoc
->target
;
8047 gcc_assert (!sym
->assoc
->dangling
);
8049 if (resolve_target
&& !gfc_resolve_expr (target
))
8052 /* For variable targets, we get some attributes from the target. */
8053 if (target
->expr_type
== EXPR_VARIABLE
)
8057 gcc_assert (target
->symtree
);
8058 tsym
= target
->symtree
->n
.sym
;
8060 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8061 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8063 sym
->attr
.target
= tsym
->attr
.target
8064 || gfc_expr_attr (target
).pointer
;
8065 if (is_subref_array (target
))
8066 sym
->attr
.subref_array_pointer
= 1;
8069 /* Get type if this was not already set. Note that it can be
8070 some other type than the target in case this is a SELECT TYPE
8071 selector! So we must not update when the type is already there. */
8072 if (sym
->ts
.type
== BT_UNKNOWN
)
8073 sym
->ts
= target
->ts
;
8074 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8076 /* See if this is a valid association-to-variable. */
8077 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8078 && !gfc_has_vector_subscript (target
));
8080 /* Finally resolve if this is an array or not. */
8081 if (sym
->attr
.dimension
&& target
->rank
== 0)
8083 /* primary.c makes the assumption that a reference to an associate
8084 name followed by a left parenthesis is an array reference. */
8085 if (sym
->ts
.type
!= BT_CHARACTER
)
8086 gfc_error ("Associate-name %qs at %L is used as array",
8087 sym
->name
, &sym
->declared_at
);
8088 sym
->attr
.dimension
= 0;
8093 /* We cannot deal with class selectors that need temporaries. */
8094 if (target
->ts
.type
== BT_CLASS
8095 && gfc_ref_needs_temporary_p (target
->ref
))
8097 gfc_error ("CLASS selector at %L needs a temporary which is not "
8098 "yet implemented", &target
->where
);
8102 if (target
->ts
.type
== BT_CLASS
)
8103 gfc_fix_class_refs (target
);
8105 if (target
->rank
!= 0)
8108 if (sym
->ts
.type
!= BT_CLASS
&& !sym
->as
)
8110 as
= gfc_get_array_spec ();
8111 as
->rank
= target
->rank
;
8112 as
->type
= AS_DEFERRED
;
8113 as
->corank
= gfc_get_corank (target
);
8114 sym
->attr
.dimension
= 1;
8115 if (as
->corank
!= 0)
8116 sym
->attr
.codimension
= 1;
8122 /* target's rank is 0, but the type of the sym is still array valued,
8123 which has to be corrected. */
8124 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8127 symbol_attribute attr
;
8128 /* The associated variable's type is still the array type
8129 correct this now. */
8130 gfc_typespec
*ts
= &target
->ts
;
8133 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8138 ts
= &ref
->u
.c
.component
->ts
;
8141 if (ts
->type
== BT_CLASS
)
8142 ts
= &ts
->u
.derived
->components
->ts
;
8148 /* Create a scalar instance of the current class type. Because the
8149 rank of a class array goes into its name, the type has to be
8150 rebuild. The alternative of (re-)setting just the attributes
8151 and as in the current type, destroys the type also in other
8155 sym
->ts
.type
= BT_CLASS
;
8156 attr
= CLASS_DATA (sym
)->attr
;
8158 attr
.associate_var
= 1;
8159 attr
.dimension
= attr
.codimension
= 0;
8160 attr
.class_pointer
= 1;
8161 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8163 /* Make sure the _vptr is set. */
8164 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true);
8165 if (c
->ts
.u
.derived
== NULL
)
8166 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8167 CLASS_DATA (sym
)->attr
.pointer
= 1;
8168 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8169 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8170 gfc_commit_symbol (sym
->ts
.u
.derived
);
8171 /* _vptr now has the _vtab in it, change it to the _vtype. */
8172 if (c
->ts
.u
.derived
->attr
.vtab
)
8173 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8174 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8175 resolve_types (c
->ts
.u
.derived
->ns
);
8179 /* Mark this as an associate variable. */
8180 sym
->attr
.associate_var
= 1;
8182 /* If the target is a good class object, so is the associate variable. */
8183 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8184 sym
->attr
.class_ok
= 1;
8188 /* Resolve a SELECT TYPE statement. */
8191 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8193 gfc_symbol
*selector_type
;
8194 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8195 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8198 char name
[GFC_MAX_SYMBOL_LEN
];
8203 ns
= code
->ext
.block
.ns
;
8206 /* Check for F03:C813. */
8207 if (code
->expr1
->ts
.type
!= BT_CLASS
8208 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8210 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8211 "at %L", &code
->loc
);
8215 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8220 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8221 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8222 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8224 /* F2008: C803 The selector expression must not be coindexed. */
8225 if (gfc_is_coindexed (code
->expr2
))
8227 gfc_error ("Selector at %L must not be coindexed",
8228 &code
->expr2
->where
);
8235 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8237 if (gfc_is_coindexed (code
->expr1
))
8239 gfc_error ("Selector at %L must not be coindexed",
8240 &code
->expr1
->where
);
8245 /* Loop over TYPE IS / CLASS IS cases. */
8246 for (body
= code
->block
; body
; body
= body
->block
)
8248 c
= body
->ext
.block
.case_list
;
8250 /* Check F03:C815. */
8251 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8252 && !selector_type
->attr
.unlimited_polymorphic
8253 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8255 gfc_error ("Derived type %qs at %L must be extensible",
8256 c
->ts
.u
.derived
->name
, &c
->where
);
8261 /* Check F03:C816. */
8262 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8263 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8264 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8266 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8267 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8268 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8270 gfc_error ("Unexpected intrinsic type %qs at %L",
8271 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8276 /* Check F03:C814. */
8277 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8279 gfc_error ("The type-spec at %L shall specify that each length "
8280 "type parameter is assumed", &c
->where
);
8285 /* Intercept the DEFAULT case. */
8286 if (c
->ts
.type
== BT_UNKNOWN
)
8288 /* Check F03:C818. */
8291 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8292 "by a second DEFAULT CASE at %L",
8293 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8298 default_case
= body
;
8305 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8306 target if present. If there are any EXIT statements referring to the
8307 SELECT TYPE construct, this is no problem because the gfc_code
8308 reference stays the same and EXIT is equally possible from the BLOCK
8309 it is changed to. */
8310 code
->op
= EXEC_BLOCK
;
8313 gfc_association_list
* assoc
;
8315 assoc
= gfc_get_association_list ();
8316 assoc
->st
= code
->expr1
->symtree
;
8317 assoc
->target
= gfc_copy_expr (code
->expr2
);
8318 assoc
->target
->where
= code
->expr2
->where
;
8319 /* assoc->variable will be set by resolve_assoc_var. */
8321 code
->ext
.block
.assoc
= assoc
;
8322 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8324 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8327 code
->ext
.block
.assoc
= NULL
;
8329 /* Add EXEC_SELECT to switch on type. */
8330 new_st
= gfc_get_code (code
->op
);
8331 new_st
->expr1
= code
->expr1
;
8332 new_st
->expr2
= code
->expr2
;
8333 new_st
->block
= code
->block
;
8334 code
->expr1
= code
->expr2
= NULL
;
8339 ns
->code
->next
= new_st
;
8341 code
->op
= EXEC_SELECT
;
8343 gfc_add_vptr_component (code
->expr1
);
8344 gfc_add_hash_component (code
->expr1
);
8346 /* Loop over TYPE IS / CLASS IS cases. */
8347 for (body
= code
->block
; body
; body
= body
->block
)
8349 c
= body
->ext
.block
.case_list
;
8351 if (c
->ts
.type
== BT_DERIVED
)
8352 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8353 c
->ts
.u
.derived
->hash_value
);
8354 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8359 ivtab
= gfc_find_vtab (&c
->ts
);
8360 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8361 e
= CLASS_DATA (ivtab
)->initializer
;
8362 c
->low
= c
->high
= gfc_copy_expr (e
);
8365 else if (c
->ts
.type
== BT_UNKNOWN
)
8368 /* Associate temporary to selector. This should only be done
8369 when this case is actually true, so build a new ASSOCIATE
8370 that does precisely this here (instead of using the
8373 if (c
->ts
.type
== BT_CLASS
)
8374 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8375 else if (c
->ts
.type
== BT_DERIVED
)
8376 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8377 else if (c
->ts
.type
== BT_CHARACTER
)
8379 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8380 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8381 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8382 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8383 charlen
, c
->ts
.kind
);
8386 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8389 st
= gfc_find_symtree (ns
->sym_root
, name
);
8390 gcc_assert (st
->n
.sym
->assoc
);
8391 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8392 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8393 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8394 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8396 new_st
= gfc_get_code (EXEC_BLOCK
);
8397 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8398 new_st
->ext
.block
.ns
->code
= body
->next
;
8399 body
->next
= new_st
;
8401 /* Chain in the new list only if it is marked as dangling. Otherwise
8402 there is a CASE label overlap and this is already used. Just ignore,
8403 the error is diagnosed elsewhere. */
8404 if (st
->n
.sym
->assoc
->dangling
)
8406 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8407 st
->n
.sym
->assoc
->dangling
= 0;
8410 resolve_assoc_var (st
->n
.sym
, false);
8413 /* Take out CLASS IS cases for separate treatment. */
8415 while (body
&& body
->block
)
8417 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8419 /* Add to class_is list. */
8420 if (class_is
== NULL
)
8422 class_is
= body
->block
;
8427 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8428 tail
->block
= body
->block
;
8431 /* Remove from EXEC_SELECT list. */
8432 body
->block
= body
->block
->block
;
8445 /* Add a default case to hold the CLASS IS cases. */
8446 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8447 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8449 tail
->ext
.block
.case_list
= gfc_get_case ();
8450 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8452 default_case
= tail
;
8455 /* More than one CLASS IS block? */
8456 if (class_is
->block
)
8460 /* Sort CLASS IS blocks by extension level. */
8464 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8467 /* F03:C817 (check for doubles). */
8468 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8469 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8471 gfc_error ("Double CLASS IS block in SELECT TYPE "
8473 &c2
->ext
.block
.case_list
->where
);
8476 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8477 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8480 (*c1
)->block
= c2
->block
;
8490 /* Generate IF chain. */
8491 if_st
= gfc_get_code (EXEC_IF
);
8493 for (body
= class_is
; body
; body
= body
->block
)
8495 new_st
->block
= gfc_get_code (EXEC_IF
);
8496 new_st
= new_st
->block
;
8497 /* Set up IF condition: Call _gfortran_is_extension_of. */
8498 new_st
->expr1
= gfc_get_expr ();
8499 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8500 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8501 new_st
->expr1
->ts
.kind
= 4;
8502 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8503 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8504 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8505 /* Set up arguments. */
8506 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8507 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8508 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8509 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8510 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8511 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8512 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8513 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8514 new_st
->next
= body
->next
;
8516 if (default_case
->next
)
8518 new_st
->block
= gfc_get_code (EXEC_IF
);
8519 new_st
= new_st
->block
;
8520 new_st
->next
= default_case
->next
;
8523 /* Replace CLASS DEFAULT code by the IF chain. */
8524 default_case
->next
= if_st
;
8527 /* Resolve the internal code. This can not be done earlier because
8528 it requires that the sym->assoc of selectors is set already. */
8529 gfc_current_ns
= ns
;
8530 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8531 gfc_current_ns
= old_ns
;
8533 resolve_select (code
, true);
8537 /* Resolve a transfer statement. This is making sure that:
8538 -- a derived type being transferred has only non-pointer components
8539 -- a derived type being transferred doesn't have private components, unless
8540 it's being transferred from the module where the type was defined
8541 -- we're not trying to transfer a whole assumed size array. */
8544 resolve_transfer (gfc_code
*code
)
8553 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8554 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8555 exp
= exp
->value
.op
.op1
;
8557 if (exp
&& exp
->expr_type
== EXPR_NULL
8560 gfc_error ("Invalid context for NULL () intrinsic at %L",
8565 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8566 && exp
->expr_type
!= EXPR_FUNCTION
8567 && exp
->expr_type
!= EXPR_STRUCTURE
))
8570 /* If we are reading, the variable will be changed. Note that
8571 code->ext.dt may be NULL if the TRANSFER is related to
8572 an INQUIRE statement -- but in this case, we are not reading, either. */
8573 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8574 && !gfc_check_vardef_context (exp
, false, false, false,
8578 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8580 /* Go to actual component transferred. */
8581 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8582 if (ref
->type
== REF_COMPONENT
)
8583 ts
= &ref
->u
.c
.component
->ts
;
8585 if (ts
->type
== BT_CLASS
)
8587 /* FIXME: Test for defined input/output. */
8588 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8589 "it is processed by a defined input/output procedure",
8594 if (ts
->type
== BT_DERIVED
)
8596 /* Check that transferred derived type doesn't contain POINTER
8598 if (ts
->u
.derived
->attr
.pointer_comp
)
8600 gfc_error ("Data transfer element at %L cannot have POINTER "
8601 "components unless it is processed by a defined "
8602 "input/output procedure", &code
->loc
);
8607 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8609 gfc_error ("Data transfer element at %L cannot have "
8610 "procedure pointer components", &code
->loc
);
8614 if (ts
->u
.derived
->attr
.alloc_comp
)
8616 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8617 "components unless it is processed by a defined "
8618 "input/output procedure", &code
->loc
);
8622 /* C_PTR and C_FUNPTR have private components which means they can not
8623 be printed. However, if -std=gnu and not -pedantic, allow
8624 the component to be printed to help debugging. */
8625 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8627 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8628 "cannot have PRIVATE components", &code
->loc
))
8631 else if (derived_inaccessible (ts
->u
.derived
))
8633 gfc_error ("Data transfer element at %L cannot have "
8634 "PRIVATE components",&code
->loc
);
8639 if (exp
->expr_type
== EXPR_STRUCTURE
)
8642 sym
= exp
->symtree
->n
.sym
;
8644 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8645 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8647 gfc_error ("Data transfer element at %L cannot be a full reference to "
8648 "an assumed-size array", &code
->loc
);
8654 /*********** Toplevel code resolution subroutines ***********/
8656 /* Find the set of labels that are reachable from this block. We also
8657 record the last statement in each block. */
8660 find_reachable_labels (gfc_code
*block
)
8667 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8669 /* Collect labels in this block. We don't keep those corresponding
8670 to END {IF|SELECT}, these are checked in resolve_branch by going
8671 up through the code_stack. */
8672 for (c
= block
; c
; c
= c
->next
)
8674 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8675 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8678 /* Merge with labels from parent block. */
8681 gcc_assert (cs_base
->prev
->reachable_labels
);
8682 bitmap_ior_into (cs_base
->reachable_labels
,
8683 cs_base
->prev
->reachable_labels
);
8689 resolve_lock_unlock (gfc_code
*code
)
8691 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8692 && code
->expr1
->value
.function
.isym
8693 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8694 remove_caf_get_intrinsic (code
->expr1
);
8696 if (code
->expr1
->ts
.type
!= BT_DERIVED
8697 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8698 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8699 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8700 || code
->expr1
->rank
!= 0
8701 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8702 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8703 &code
->expr1
->where
);
8707 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8708 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8709 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8710 &code
->expr2
->where
);
8713 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8714 _("STAT variable")))
8719 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8720 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8721 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8722 &code
->expr3
->where
);
8725 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8726 _("ERRMSG variable")))
8729 /* Check ACQUIRED_LOCK. */
8731 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8732 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8733 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8734 "variable", &code
->expr4
->where
);
8737 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8738 _("ACQUIRED_LOCK variable")))
8744 resolve_critical (gfc_code
*code
)
8746 gfc_symtree
*symtree
;
8747 gfc_symbol
*lock_type
;
8748 char name
[GFC_MAX_SYMBOL_LEN
];
8749 static int serial
= 0;
8751 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8754 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8755 GFC_PREFIX ("lock_type"));
8757 lock_type
= symtree
->n
.sym
;
8760 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8763 lock_type
= symtree
->n
.sym
;
8764 lock_type
->attr
.flavor
= FL_DERIVED
;
8765 lock_type
->attr
.zero_comp
= 1;
8766 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8767 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8770 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8771 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8774 code
->resolved_sym
= symtree
->n
.sym
;
8775 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8776 symtree
->n
.sym
->attr
.referenced
= 1;
8777 symtree
->n
.sym
->attr
.artificial
= 1;
8778 symtree
->n
.sym
->attr
.codimension
= 1;
8779 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8780 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8781 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8782 symtree
->n
.sym
->as
->corank
= 1;
8783 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8784 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8785 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8791 resolve_sync (gfc_code
*code
)
8793 /* Check imageset. The * case matches expr1 == NULL. */
8796 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8797 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8798 "INTEGER expression", &code
->expr1
->where
);
8799 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8800 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8801 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8802 &code
->expr1
->where
);
8803 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8804 && gfc_simplify_expr (code
->expr1
, 0))
8806 gfc_constructor
*cons
;
8807 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8808 for (; cons
; cons
= gfc_constructor_next (cons
))
8809 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8810 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8811 gfc_error ("Imageset argument at %L must between 1 and "
8812 "num_images()", &cons
->expr
->where
);
8818 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8819 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8820 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8821 &code
->expr2
->where
);
8825 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8826 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8827 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8828 &code
->expr3
->where
);
8832 /* Given a branch to a label, see if the branch is conforming.
8833 The code node describes where the branch is located. */
8836 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8843 /* Step one: is this a valid branching target? */
8845 if (label
->defined
== ST_LABEL_UNKNOWN
)
8847 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8852 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8854 gfc_error ("Statement at %L is not a valid branch target statement "
8855 "for the branch statement at %L", &label
->where
, &code
->loc
);
8859 /* Step two: make sure this branch is not a branch to itself ;-) */
8861 if (code
->here
== label
)
8864 "Branch at %L may result in an infinite loop", &code
->loc
);
8868 /* Step three: See if the label is in the same block as the
8869 branching statement. The hard work has been done by setting up
8870 the bitmap reachable_labels. */
8872 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8874 /* Check now whether there is a CRITICAL construct; if so, check
8875 whether the label is still visible outside of the CRITICAL block,
8876 which is invalid. */
8877 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8879 if (stack
->current
->op
== EXEC_CRITICAL
8880 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8881 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8882 "label at %L", &code
->loc
, &label
->where
);
8883 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8884 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8885 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8886 "for label at %L", &code
->loc
, &label
->where
);
8892 /* Step four: If we haven't found the label in the bitmap, it may
8893 still be the label of the END of the enclosing block, in which
8894 case we find it by going up the code_stack. */
8896 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8898 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8900 if (stack
->current
->op
== EXEC_CRITICAL
)
8902 /* Note: A label at END CRITICAL does not leave the CRITICAL
8903 construct as END CRITICAL is still part of it. */
8904 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8905 " at %L", &code
->loc
, &label
->where
);
8908 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8910 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8911 "label at %L", &code
->loc
, &label
->where
);
8918 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8922 /* The label is not in an enclosing block, so illegal. This was
8923 allowed in Fortran 66, so we allow it as extension. No
8924 further checks are necessary in this case. */
8925 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8926 "as the GOTO statement at %L", &label
->where
,
8932 /* Check whether EXPR1 has the same shape as EXPR2. */
8935 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8937 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8938 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8939 bool result
= false;
8942 /* Compare the rank. */
8943 if (expr1
->rank
!= expr2
->rank
)
8946 /* Compare the size of each dimension. */
8947 for (i
=0; i
<expr1
->rank
; i
++)
8949 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8952 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8955 if (mpz_cmp (shape
[i
], shape2
[i
]))
8959 /* When either of the two expression is an assumed size array, we
8960 ignore the comparison of dimension sizes. */
8965 gfc_clear_shape (shape
, i
);
8966 gfc_clear_shape (shape2
, i
);
8971 /* Check whether a WHERE assignment target or a WHERE mask expression
8972 has the same shape as the outmost WHERE mask expression. */
8975 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8981 cblock
= code
->block
;
8983 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8984 In case of nested WHERE, only the outmost one is stored. */
8985 if (mask
== NULL
) /* outmost WHERE */
8987 else /* inner WHERE */
8994 /* Check if the mask-expr has a consistent shape with the
8995 outmost WHERE mask-expr. */
8996 if (!resolve_where_shape (cblock
->expr1
, e
))
8997 gfc_error ("WHERE mask at %L has inconsistent shape",
8998 &cblock
->expr1
->where
);
9001 /* the assignment statement of a WHERE statement, or the first
9002 statement in where-body-construct of a WHERE construct */
9003 cnext
= cblock
->next
;
9008 /* WHERE assignment statement */
9011 /* Check shape consistent for WHERE assignment target. */
9012 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9013 gfc_error ("WHERE assignment target at %L has "
9014 "inconsistent shape", &cnext
->expr1
->where
);
9018 case EXEC_ASSIGN_CALL
:
9019 resolve_call (cnext
);
9020 if (!cnext
->resolved_sym
->attr
.elemental
)
9021 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9022 &cnext
->ext
.actual
->expr
->where
);
9025 /* WHERE or WHERE construct is part of a where-body-construct */
9027 resolve_where (cnext
, e
);
9031 gfc_error ("Unsupported statement inside WHERE at %L",
9034 /* the next statement within the same where-body-construct */
9035 cnext
= cnext
->next
;
9037 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9038 cblock
= cblock
->block
;
9043 /* Resolve assignment in FORALL construct.
9044 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9045 FORALL index variables. */
9048 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9052 for (n
= 0; n
< nvar
; n
++)
9054 gfc_symbol
*forall_index
;
9056 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9058 /* Check whether the assignment target is one of the FORALL index
9060 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9061 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9062 gfc_error ("Assignment to a FORALL index variable at %L",
9063 &code
->expr1
->where
);
9066 /* If one of the FORALL index variables doesn't appear in the
9067 assignment variable, then there could be a many-to-one
9068 assignment. Emit a warning rather than an error because the
9069 mask could be resolving this problem. */
9070 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9071 gfc_warning (0, "The FORALL with index %qs is not used on the "
9072 "left side of the assignment at %L and so might "
9073 "cause multiple assignment to this object",
9074 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9080 /* Resolve WHERE statement in FORALL construct. */
9083 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9084 gfc_expr
**var_expr
)
9089 cblock
= code
->block
;
9092 /* the assignment statement of a WHERE statement, or the first
9093 statement in where-body-construct of a WHERE construct */
9094 cnext
= cblock
->next
;
9099 /* WHERE assignment statement */
9101 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9104 /* WHERE operator assignment statement */
9105 case EXEC_ASSIGN_CALL
:
9106 resolve_call (cnext
);
9107 if (!cnext
->resolved_sym
->attr
.elemental
)
9108 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9109 &cnext
->ext
.actual
->expr
->where
);
9112 /* WHERE or WHERE construct is part of a where-body-construct */
9114 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9118 gfc_error ("Unsupported statement inside WHERE at %L",
9121 /* the next statement within the same where-body-construct */
9122 cnext
= cnext
->next
;
9124 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9125 cblock
= cblock
->block
;
9130 /* Traverse the FORALL body to check whether the following errors exist:
9131 1. For assignment, check if a many-to-one assignment happens.
9132 2. For WHERE statement, check the WHERE body to see if there is any
9133 many-to-one assignment. */
9136 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9140 c
= code
->block
->next
;
9146 case EXEC_POINTER_ASSIGN
:
9147 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9150 case EXEC_ASSIGN_CALL
:
9154 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9155 there is no need to handle it here. */
9159 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9164 /* The next statement in the FORALL body. */
9170 /* Counts the number of iterators needed inside a forall construct, including
9171 nested forall constructs. This is used to allocate the needed memory
9172 in gfc_resolve_forall. */
9175 gfc_count_forall_iterators (gfc_code
*code
)
9177 int max_iters
, sub_iters
, current_iters
;
9178 gfc_forall_iterator
*fa
;
9180 gcc_assert(code
->op
== EXEC_FORALL
);
9184 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9187 code
= code
->block
->next
;
9191 if (code
->op
== EXEC_FORALL
)
9193 sub_iters
= gfc_count_forall_iterators (code
);
9194 if (sub_iters
> max_iters
)
9195 max_iters
= sub_iters
;
9200 return current_iters
+ max_iters
;
9204 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9205 gfc_resolve_forall_body to resolve the FORALL body. */
9208 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9210 static gfc_expr
**var_expr
;
9211 static int total_var
= 0;
9212 static int nvar
= 0;
9214 gfc_forall_iterator
*fa
;
9219 /* Start to resolve a FORALL construct */
9220 if (forall_save
== 0)
9222 /* Count the total number of FORALL index in the nested FORALL
9223 construct in order to allocate the VAR_EXPR with proper size. */
9224 total_var
= gfc_count_forall_iterators (code
);
9226 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9227 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9230 /* The information about FORALL iterator, including FORALL index start, end
9231 and stride. The FORALL index can not appear in start, end or stride. */
9232 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9234 /* Check if any outer FORALL index name is the same as the current
9236 for (i
= 0; i
< nvar
; i
++)
9238 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9240 gfc_error ("An outer FORALL construct already has an index "
9241 "with this name %L", &fa
->var
->where
);
9245 /* Record the current FORALL index. */
9246 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9250 /* No memory leak. */
9251 gcc_assert (nvar
<= total_var
);
9254 /* Resolve the FORALL body. */
9255 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9257 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9258 gfc_resolve_blocks (code
->block
, ns
);
9262 /* Free only the VAR_EXPRs allocated in this frame. */
9263 for (i
= nvar
; i
< tmp
; i
++)
9264 gfc_free_expr (var_expr
[i
]);
9268 /* We are in the outermost FORALL construct. */
9269 gcc_assert (forall_save
== 0);
9271 /* VAR_EXPR is not needed any more. */
9278 /* Resolve a BLOCK construct statement. */
9281 resolve_block_construct (gfc_code
* code
)
9283 /* Resolve the BLOCK's namespace. */
9284 gfc_resolve (code
->ext
.block
.ns
);
9286 /* For an ASSOCIATE block, the associations (and their targets) are already
9287 resolved during resolve_symbol. */
9291 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9295 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9299 for (; b
; b
= b
->block
)
9301 t
= gfc_resolve_expr (b
->expr1
);
9302 if (!gfc_resolve_expr (b
->expr2
))
9308 if (t
&& b
->expr1
!= NULL
9309 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9310 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9317 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9318 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9323 resolve_branch (b
->label1
, b
);
9327 resolve_block_construct (b
);
9331 case EXEC_SELECT_TYPE
:
9335 case EXEC_DO_CONCURRENT
:
9343 case EXEC_OACC_PARALLEL_LOOP
:
9344 case EXEC_OACC_PARALLEL
:
9345 case EXEC_OACC_KERNELS_LOOP
:
9346 case EXEC_OACC_KERNELS
:
9347 case EXEC_OACC_DATA
:
9348 case EXEC_OACC_HOST_DATA
:
9349 case EXEC_OACC_LOOP
:
9350 case EXEC_OACC_UPDATE
:
9351 case EXEC_OACC_WAIT
:
9352 case EXEC_OACC_CACHE
:
9353 case EXEC_OACC_ENTER_DATA
:
9354 case EXEC_OACC_EXIT_DATA
:
9355 case EXEC_OMP_ATOMIC
:
9356 case EXEC_OMP_CRITICAL
:
9357 case EXEC_OMP_DISTRIBUTE
:
9358 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9359 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9360 case EXEC_OMP_DISTRIBUTE_SIMD
:
9362 case EXEC_OMP_DO_SIMD
:
9363 case EXEC_OMP_MASTER
:
9364 case EXEC_OMP_ORDERED
:
9365 case EXEC_OMP_PARALLEL
:
9366 case EXEC_OMP_PARALLEL_DO
:
9367 case EXEC_OMP_PARALLEL_DO_SIMD
:
9368 case EXEC_OMP_PARALLEL_SECTIONS
:
9369 case EXEC_OMP_PARALLEL_WORKSHARE
:
9370 case EXEC_OMP_SECTIONS
:
9372 case EXEC_OMP_SINGLE
:
9373 case EXEC_OMP_TARGET
:
9374 case EXEC_OMP_TARGET_DATA
:
9375 case EXEC_OMP_TARGET_TEAMS
:
9376 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9377 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9378 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9379 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9380 case EXEC_OMP_TARGET_UPDATE
:
9382 case EXEC_OMP_TASKGROUP
:
9383 case EXEC_OMP_TASKWAIT
:
9384 case EXEC_OMP_TASKYIELD
:
9385 case EXEC_OMP_TEAMS
:
9386 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9387 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9388 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9389 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9390 case EXEC_OMP_WORKSHARE
:
9394 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9397 gfc_resolve_code (b
->next
, ns
);
9402 /* Does everything to resolve an ordinary assignment. Returns true
9403 if this is an interface assignment. */
9405 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9414 symbol_attribute attr
;
9416 if (gfc_extend_assign (code
, ns
))
9420 if (code
->op
== EXEC_ASSIGN_CALL
)
9422 lhs
= code
->ext
.actual
->expr
;
9423 rhsptr
= &code
->ext
.actual
->next
->expr
;
9427 gfc_actual_arglist
* args
;
9428 gfc_typebound_proc
* tbp
;
9430 gcc_assert (code
->op
== EXEC_COMPCALL
);
9432 args
= code
->expr1
->value
.compcall
.actual
;
9434 rhsptr
= &args
->next
->expr
;
9436 tbp
= code
->expr1
->value
.compcall
.tbp
;
9437 gcc_assert (!tbp
->is_generic
);
9440 /* Make a temporary rhs when there is a default initializer
9441 and rhs is the same symbol as the lhs. */
9442 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9443 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9444 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9445 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9446 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9455 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9456 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9460 /* Handle the case of a BOZ literal on the RHS. */
9461 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9464 if (warn_surprising
)
9465 gfc_warning (OPT_Wsurprising
,
9466 "BOZ literal at %L is bitwise transferred "
9467 "non-integer symbol %qs", &code
->loc
,
9468 lhs
->symtree
->n
.sym
->name
);
9470 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9472 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9474 if (rc
== ARITH_UNDERFLOW
)
9475 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9476 ". This check can be disabled with the option "
9477 "%<-fno-range-check%>", &rhs
->where
);
9478 else if (rc
== ARITH_OVERFLOW
)
9479 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9480 ". This check can be disabled with the option "
9481 "%<-fno-range-check%>", &rhs
->where
);
9482 else if (rc
== ARITH_NAN
)
9483 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9484 ". This check can be disabled with the option "
9485 "%<-fno-range-check%>", &rhs
->where
);
9490 if (lhs
->ts
.type
== BT_CHARACTER
9491 && warn_character_truncation
)
9493 if (lhs
->ts
.u
.cl
!= NULL
9494 && lhs
->ts
.u
.cl
->length
!= NULL
9495 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9496 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9498 if (rhs
->expr_type
== EXPR_CONSTANT
)
9499 rlen
= rhs
->value
.character
.length
;
9501 else if (rhs
->ts
.u
.cl
!= NULL
9502 && rhs
->ts
.u
.cl
->length
!= NULL
9503 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9504 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9506 if (rlen
&& llen
&& rlen
> llen
)
9507 gfc_warning_now (OPT_Wcharacter_truncation
,
9508 "CHARACTER expression will be truncated "
9509 "in assignment (%d/%d) at %L",
9510 llen
, rlen
, &code
->loc
);
9513 /* Ensure that a vector index expression for the lvalue is evaluated
9514 to a temporary if the lvalue symbol is referenced in it. */
9517 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9518 if (ref
->type
== REF_ARRAY
)
9520 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9521 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9522 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9523 ref
->u
.ar
.start
[n
]))
9525 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9529 if (gfc_pure (NULL
))
9531 if (lhs
->ts
.type
== BT_DERIVED
9532 && lhs
->expr_type
== EXPR_VARIABLE
9533 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9534 && rhs
->expr_type
== EXPR_VARIABLE
9535 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9536 || gfc_is_coindexed (rhs
)))
9539 if (gfc_is_coindexed (rhs
))
9540 gfc_error ("Coindexed expression at %L is assigned to "
9541 "a derived type variable with a POINTER "
9542 "component in a PURE procedure",
9545 gfc_error ("The impure variable at %L is assigned to "
9546 "a derived type variable with a POINTER "
9547 "component in a PURE procedure (12.6)",
9552 /* Fortran 2008, C1283. */
9553 if (gfc_is_coindexed (lhs
))
9555 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9556 "procedure", &rhs
->where
);
9561 if (gfc_implicit_pure (NULL
))
9563 if (lhs
->expr_type
== EXPR_VARIABLE
9564 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9565 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9566 gfc_unset_implicit_pure (NULL
);
9568 if (lhs
->ts
.type
== BT_DERIVED
9569 && lhs
->expr_type
== EXPR_VARIABLE
9570 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9571 && rhs
->expr_type
== EXPR_VARIABLE
9572 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9573 || gfc_is_coindexed (rhs
)))
9574 gfc_unset_implicit_pure (NULL
);
9576 /* Fortran 2008, C1283. */
9577 if (gfc_is_coindexed (lhs
))
9578 gfc_unset_implicit_pure (NULL
);
9581 /* F2008, 7.2.1.2. */
9582 attr
= gfc_expr_attr (lhs
);
9583 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9585 if (attr
.codimension
)
9587 gfc_error ("Assignment to polymorphic coarray at %L is not "
9588 "permitted", &lhs
->where
);
9591 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9592 "polymorphic variable at %L", &lhs
->where
))
9594 if (!flag_realloc_lhs
)
9596 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9597 "requires %<-frealloc-lhs%>", &lhs
->where
);
9601 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9602 "is not yet supported", &lhs
->where
);
9605 else if (lhs
->ts
.type
== BT_CLASS
)
9607 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9608 "assignment at %L - check that there is a matching specific "
9609 "subroutine for '=' operator", &lhs
->where
);
9613 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9615 /* F2008, Section 7.2.1.2. */
9616 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9618 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9619 "component in assignment at %L", &lhs
->where
);
9623 gfc_check_assign (lhs
, rhs
, 1);
9625 /* Assign the 'data' of a class object to a derived type. */
9626 if (lhs
->ts
.type
== BT_DERIVED
9627 && rhs
->ts
.type
== BT_CLASS
)
9628 gfc_add_data_component (rhs
);
9630 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9631 Additionally, insert this code when the RHS is a CAF as we then use the
9632 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9633 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9634 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9636 if (flag_coarray
== GFC_FCOARRAY_LIB
9638 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9639 && code
->expr2
->value
.function
.isym
9640 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9641 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9642 && !gfc_expr_attr (rhs
).allocatable
9643 && !gfc_has_vector_subscript (rhs
))))
9645 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9646 && code
->expr2
->value
.function
.isym
9647 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9648 remove_caf_get_intrinsic (code
->expr2
);
9649 code
->op
= EXEC_CALL
;
9650 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9651 code
->resolved_sym
= code
->symtree
->n
.sym
;
9652 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9653 code
->resolved_sym
->attr
.intrinsic
= 1;
9654 code
->resolved_sym
->attr
.subroutine
= 1;
9655 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9656 gfc_commit_symbol (code
->resolved_sym
);
9657 code
->ext
.actual
= gfc_get_actual_arglist ();
9658 code
->ext
.actual
->expr
= lhs
;
9659 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9660 code
->ext
.actual
->next
->expr
= rhs
;
9669 /* Add a component reference onto an expression. */
9672 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9677 ref
= &((*ref
)->next
);
9678 *ref
= gfc_get_ref ();
9679 (*ref
)->type
= REF_COMPONENT
;
9680 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9681 (*ref
)->u
.c
.component
= c
;
9684 /* Add a full array ref, as necessary. */
9687 gfc_add_full_array_ref (e
, c
->as
);
9688 e
->rank
= c
->as
->rank
;
9693 /* Build an assignment. Keep the argument 'op' for future use, so that
9694 pointer assignments can be made. */
9697 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9698 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9700 gfc_code
*this_code
;
9702 this_code
= gfc_get_code (op
);
9703 this_code
->next
= NULL
;
9704 this_code
->expr1
= gfc_copy_expr (expr1
);
9705 this_code
->expr2
= gfc_copy_expr (expr2
);
9706 this_code
->loc
= loc
;
9709 add_comp_ref (this_code
->expr1
, comp1
);
9710 add_comp_ref (this_code
->expr2
, comp2
);
9717 /* Makes a temporary variable expression based on the characteristics of
9718 a given variable expression. */
9721 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9723 static int serial
= 0;
9724 char name
[GFC_MAX_SYMBOL_LEN
];
9727 gfc_array_ref
*aref
;
9730 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9731 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9732 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9738 /* This function could be expanded to support other expression type
9739 but this is not needed here. */
9740 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9742 /* Obtain the arrayspec for the temporary. */
9745 aref
= gfc_find_array_ref (e
);
9746 if (e
->expr_type
== EXPR_VARIABLE
9747 && e
->symtree
->n
.sym
->as
== aref
->as
)
9751 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9752 if (ref
->type
== REF_COMPONENT
9753 && ref
->u
.c
.component
->as
== aref
->as
)
9761 /* Add the attributes and the arrayspec to the temporary. */
9762 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9763 tmp
->n
.sym
->attr
.function
= 0;
9764 tmp
->n
.sym
->attr
.result
= 0;
9765 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9769 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9772 if (as
->type
== AS_DEFERRED
)
9773 tmp
->n
.sym
->attr
.allocatable
= 1;
9776 tmp
->n
.sym
->attr
.dimension
= 0;
9778 gfc_set_sym_referenced (tmp
->n
.sym
);
9779 gfc_commit_symbol (tmp
->n
.sym
);
9780 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9782 /* Should the lhs be a section, use its array ref for the
9783 temporary expression. */
9784 if (aref
&& aref
->type
!= AR_FULL
)
9786 gfc_free_ref_list (e
->ref
);
9787 e
->ref
= gfc_copy_ref (ref
);
9793 /* Add one line of code to the code chain, making sure that 'head' and
9794 'tail' are appropriately updated. */
9797 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9799 gcc_assert (this_code
);
9801 *head
= *tail
= *this_code
;
9803 *tail
= gfc_append_code (*tail
, *this_code
);
9808 /* Counts the potential number of part array references that would
9809 result from resolution of typebound defined assignments. */
9812 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9815 int c_depth
= 0, t_depth
;
9817 for (c
= derived
->components
; c
; c
= c
->next
)
9819 if ((c
->ts
.type
!= BT_DERIVED
9821 || c
->attr
.allocatable
9822 || c
->attr
.proc_pointer_comp
9823 || c
->attr
.class_pointer
9824 || c
->attr
.proc_pointer
)
9825 && !c
->attr
.defined_assign_comp
)
9828 if (c
->as
&& c_depth
== 0)
9831 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9832 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9837 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9839 return depth
+ c_depth
;
9843 /* Implement 7.2.1.3 of the F08 standard:
9844 "An intrinsic assignment where the variable is of derived type is
9845 performed as if each component of the variable were assigned from the
9846 corresponding component of expr using pointer assignment (7.2.2) for
9847 each pointer component, defined assignment for each nonpointer
9848 nonallocatable component of a type that has a type-bound defined
9849 assignment consistent with the component, intrinsic assignment for
9850 each other nonpointer nonallocatable component, ..."
9852 The pointer assignments are taken care of by the intrinsic
9853 assignment of the structure itself. This function recursively adds
9854 defined assignments where required. The recursion is accomplished
9855 by calling gfc_resolve_code.
9857 When the lhs in a defined assignment has intent INOUT, we need a
9858 temporary for the lhs. In pseudo-code:
9860 ! Only call function lhs once.
9861 if (lhs is not a constant or an variable)
9864 ! Do the intrinsic assignment
9866 ! Now do the defined assignments
9867 do over components with typebound defined assignment [%cmp]
9868 #if one component's assignment procedure is INOUT
9870 #if expr2 non-variable
9876 t1%cmp {defined=} expr2%cmp
9882 expr1%cmp {defined=} expr2%cmp
9886 /* The temporary assignments have to be put on top of the additional
9887 code to avoid the result being changed by the intrinsic assignment.
9889 static int component_assignment_level
= 0;
9890 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9893 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9895 gfc_component
*comp1
, *comp2
;
9896 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9898 int error_count
, depth
;
9900 gfc_get_errors (NULL
, &error_count
);
9902 /* Filter out continuing processing after an error. */
9904 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9905 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9908 /* TODO: Handle more than one part array reference in assignments. */
9909 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9910 (*code
)->expr1
->rank
? 1 : 0);
9913 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
9914 "done because multiple part array references would "
9915 "occur in intermediate expressions.", &(*code
)->loc
);
9919 component_assignment_level
++;
9921 /* Create a temporary so that functions get called only once. */
9922 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9923 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9927 /* Assign the rhs to the temporary. */
9928 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9929 this_code
= build_assignment (EXEC_ASSIGN
,
9930 tmp_expr
, (*code
)->expr2
,
9931 NULL
, NULL
, (*code
)->loc
);
9932 /* Add the code and substitute the rhs expression. */
9933 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9934 gfc_free_expr ((*code
)->expr2
);
9935 (*code
)->expr2
= tmp_expr
;
9938 /* Do the intrinsic assignment. This is not needed if the lhs is one
9939 of the temporaries generated here, since the intrinsic assignment
9940 to the final result already does this. */
9941 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9943 this_code
= build_assignment (EXEC_ASSIGN
,
9944 (*code
)->expr1
, (*code
)->expr2
,
9945 NULL
, NULL
, (*code
)->loc
);
9946 add_code_to_chain (&this_code
, &head
, &tail
);
9949 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9950 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9953 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9957 /* The intrinsic assignment does the right thing for pointers
9958 of all kinds and allocatable components. */
9959 if (comp1
->ts
.type
!= BT_DERIVED
9960 || comp1
->attr
.pointer
9961 || comp1
->attr
.allocatable
9962 || comp1
->attr
.proc_pointer_comp
9963 || comp1
->attr
.class_pointer
9964 || comp1
->attr
.proc_pointer
)
9967 /* Make an assigment for this component. */
9968 this_code
= build_assignment (EXEC_ASSIGN
,
9969 (*code
)->expr1
, (*code
)->expr2
,
9970 comp1
, comp2
, (*code
)->loc
);
9972 /* Convert the assignment if there is a defined assignment for
9973 this type. Otherwise, using the call from gfc_resolve_code,
9974 recurse into its components. */
9975 gfc_resolve_code (this_code
, ns
);
9977 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9979 gfc_formal_arglist
*dummy_args
;
9981 /* Check that there is a typebound defined assignment. If not,
9982 then this must be a module defined assignment. We cannot
9983 use the defined_assign_comp attribute here because it must
9984 be this derived type that has the defined assignment and not
9986 if (!(comp1
->ts
.u
.derived
->f2k_derived
9987 && comp1
->ts
.u
.derived
->f2k_derived
9988 ->tb_op
[INTRINSIC_ASSIGN
]))
9990 gfc_free_statements (this_code
);
9995 /* If the first argument of the subroutine has intent INOUT
9996 a temporary must be generated and used instead. */
9997 rsym
= this_code
->resolved_sym
;
9998 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10000 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10002 gfc_code
*temp_code
;
10005 /* Build the temporary required for the assignment and put
10006 it at the head of the generated code. */
10009 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10010 temp_code
= build_assignment (EXEC_ASSIGN
,
10011 t1
, (*code
)->expr1
,
10012 NULL
, NULL
, (*code
)->loc
);
10014 /* For allocatable LHS, check whether it is allocated. Note
10015 that allocatable components with defined assignment are
10016 not yet support. See PR 57696. */
10017 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10021 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10022 block
= gfc_get_code (EXEC_IF
);
10023 block
->block
= gfc_get_code (EXEC_IF
);
10024 block
->block
->expr1
10025 = gfc_build_intrinsic_call (ns
,
10026 GFC_ISYM_ALLOCATED
, "allocated",
10027 (*code
)->loc
, 1, e
);
10028 block
->block
->next
= temp_code
;
10031 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10034 /* Replace the first actual arg with the component of the
10036 gfc_free_expr (this_code
->ext
.actual
->expr
);
10037 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10038 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10040 /* If the LHS variable is allocatable and wasn't allocated and
10041 the temporary is allocatable, pointer assign the address of
10042 the freshly allocated LHS to the temporary. */
10043 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10044 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10049 cond
= gfc_get_expr ();
10050 cond
->ts
.type
= BT_LOGICAL
;
10051 cond
->ts
.kind
= gfc_default_logical_kind
;
10052 cond
->expr_type
= EXPR_OP
;
10053 cond
->where
= (*code
)->loc
;
10054 cond
->value
.op
.op
= INTRINSIC_NOT
;
10055 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10056 GFC_ISYM_ALLOCATED
, "allocated",
10057 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10058 block
= gfc_get_code (EXEC_IF
);
10059 block
->block
= gfc_get_code (EXEC_IF
);
10060 block
->block
->expr1
= cond
;
10061 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10062 t1
, (*code
)->expr1
,
10063 NULL
, NULL
, (*code
)->loc
);
10064 add_code_to_chain (&block
, &head
, &tail
);
10068 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10070 /* Don't add intrinsic assignments since they are already
10071 effected by the intrinsic assignment of the structure. */
10072 gfc_free_statements (this_code
);
10077 add_code_to_chain (&this_code
, &head
, &tail
);
10081 /* Transfer the value to the final result. */
10082 this_code
= build_assignment (EXEC_ASSIGN
,
10083 (*code
)->expr1
, t1
,
10084 comp1
, comp2
, (*code
)->loc
);
10085 add_code_to_chain (&this_code
, &head
, &tail
);
10089 /* Put the temporary assignments at the top of the generated code. */
10090 if (tmp_head
&& component_assignment_level
== 1)
10092 gfc_append_code (tmp_head
, head
);
10094 tmp_head
= tmp_tail
= NULL
;
10097 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10098 // not accidentally deallocated. Hence, nullify t1.
10099 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10100 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10106 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10107 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10108 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10109 block
= gfc_get_code (EXEC_IF
);
10110 block
->block
= gfc_get_code (EXEC_IF
);
10111 block
->block
->expr1
= cond
;
10112 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10113 t1
, gfc_get_null_expr (&(*code
)->loc
),
10114 NULL
, NULL
, (*code
)->loc
);
10115 gfc_append_code (tail
, block
);
10119 /* Now attach the remaining code chain to the input code. Step on
10120 to the end of the new code since resolution is complete. */
10121 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10122 tail
->next
= (*code
)->next
;
10123 /* Overwrite 'code' because this would place the intrinsic assignment
10124 before the temporary for the lhs is created. */
10125 gfc_free_expr ((*code
)->expr1
);
10126 gfc_free_expr ((*code
)->expr2
);
10132 component_assignment_level
--;
10136 /* Given a block of code, recursively resolve everything pointed to by this
10140 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10142 int omp_workshare_save
;
10143 int forall_save
, do_concurrent_save
;
10147 frame
.prev
= cs_base
;
10151 find_reachable_labels (code
);
10153 for (; code
; code
= code
->next
)
10155 frame
.current
= code
;
10156 forall_save
= forall_flag
;
10157 do_concurrent_save
= gfc_do_concurrent_flag
;
10159 if (code
->op
== EXEC_FORALL
)
10162 gfc_resolve_forall (code
, ns
, forall_save
);
10165 else if (code
->block
)
10167 omp_workshare_save
= -1;
10170 case EXEC_OACC_PARALLEL_LOOP
:
10171 case EXEC_OACC_PARALLEL
:
10172 case EXEC_OACC_KERNELS_LOOP
:
10173 case EXEC_OACC_KERNELS
:
10174 case EXEC_OACC_DATA
:
10175 case EXEC_OACC_HOST_DATA
:
10176 case EXEC_OACC_LOOP
:
10177 gfc_resolve_oacc_blocks (code
, ns
);
10179 case EXEC_OMP_PARALLEL_WORKSHARE
:
10180 omp_workshare_save
= omp_workshare_flag
;
10181 omp_workshare_flag
= 1;
10182 gfc_resolve_omp_parallel_blocks (code
, ns
);
10184 case EXEC_OMP_PARALLEL
:
10185 case EXEC_OMP_PARALLEL_DO
:
10186 case EXEC_OMP_PARALLEL_DO_SIMD
:
10187 case EXEC_OMP_PARALLEL_SECTIONS
:
10188 case EXEC_OMP_TARGET_TEAMS
:
10189 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10190 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10191 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10192 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10193 case EXEC_OMP_TASK
:
10194 case EXEC_OMP_TEAMS
:
10195 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10196 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10197 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10198 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10199 omp_workshare_save
= omp_workshare_flag
;
10200 omp_workshare_flag
= 0;
10201 gfc_resolve_omp_parallel_blocks (code
, ns
);
10203 case EXEC_OMP_DISTRIBUTE
:
10204 case EXEC_OMP_DISTRIBUTE_SIMD
:
10206 case EXEC_OMP_DO_SIMD
:
10207 case EXEC_OMP_SIMD
:
10208 gfc_resolve_omp_do_blocks (code
, ns
);
10210 case EXEC_SELECT_TYPE
:
10211 /* Blocks are handled in resolve_select_type because we have
10212 to transform the SELECT TYPE into ASSOCIATE first. */
10214 case EXEC_DO_CONCURRENT
:
10215 gfc_do_concurrent_flag
= 1;
10216 gfc_resolve_blocks (code
->block
, ns
);
10217 gfc_do_concurrent_flag
= 2;
10219 case EXEC_OMP_WORKSHARE
:
10220 omp_workshare_save
= omp_workshare_flag
;
10221 omp_workshare_flag
= 1;
10224 gfc_resolve_blocks (code
->block
, ns
);
10228 if (omp_workshare_save
!= -1)
10229 omp_workshare_flag
= omp_workshare_save
;
10233 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10234 t
= gfc_resolve_expr (code
->expr1
);
10235 forall_flag
= forall_save
;
10236 gfc_do_concurrent_flag
= do_concurrent_save
;
10238 if (!gfc_resolve_expr (code
->expr2
))
10241 if (code
->op
== EXEC_ALLOCATE
10242 && !gfc_resolve_expr (code
->expr3
))
10248 case EXEC_END_BLOCK
:
10249 case EXEC_END_NESTED_BLOCK
:
10253 case EXEC_ERROR_STOP
:
10255 case EXEC_CONTINUE
:
10257 case EXEC_ASSIGN_CALL
:
10260 case EXEC_CRITICAL
:
10261 resolve_critical (code
);
10264 case EXEC_SYNC_ALL
:
10265 case EXEC_SYNC_IMAGES
:
10266 case EXEC_SYNC_MEMORY
:
10267 resolve_sync (code
);
10272 resolve_lock_unlock (code
);
10276 /* Keep track of which entry we are up to. */
10277 current_entry_id
= code
->ext
.entry
->id
;
10281 resolve_where (code
, NULL
);
10285 if (code
->expr1
!= NULL
)
10287 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10288 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10289 "INTEGER variable", &code
->expr1
->where
);
10290 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10291 gfc_error ("Variable %qs has not been assigned a target "
10292 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10293 &code
->expr1
->where
);
10296 resolve_branch (code
->label1
, code
);
10300 if (code
->expr1
!= NULL
10301 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10302 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10303 "INTEGER return specifier", &code
->expr1
->where
);
10306 case EXEC_INIT_ASSIGN
:
10307 case EXEC_END_PROCEDURE
:
10314 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10316 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10317 && code
->expr1
->value
.function
.isym
10318 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10319 remove_caf_get_intrinsic (code
->expr1
);
10321 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10325 if (resolve_ordinary_assign (code
, ns
))
10327 if (code
->op
== EXEC_COMPCALL
)
10333 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10334 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10335 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10336 generate_component_assignments (&code
, ns
);
10340 case EXEC_LABEL_ASSIGN
:
10341 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10342 gfc_error ("Label %d referenced at %L is never defined",
10343 code
->label1
->value
, &code
->label1
->where
);
10345 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10346 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10347 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10348 != gfc_default_integer_kind
10349 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10350 gfc_error ("ASSIGN statement at %L requires a scalar "
10351 "default INTEGER variable", &code
->expr1
->where
);
10354 case EXEC_POINTER_ASSIGN
:
10361 /* This is both a variable definition and pointer assignment
10362 context, so check both of them. For rank remapping, a final
10363 array ref may be present on the LHS and fool gfc_expr_attr
10364 used in gfc_check_vardef_context. Remove it. */
10365 e
= remove_last_array_ref (code
->expr1
);
10366 t
= gfc_check_vardef_context (e
, true, false, false,
10367 _("pointer assignment"));
10369 t
= gfc_check_vardef_context (e
, false, false, false,
10370 _("pointer assignment"));
10375 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10379 case EXEC_ARITHMETIC_IF
:
10381 gfc_expr
*e
= code
->expr1
;
10383 gfc_resolve_expr (e
);
10384 if (e
->expr_type
== EXPR_NULL
)
10385 gfc_error ("Invalid NULL at %L", &e
->where
);
10387 if (t
&& (e
->rank
> 0
10388 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
10389 gfc_error ("Arithmetic IF statement at %L requires a scalar "
10390 "REAL or INTEGER expression", &e
->where
);
10392 resolve_branch (code
->label1
, code
);
10393 resolve_branch (code
->label2
, code
);
10394 resolve_branch (code
->label3
, code
);
10399 if (t
&& code
->expr1
!= NULL
10400 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10401 || code
->expr1
->rank
!= 0))
10402 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10403 &code
->expr1
->where
);
10408 resolve_call (code
);
10411 case EXEC_COMPCALL
:
10413 resolve_typebound_subroutine (code
);
10416 case EXEC_CALL_PPC
:
10417 resolve_ppc_call (code
);
10421 /* Select is complicated. Also, a SELECT construct could be
10422 a transformed computed GOTO. */
10423 resolve_select (code
, false);
10426 case EXEC_SELECT_TYPE
:
10427 resolve_select_type (code
, ns
);
10431 resolve_block_construct (code
);
10435 if (code
->ext
.iterator
!= NULL
)
10437 gfc_iterator
*iter
= code
->ext
.iterator
;
10438 if (gfc_resolve_iterator (iter
, true, false))
10439 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10443 case EXEC_DO_WHILE
:
10444 if (code
->expr1
== NULL
)
10445 gfc_internal_error ("gfc_resolve_code(): No expression on "
10448 && (code
->expr1
->rank
!= 0
10449 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10450 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10451 "a scalar LOGICAL expression", &code
->expr1
->where
);
10454 case EXEC_ALLOCATE
:
10456 resolve_allocate_deallocate (code
, "ALLOCATE");
10460 case EXEC_DEALLOCATE
:
10462 resolve_allocate_deallocate (code
, "DEALLOCATE");
10467 if (!gfc_resolve_open (code
->ext
.open
))
10470 resolve_branch (code
->ext
.open
->err
, code
);
10474 if (!gfc_resolve_close (code
->ext
.close
))
10477 resolve_branch (code
->ext
.close
->err
, code
);
10480 case EXEC_BACKSPACE
:
10484 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10487 resolve_branch (code
->ext
.filepos
->err
, code
);
10491 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10494 resolve_branch (code
->ext
.inquire
->err
, code
);
10497 case EXEC_IOLENGTH
:
10498 gcc_assert (code
->ext
.inquire
!= NULL
);
10499 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10502 resolve_branch (code
->ext
.inquire
->err
, code
);
10506 if (!gfc_resolve_wait (code
->ext
.wait
))
10509 resolve_branch (code
->ext
.wait
->err
, code
);
10510 resolve_branch (code
->ext
.wait
->end
, code
);
10511 resolve_branch (code
->ext
.wait
->eor
, code
);
10516 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10519 resolve_branch (code
->ext
.dt
->err
, code
);
10520 resolve_branch (code
->ext
.dt
->end
, code
);
10521 resolve_branch (code
->ext
.dt
->eor
, code
);
10524 case EXEC_TRANSFER
:
10525 resolve_transfer (code
);
10528 case EXEC_DO_CONCURRENT
:
10530 resolve_forall_iterators (code
->ext
.forall_iterator
);
10532 if (code
->expr1
!= NULL
10533 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10534 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10535 "expression", &code
->expr1
->where
);
10538 case EXEC_OACC_PARALLEL_LOOP
:
10539 case EXEC_OACC_PARALLEL
:
10540 case EXEC_OACC_KERNELS_LOOP
:
10541 case EXEC_OACC_KERNELS
:
10542 case EXEC_OACC_DATA
:
10543 case EXEC_OACC_HOST_DATA
:
10544 case EXEC_OACC_LOOP
:
10545 case EXEC_OACC_UPDATE
:
10546 case EXEC_OACC_WAIT
:
10547 case EXEC_OACC_CACHE
:
10548 case EXEC_OACC_ENTER_DATA
:
10549 case EXEC_OACC_EXIT_DATA
:
10550 gfc_resolve_oacc_directive (code
, ns
);
10553 case EXEC_OMP_ATOMIC
:
10554 case EXEC_OMP_BARRIER
:
10555 case EXEC_OMP_CANCEL
:
10556 case EXEC_OMP_CANCELLATION_POINT
:
10557 case EXEC_OMP_CRITICAL
:
10558 case EXEC_OMP_FLUSH
:
10559 case EXEC_OMP_DISTRIBUTE
:
10560 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10561 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10562 case EXEC_OMP_DISTRIBUTE_SIMD
:
10564 case EXEC_OMP_DO_SIMD
:
10565 case EXEC_OMP_MASTER
:
10566 case EXEC_OMP_ORDERED
:
10567 case EXEC_OMP_SECTIONS
:
10568 case EXEC_OMP_SIMD
:
10569 case EXEC_OMP_SINGLE
:
10570 case EXEC_OMP_TARGET
:
10571 case EXEC_OMP_TARGET_DATA
:
10572 case EXEC_OMP_TARGET_TEAMS
:
10573 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10574 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10575 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10576 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10577 case EXEC_OMP_TARGET_UPDATE
:
10578 case EXEC_OMP_TASK
:
10579 case EXEC_OMP_TASKGROUP
:
10580 case EXEC_OMP_TASKWAIT
:
10581 case EXEC_OMP_TASKYIELD
:
10582 case EXEC_OMP_TEAMS
:
10583 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10584 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10585 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10586 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10587 case EXEC_OMP_WORKSHARE
:
10588 gfc_resolve_omp_directive (code
, ns
);
10591 case EXEC_OMP_PARALLEL
:
10592 case EXEC_OMP_PARALLEL_DO
:
10593 case EXEC_OMP_PARALLEL_DO_SIMD
:
10594 case EXEC_OMP_PARALLEL_SECTIONS
:
10595 case EXEC_OMP_PARALLEL_WORKSHARE
:
10596 omp_workshare_save
= omp_workshare_flag
;
10597 omp_workshare_flag
= 0;
10598 gfc_resolve_omp_directive (code
, ns
);
10599 omp_workshare_flag
= omp_workshare_save
;
10603 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10607 cs_base
= frame
.prev
;
10611 /* Resolve initial values and make sure they are compatible with
10615 resolve_values (gfc_symbol
*sym
)
10619 if (sym
->value
== NULL
)
10622 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10623 t
= resolve_structure_cons (sym
->value
, 1);
10625 t
= gfc_resolve_expr (sym
->value
);
10630 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10634 /* Verify any BIND(C) derived types in the namespace so we can report errors
10635 for them once, rather than for each variable declared of that type. */
10638 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10640 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10641 && derived_sym
->attr
.is_bind_c
== 1)
10642 verify_bind_c_derived_type (derived_sym
);
10648 /* Verify that any binding labels used in a given namespace do not collide
10649 with the names or binding labels of any global symbols. Multiple INTERFACE
10650 for the same procedure are permitted. */
10653 gfc_verify_binding_labels (gfc_symbol
*sym
)
10656 const char *module
;
10658 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10659 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10662 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10665 module
= sym
->module
;
10666 else if (sym
->ns
&& sym
->ns
->proc_name
10667 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10668 module
= sym
->ns
->proc_name
->name
;
10669 else if (sym
->ns
&& sym
->ns
->parent
10670 && sym
->ns
&& sym
->ns
->parent
->proc_name
10671 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10672 module
= sym
->ns
->parent
->proc_name
->name
;
10678 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10681 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10682 gsym
->where
= sym
->declared_at
;
10683 gsym
->sym_name
= sym
->name
;
10684 gsym
->binding_label
= sym
->binding_label
;
10685 gsym
->ns
= sym
->ns
;
10686 gsym
->mod_name
= module
;
10687 if (sym
->attr
.function
)
10688 gsym
->type
= GSYM_FUNCTION
;
10689 else if (sym
->attr
.subroutine
)
10690 gsym
->type
= GSYM_SUBROUTINE
;
10691 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10692 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10696 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10698 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10699 "identifier as entity at %L", sym
->name
,
10700 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10701 /* Clear the binding label to prevent checking multiple times. */
10702 sym
->binding_label
= NULL
;
10705 else if (sym
->attr
.flavor
== FL_VARIABLE
10706 && (strcmp (module
, gsym
->mod_name
) != 0
10707 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10709 /* This can only happen if the variable is defined in a module - if it
10710 isn't the same module, reject it. */
10711 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10712 "the same global identifier as entity at %L from module %s",
10713 sym
->name
, module
, sym
->binding_label
,
10714 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10715 sym
->binding_label
= NULL
;
10717 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10718 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10719 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10720 && sym
!= gsym
->ns
->proc_name
10721 && (module
!= gsym
->mod_name
10722 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10723 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10725 /* Print an error if the procedure is defined multiple times; we have to
10726 exclude references to the same procedure via module association or
10727 multiple checks for the same procedure. */
10728 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10729 "global identifier as entity at %L", sym
->name
,
10730 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10731 sym
->binding_label
= NULL
;
10736 /* Resolve an index expression. */
10739 resolve_index_expr (gfc_expr
*e
)
10741 if (!gfc_resolve_expr (e
))
10744 if (!gfc_simplify_expr (e
, 0))
10747 if (!gfc_specification_expr (e
))
10754 /* Resolve a charlen structure. */
10757 resolve_charlen (gfc_charlen
*cl
)
10760 bool saved_specification_expr
;
10766 saved_specification_expr
= specification_expr
;
10767 specification_expr
= true;
10769 if (cl
->length_from_typespec
)
10771 if (!gfc_resolve_expr (cl
->length
))
10773 specification_expr
= saved_specification_expr
;
10777 if (!gfc_simplify_expr (cl
->length
, 0))
10779 specification_expr
= saved_specification_expr
;
10786 if (!resolve_index_expr (cl
->length
))
10788 specification_expr
= saved_specification_expr
;
10793 /* "If the character length parameter value evaluates to a negative
10794 value, the length of character entities declared is zero." */
10795 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10797 if (warn_surprising
)
10798 gfc_warning_now (OPT_Wsurprising
,
10799 "CHARACTER variable at %L has negative length %d,"
10800 " the length has been set to zero",
10801 &cl
->length
->where
, i
);
10802 gfc_replace_expr (cl
->length
,
10803 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10806 /* Check that the character length is not too large. */
10807 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10808 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10809 && cl
->length
->ts
.type
== BT_INTEGER
10810 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10812 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10813 specification_expr
= saved_specification_expr
;
10817 specification_expr
= saved_specification_expr
;
10822 /* Test for non-constant shape arrays. */
10825 is_non_constant_shape_array (gfc_symbol
*sym
)
10831 not_constant
= false;
10832 if (sym
->as
!= NULL
)
10834 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10835 has not been simplified; parameter array references. Do the
10836 simplification now. */
10837 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10839 e
= sym
->as
->lower
[i
];
10840 if (e
&& (!resolve_index_expr(e
)
10841 || !gfc_is_constant_expr (e
)))
10842 not_constant
= true;
10843 e
= sym
->as
->upper
[i
];
10844 if (e
&& (!resolve_index_expr(e
)
10845 || !gfc_is_constant_expr (e
)))
10846 not_constant
= true;
10849 return not_constant
;
10852 /* Given a symbol and an initialization expression, add code to initialize
10853 the symbol to the function entry. */
10855 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10859 gfc_namespace
*ns
= sym
->ns
;
10861 /* Search for the function namespace if this is a contained
10862 function without an explicit result. */
10863 if (sym
->attr
.function
&& sym
== sym
->result
10864 && sym
->name
!= sym
->ns
->proc_name
->name
)
10866 ns
= ns
->contained
;
10867 for (;ns
; ns
= ns
->sibling
)
10868 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10874 gfc_free_expr (init
);
10878 /* Build an l-value expression for the result. */
10879 lval
= gfc_lval_expr_from_sym (sym
);
10881 /* Add the code at scope entry. */
10882 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10883 init_st
->next
= ns
->code
;
10884 ns
->code
= init_st
;
10886 /* Assign the default initializer to the l-value. */
10887 init_st
->loc
= sym
->declared_at
;
10888 init_st
->expr1
= lval
;
10889 init_st
->expr2
= init
;
10892 /* Assign the default initializer to a derived type variable or result. */
10895 apply_default_init (gfc_symbol
*sym
)
10897 gfc_expr
*init
= NULL
;
10899 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10902 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10903 init
= gfc_default_initializer (&sym
->ts
);
10905 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10908 build_init_assign (sym
, init
);
10909 sym
->attr
.referenced
= 1;
10912 /* Build an initializer for a local integer, real, complex, logical, or
10913 character variable, based on the command line flags finit-local-zero,
10914 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10915 null if the symbol should not have a default initialization. */
10917 build_default_init_expr (gfc_symbol
*sym
)
10920 gfc_expr
*init_expr
;
10923 /* These symbols should never have a default initialization. */
10924 if (sym
->attr
.allocatable
10925 || sym
->attr
.external
10927 || sym
->attr
.pointer
10928 || sym
->attr
.in_equivalence
10929 || sym
->attr
.in_common
10932 || sym
->attr
.cray_pointee
10933 || sym
->attr
.cray_pointer
10937 /* Now we'll try to build an initializer expression. */
10938 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10939 &sym
->declared_at
);
10941 /* We will only initialize integers, reals, complex, logicals, and
10942 characters, and only if the corresponding command-line flags
10943 were set. Otherwise, we free init_expr and return null. */
10944 switch (sym
->ts
.type
)
10947 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10948 mpz_set_si (init_expr
->value
.integer
,
10949 gfc_option
.flag_init_integer_value
);
10952 gfc_free_expr (init_expr
);
10958 switch (flag_init_real
)
10960 case GFC_INIT_REAL_SNAN
:
10961 init_expr
->is_snan
= 1;
10962 /* Fall through. */
10963 case GFC_INIT_REAL_NAN
:
10964 mpfr_set_nan (init_expr
->value
.real
);
10967 case GFC_INIT_REAL_INF
:
10968 mpfr_set_inf (init_expr
->value
.real
, 1);
10971 case GFC_INIT_REAL_NEG_INF
:
10972 mpfr_set_inf (init_expr
->value
.real
, -1);
10975 case GFC_INIT_REAL_ZERO
:
10976 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10980 gfc_free_expr (init_expr
);
10987 switch (flag_init_real
)
10989 case GFC_INIT_REAL_SNAN
:
10990 init_expr
->is_snan
= 1;
10991 /* Fall through. */
10992 case GFC_INIT_REAL_NAN
:
10993 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10994 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10997 case GFC_INIT_REAL_INF
:
10998 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10999 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
11002 case GFC_INIT_REAL_NEG_INF
:
11003 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
11004 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
11007 case GFC_INIT_REAL_ZERO
:
11008 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
11012 gfc_free_expr (init_expr
);
11019 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
11020 init_expr
->value
.logical
= 0;
11021 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
11022 init_expr
->value
.logical
= 1;
11025 gfc_free_expr (init_expr
);
11031 /* For characters, the length must be constant in order to
11032 create a default initializer. */
11033 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
11034 && sym
->ts
.u
.cl
->length
11035 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11037 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
11038 init_expr
->value
.character
.length
= char_len
;
11039 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
11040 for (i
= 0; i
< char_len
; i
++)
11041 init_expr
->value
.character
.string
[i
]
11042 = (unsigned char) gfc_option
.flag_init_character_value
;
11046 gfc_free_expr (init_expr
);
11049 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
11050 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
11052 gfc_actual_arglist
*arg
;
11053 init_expr
= gfc_get_expr ();
11054 init_expr
->where
= sym
->declared_at
;
11055 init_expr
->ts
= sym
->ts
;
11056 init_expr
->expr_type
= EXPR_FUNCTION
;
11057 init_expr
->value
.function
.isym
=
11058 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
11059 init_expr
->value
.function
.name
= "repeat";
11060 arg
= gfc_get_actual_arglist ();
11061 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
11063 arg
->expr
->value
.character
.string
[0]
11064 = gfc_option
.flag_init_character_value
;
11065 arg
->next
= gfc_get_actual_arglist ();
11066 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
11067 init_expr
->value
.function
.actual
= arg
;
11072 gfc_free_expr (init_expr
);
11078 /* Add an initialization expression to a local variable. */
11080 apply_default_init_local (gfc_symbol
*sym
)
11082 gfc_expr
*init
= NULL
;
11084 /* The symbol should be a variable or a function return value. */
11085 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11086 || (sym
->attr
.function
&& sym
->result
!= sym
))
11089 /* Try to build the initializer expression. If we can't initialize
11090 this symbol, then init will be NULL. */
11091 init
= build_default_init_expr (sym
);
11095 /* For saved variables, we don't want to add an initializer at function
11096 entry, so we just add a static initializer. Note that automatic variables
11097 are stack allocated even with -fno-automatic; we have also to exclude
11098 result variable, which are also nonstatic. */
11099 if (sym
->attr
.save
|| sym
->ns
->save_all
11100 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11101 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11102 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
11104 /* Don't clobber an existing initializer! */
11105 gcc_assert (sym
->value
== NULL
);
11110 build_init_assign (sym
, init
);
11114 /* Resolution of common features of flavors variable and procedure. */
11117 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11119 gfc_array_spec
*as
;
11121 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11122 as
= CLASS_DATA (sym
)->as
;
11126 /* Constraints on deferred shape variable. */
11127 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11129 bool pointer
, allocatable
, dimension
;
11131 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11133 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11134 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11135 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11139 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11140 allocatable
= sym
->attr
.allocatable
;
11141 dimension
= sym
->attr
.dimension
;
11146 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11148 gfc_error ("Allocatable array %qs at %L must have a deferred "
11149 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11152 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11153 "%qs at %L may not be ALLOCATABLE",
11154 sym
->name
, &sym
->declared_at
))
11158 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11160 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11161 "assumed rank", sym
->name
, &sym
->declared_at
);
11167 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11168 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11170 gfc_error ("Array %qs at %L cannot have a deferred shape",
11171 sym
->name
, &sym
->declared_at
);
11176 /* Constraints on polymorphic variables. */
11177 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11180 if (sym
->attr
.class_ok
11181 && !sym
->attr
.select_type_temporary
11182 && !UNLIMITED_POLY (sym
)
11183 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11185 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11186 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11187 &sym
->declared_at
);
11192 /* Assume that use associated symbols were checked in the module ns.
11193 Class-variables that are associate-names are also something special
11194 and excepted from the test. */
11195 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11197 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11198 "or pointer", sym
->name
, &sym
->declared_at
);
11207 /* Additional checks for symbols with flavor variable and derived
11208 type. To be called from resolve_fl_variable. */
11211 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11213 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11215 /* Check to see if a derived type is blocked from being host
11216 associated by the presence of another class I symbol in the same
11217 namespace. 14.6.1.3 of the standard and the discussion on
11218 comp.lang.fortran. */
11219 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11220 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11223 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11224 if (s
&& s
->attr
.generic
)
11225 s
= gfc_find_dt_in_generic (s
);
11226 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11228 gfc_error ("The type %qs cannot be host associated at %L "
11229 "because it is blocked by an incompatible object "
11230 "of the same name declared at %L",
11231 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11237 /* 4th constraint in section 11.3: "If an object of a type for which
11238 component-initialization is specified (R429) appears in the
11239 specification-part of a module and does not have the ALLOCATABLE
11240 or POINTER attribute, the object shall have the SAVE attribute."
11242 The check for initializers is performed with
11243 gfc_has_default_initializer because gfc_default_initializer generates
11244 a hidden default for allocatable components. */
11245 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11246 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11247 && !sym
->ns
->save_all
&& !sym
->attr
.save
11248 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11249 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11250 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11251 "%qs at %L, needed due to the default "
11252 "initialization", sym
->name
, &sym
->declared_at
))
11255 /* Assign default initializer. */
11256 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11257 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11259 sym
->value
= gfc_default_initializer (&sym
->ts
);
11266 /* Resolve symbols with flavor variable. */
11269 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11271 int no_init_flag
, automatic_flag
;
11273 const char *auto_save_msg
;
11274 bool saved_specification_expr
;
11276 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11279 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11282 /* Set this flag to check that variables are parameters of all entries.
11283 This check is effected by the call to gfc_resolve_expr through
11284 is_non_constant_shape_array. */
11285 saved_specification_expr
= specification_expr
;
11286 specification_expr
= true;
11288 if (sym
->ns
->proc_name
11289 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11290 || sym
->ns
->proc_name
->attr
.is_main_program
)
11291 && !sym
->attr
.use_assoc
11292 && !sym
->attr
.allocatable
11293 && !sym
->attr
.pointer
11294 && is_non_constant_shape_array (sym
))
11296 /* The shape of a main program or module array needs to be
11298 gfc_error ("The module or main program array %qs at %L must "
11299 "have constant shape", sym
->name
, &sym
->declared_at
);
11300 specification_expr
= saved_specification_expr
;
11304 /* Constraints on deferred type parameter. */
11305 if (sym
->ts
.deferred
11306 && !(sym
->attr
.pointer
11307 || sym
->attr
.allocatable
11308 || sym
->attr
.omp_udr_artificial_var
))
11310 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11311 "requires either the pointer or allocatable attribute",
11312 sym
->name
, &sym
->declared_at
);
11313 specification_expr
= saved_specification_expr
;
11317 if (sym
->ts
.type
== BT_CHARACTER
)
11319 /* Make sure that character string variables with assumed length are
11320 dummy arguments. */
11321 e
= sym
->ts
.u
.cl
->length
;
11322 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11323 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11324 && !sym
->attr
.omp_udr_artificial_var
)
11326 gfc_error ("Entity with assumed character length at %L must be a "
11327 "dummy argument or a PARAMETER", &sym
->declared_at
);
11328 specification_expr
= saved_specification_expr
;
11332 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11334 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11335 specification_expr
= saved_specification_expr
;
11339 if (!gfc_is_constant_expr (e
)
11340 && !(e
->expr_type
== EXPR_VARIABLE
11341 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11343 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11344 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11345 || sym
->ns
->proc_name
->attr
.is_main_program
))
11347 gfc_error ("%qs at %L must have constant character length "
11348 "in this context", sym
->name
, &sym
->declared_at
);
11349 specification_expr
= saved_specification_expr
;
11352 if (sym
->attr
.in_common
)
11354 gfc_error ("COMMON variable %qs at %L must have constant "
11355 "character length", sym
->name
, &sym
->declared_at
);
11356 specification_expr
= saved_specification_expr
;
11362 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11363 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11365 /* Determine if the symbol may not have an initializer. */
11366 no_init_flag
= automatic_flag
= 0;
11367 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11368 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11370 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11371 && is_non_constant_shape_array (sym
))
11373 no_init_flag
= automatic_flag
= 1;
11375 /* Also, they must not have the SAVE attribute.
11376 SAVE_IMPLICIT is checked below. */
11377 if (sym
->as
&& sym
->attr
.codimension
)
11379 int corank
= sym
->as
->corank
;
11380 sym
->as
->corank
= 0;
11381 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11382 sym
->as
->corank
= corank
;
11384 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11386 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11387 specification_expr
= saved_specification_expr
;
11392 /* Ensure that any initializer is simplified. */
11394 gfc_simplify_expr (sym
->value
, 1);
11396 /* Reject illegal initializers. */
11397 if (!sym
->mark
&& sym
->value
)
11399 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11400 && CLASS_DATA (sym
)->attr
.allocatable
))
11401 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11402 sym
->name
, &sym
->declared_at
);
11403 else if (sym
->attr
.external
)
11404 gfc_error ("External %qs at %L cannot have an initializer",
11405 sym
->name
, &sym
->declared_at
);
11406 else if (sym
->attr
.dummy
11407 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11408 gfc_error ("Dummy %qs at %L cannot have an initializer",
11409 sym
->name
, &sym
->declared_at
);
11410 else if (sym
->attr
.intrinsic
)
11411 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11412 sym
->name
, &sym
->declared_at
);
11413 else if (sym
->attr
.result
)
11414 gfc_error ("Function result %qs at %L cannot have an initializer",
11415 sym
->name
, &sym
->declared_at
);
11416 else if (automatic_flag
)
11417 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11418 sym
->name
, &sym
->declared_at
);
11420 goto no_init_error
;
11421 specification_expr
= saved_specification_expr
;
11426 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11428 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11429 specification_expr
= saved_specification_expr
;
11433 specification_expr
= saved_specification_expr
;
11438 /* Compare the dummy characteristics of a module procedure interface
11439 declaration with the corresponding declaration in a submodule. */
11440 static gfc_formal_arglist
*new_formal
;
11441 static char errmsg
[200];
11444 compare_fsyms (gfc_symbol
*sym
)
11448 if (sym
== NULL
|| new_formal
== NULL
)
11451 fsym
= new_formal
->sym
;
11456 if (strcmp (sym
->name
, fsym
->name
) == 0)
11458 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
11459 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
11464 /* Resolve a procedure. */
11467 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11469 gfc_formal_arglist
*arg
;
11471 if (sym
->attr
.function
11472 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11475 if (sym
->ts
.type
== BT_CHARACTER
)
11477 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11479 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11480 && !resolve_charlen (cl
))
11483 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11484 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11486 gfc_error ("Character-valued statement function %qs at %L must "
11487 "have constant length", sym
->name
, &sym
->declared_at
);
11492 /* Ensure that derived type for are not of a private type. Internal
11493 module procedures are excluded by 2.2.3.3 - i.e., they are not
11494 externally accessible and can access all the objects accessible in
11496 if (!(sym
->ns
->parent
11497 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11498 && gfc_check_symbol_access (sym
))
11500 gfc_interface
*iface
;
11502 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11505 && arg
->sym
->ts
.type
== BT_DERIVED
11506 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11507 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11508 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11509 "and cannot be a dummy argument"
11510 " of %qs, which is PUBLIC at %L",
11511 arg
->sym
->name
, sym
->name
,
11512 &sym
->declared_at
))
11514 /* Stop this message from recurring. */
11515 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11520 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11521 PRIVATE to the containing module. */
11522 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11524 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11527 && arg
->sym
->ts
.type
== BT_DERIVED
11528 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11529 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11530 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11531 "PUBLIC interface %qs at %L "
11532 "takes dummy arguments of %qs which "
11533 "is PRIVATE", iface
->sym
->name
,
11534 sym
->name
, &iface
->sym
->declared_at
,
11535 gfc_typename(&arg
->sym
->ts
)))
11537 /* Stop this message from recurring. */
11538 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11545 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11546 && !sym
->attr
.proc_pointer
)
11548 gfc_error ("Function %qs at %L cannot have an initializer",
11549 sym
->name
, &sym
->declared_at
);
11553 /* An external symbol may not have an initializer because it is taken to be
11554 a procedure. Exception: Procedure Pointers. */
11555 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11557 gfc_error ("External object %qs at %L may not have an initializer",
11558 sym
->name
, &sym
->declared_at
);
11562 /* An elemental function is required to return a scalar 12.7.1 */
11563 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11565 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11566 "result", sym
->name
, &sym
->declared_at
);
11567 /* Reset so that the error only occurs once. */
11568 sym
->attr
.elemental
= 0;
11572 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11573 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11575 gfc_error ("Statement function %qs at %L may not have pointer or "
11576 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11580 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11581 char-len-param shall not be array-valued, pointer-valued, recursive
11582 or pure. ....snip... A character value of * may only be used in the
11583 following ways: (i) Dummy arg of procedure - dummy associates with
11584 actual length; (ii) To declare a named constant; or (iii) External
11585 function - but length must be declared in calling scoping unit. */
11586 if (sym
->attr
.function
11587 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11588 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11590 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11591 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11593 if (sym
->as
&& sym
->as
->rank
)
11594 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11595 "array-valued", sym
->name
, &sym
->declared_at
);
11597 if (sym
->attr
.pointer
)
11598 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11599 "pointer-valued", sym
->name
, &sym
->declared_at
);
11601 if (sym
->attr
.pure
)
11602 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11603 "pure", sym
->name
, &sym
->declared_at
);
11605 if (sym
->attr
.recursive
)
11606 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11607 "recursive", sym
->name
, &sym
->declared_at
);
11612 /* Appendix B.2 of the standard. Contained functions give an
11613 error anyway. Deferred character length is an F2003 feature.
11614 Don't warn on intrinsic conversion functions, which start
11615 with two underscores. */
11616 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11617 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11618 gfc_notify_std (GFC_STD_F95_OBS
,
11619 "CHARACTER(*) function %qs at %L",
11620 sym
->name
, &sym
->declared_at
);
11623 /* F2008, C1218. */
11624 if (sym
->attr
.elemental
)
11626 if (sym
->attr
.proc_pointer
)
11628 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11629 sym
->name
, &sym
->declared_at
);
11632 if (sym
->attr
.dummy
)
11634 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11635 sym
->name
, &sym
->declared_at
);
11640 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11642 gfc_formal_arglist
*curr_arg
;
11643 int has_non_interop_arg
= 0;
11645 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11646 sym
->common_block
))
11648 /* Clear these to prevent looking at them again if there was an
11650 sym
->attr
.is_bind_c
= 0;
11651 sym
->attr
.is_c_interop
= 0;
11652 sym
->ts
.is_c_interop
= 0;
11656 /* So far, no errors have been found. */
11657 sym
->attr
.is_c_interop
= 1;
11658 sym
->ts
.is_c_interop
= 1;
11661 curr_arg
= gfc_sym_get_dummy_args (sym
);
11662 while (curr_arg
!= NULL
)
11664 /* Skip implicitly typed dummy args here. */
11665 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11666 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11667 /* If something is found to fail, record the fact so we
11668 can mark the symbol for the procedure as not being
11669 BIND(C) to try and prevent multiple errors being
11671 has_non_interop_arg
= 1;
11673 curr_arg
= curr_arg
->next
;
11676 /* See if any of the arguments were not interoperable and if so, clear
11677 the procedure symbol to prevent duplicate error messages. */
11678 if (has_non_interop_arg
!= 0)
11680 sym
->attr
.is_c_interop
= 0;
11681 sym
->ts
.is_c_interop
= 0;
11682 sym
->attr
.is_bind_c
= 0;
11686 if (!sym
->attr
.proc_pointer
)
11688 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11690 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11691 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11694 if (sym
->attr
.intent
)
11696 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11697 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11700 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11702 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11703 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11706 if (sym
->attr
.external
&& sym
->attr
.function
11707 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11708 || sym
->attr
.contained
))
11710 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11711 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11714 if (strcmp ("ppr@", sym
->name
) == 0)
11716 gfc_error ("Procedure pointer result %qs at %L "
11717 "is missing the pointer attribute",
11718 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11723 /* Assume that a procedure whose body is not known has references
11724 to external arrays. */
11725 if (sym
->attr
.if_source
!= IFSRC_DECL
)
11726 sym
->attr
.array_outer_dependency
= 1;
11728 /* Compare the characteristics of a module procedure with the
11729 interface declaration. Ideally this would be done with
11730 gfc_compare_interfaces but, at present, the formal interface
11731 cannot be copied to the ts.interface. */
11732 if (sym
->attr
.module_procedure
11733 && sym
->attr
.if_source
== IFSRC_DECL
)
11736 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
11738 char *submodule_name
;
11739 strcpy (name
, sym
->ns
->proc_name
->name
);
11740 module_name
= strtok (name
, ".");
11741 submodule_name
= strtok (NULL
, ".");
11743 /* Stop the dummy characteristics test from using the interface
11744 symbol instead of 'sym'. */
11745 iface
= sym
->ts
.interface
;
11746 sym
->ts
.interface
= NULL
;
11751 /* Check the procedure characteristics. */
11752 if (sym
->attr
.pure
!= iface
->attr
.pure
)
11754 gfc_error ("Mismatch in PURE attribute between MODULE "
11755 "PROCEDURE at %L and its interface in %s",
11756 &sym
->declared_at
, module_name
);
11760 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
11762 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
11763 "PROCEDURE at %L and its interface in %s",
11764 &sym
->declared_at
, module_name
);
11768 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
11770 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
11771 "PROCEDURE at %L and its interface in %s",
11772 &sym
->declared_at
, module_name
);
11776 /* Check the result characteristics. */
11777 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
11779 gfc_error ("%s between the MODULE PROCEDURE declaration "
11780 "in module %s and the declaration at %L in "
11781 "SUBMODULE %s", errmsg
, module_name
,
11782 &sym
->declared_at
, submodule_name
);
11787 /* Check the charcateristics of the formal arguments. */
11788 if (sym
->formal
&& sym
->formal_ns
)
11790 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
11793 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
11797 sym
->ts
.interface
= iface
;
11803 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11804 been defined and we now know their defined arguments, check that they fulfill
11805 the requirements of the standard for procedures used as finalizers. */
11808 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11810 gfc_finalizer
* list
;
11811 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11812 bool result
= true;
11813 bool seen_scalar
= false;
11816 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11819 gfc_resolve_finalizers (parent
, finalizable
);
11821 /* Return early when not finalizable. Additionally, ensure that derived-type
11822 components have a their finalizables resolved. */
11823 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11825 bool has_final
= false;
11826 for (c
= derived
->components
; c
; c
= c
->next
)
11827 if (c
->ts
.type
== BT_DERIVED
11828 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11830 bool has_final2
= false;
11831 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11832 return false; /* Error. */
11833 has_final
= has_final
|| has_final2
;
11838 *finalizable
= false;
11843 /* Walk over the list of finalizer-procedures, check them, and if any one
11844 does not fit in with the standard's definition, print an error and remove
11845 it from the list. */
11846 prev_link
= &derived
->f2k_derived
->finalizers
;
11847 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11849 gfc_formal_arglist
*dummy_args
;
11854 /* Skip this finalizer if we already resolved it. */
11855 if (list
->proc_tree
)
11857 prev_link
= &(list
->next
);
11861 /* Check this exists and is a SUBROUTINE. */
11862 if (!list
->proc_sym
->attr
.subroutine
)
11864 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
11865 list
->proc_sym
->name
, &list
->where
);
11869 /* We should have exactly one argument. */
11870 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11871 if (!dummy_args
|| dummy_args
->next
)
11873 gfc_error ("FINAL procedure at %L must have exactly one argument",
11877 arg
= dummy_args
->sym
;
11879 /* This argument must be of our type. */
11880 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11882 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
11883 &arg
->declared_at
, derived
->name
);
11887 /* It must neither be a pointer nor allocatable nor optional. */
11888 if (arg
->attr
.pointer
)
11890 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11891 &arg
->declared_at
);
11894 if (arg
->attr
.allocatable
)
11896 gfc_error ("Argument of FINAL procedure at %L must not be"
11897 " ALLOCATABLE", &arg
->declared_at
);
11900 if (arg
->attr
.optional
)
11902 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11903 &arg
->declared_at
);
11907 /* It must not be INTENT(OUT). */
11908 if (arg
->attr
.intent
== INTENT_OUT
)
11910 gfc_error ("Argument of FINAL procedure at %L must not be"
11911 " INTENT(OUT)", &arg
->declared_at
);
11915 /* Warn if the procedure is non-scalar and not assumed shape. */
11916 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11917 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11918 gfc_warning (OPT_Wsurprising
,
11919 "Non-scalar FINAL procedure at %L should have assumed"
11920 " shape argument", &arg
->declared_at
);
11922 /* Check that it does not match in kind and rank with a FINAL procedure
11923 defined earlier. To really loop over the *earlier* declarations,
11924 we need to walk the tail of the list as new ones were pushed at the
11926 /* TODO: Handle kind parameters once they are implemented. */
11927 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11928 for (i
= list
->next
; i
; i
= i
->next
)
11930 gfc_formal_arglist
*dummy_args
;
11932 /* Argument list might be empty; that is an error signalled earlier,
11933 but we nevertheless continued resolving. */
11934 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11937 gfc_symbol
* i_arg
= dummy_args
->sym
;
11938 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11939 if (i_rank
== my_rank
)
11941 gfc_error ("FINAL procedure %qs declared at %L has the same"
11942 " rank (%d) as %qs",
11943 list
->proc_sym
->name
, &list
->where
, my_rank
,
11944 i
->proc_sym
->name
);
11950 /* Is this the/a scalar finalizer procedure? */
11951 if (!arg
->as
|| arg
->as
->rank
== 0)
11952 seen_scalar
= true;
11954 /* Find the symtree for this procedure. */
11955 gcc_assert (!list
->proc_tree
);
11956 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11958 prev_link
= &list
->next
;
11961 /* Remove wrong nodes immediately from the list so we don't risk any
11962 troubles in the future when they might fail later expectations. */
11965 *prev_link
= list
->next
;
11966 gfc_free_finalizer (i
);
11970 if (result
== false)
11973 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11974 were nodes in the list, must have been for arrays. It is surely a good
11975 idea to have a scalar version there if there's something to finalize. */
11976 if (warn_surprising
&& result
&& !seen_scalar
)
11977 gfc_warning (OPT_Wsurprising
,
11978 "Only array FINAL procedures declared for derived type %qs"
11979 " defined at %L, suggest also scalar one",
11980 derived
->name
, &derived
->declared_at
);
11982 vtab
= gfc_find_derived_vtab (derived
);
11983 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11984 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11987 *finalizable
= true;
11993 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11996 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11997 const char* generic_name
, locus where
)
11999 gfc_symbol
*sym1
, *sym2
;
12000 const char *pass1
, *pass2
;
12001 gfc_formal_arglist
*dummy_args
;
12003 gcc_assert (t1
->specific
&& t2
->specific
);
12004 gcc_assert (!t1
->specific
->is_generic
);
12005 gcc_assert (!t2
->specific
->is_generic
);
12006 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12008 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12009 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12014 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12015 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12016 || sym1
->attr
.function
!= sym2
->attr
.function
)
12018 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12019 " GENERIC %qs at %L",
12020 sym1
->name
, sym2
->name
, generic_name
, &where
);
12024 /* Determine PASS arguments. */
12025 if (t1
->specific
->nopass
)
12027 else if (t1
->specific
->pass_arg
)
12028 pass1
= t1
->specific
->pass_arg
;
12031 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12033 pass1
= dummy_args
->sym
->name
;
12037 if (t2
->specific
->nopass
)
12039 else if (t2
->specific
->pass_arg
)
12040 pass2
= t2
->specific
->pass_arg
;
12043 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12045 pass2
= dummy_args
->sym
->name
;
12050 /* Compare the interfaces. */
12051 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12052 NULL
, 0, pass1
, pass2
))
12054 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12055 sym1
->name
, sym2
->name
, generic_name
, &where
);
12063 /* Worker function for resolving a generic procedure binding; this is used to
12064 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12066 The difference between those cases is finding possible inherited bindings
12067 that are overridden, as one has to look for them in tb_sym_root,
12068 tb_uop_root or tb_op, respectively. Thus the caller must already find
12069 the super-type and set p->overridden correctly. */
12072 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12073 gfc_typebound_proc
* p
, const char* name
)
12075 gfc_tbp_generic
* target
;
12076 gfc_symtree
* first_target
;
12077 gfc_symtree
* inherited
;
12079 gcc_assert (p
&& p
->is_generic
);
12081 /* Try to find the specific bindings for the symtrees in our target-list. */
12082 gcc_assert (p
->u
.generic
);
12083 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12084 if (!target
->specific
)
12086 gfc_typebound_proc
* overridden_tbp
;
12087 gfc_tbp_generic
* g
;
12088 const char* target_name
;
12090 target_name
= target
->specific_st
->name
;
12092 /* Defined for this type directly. */
12093 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12095 target
->specific
= target
->specific_st
->n
.tb
;
12096 goto specific_found
;
12099 /* Look for an inherited specific binding. */
12102 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12107 gcc_assert (inherited
->n
.tb
);
12108 target
->specific
= inherited
->n
.tb
;
12109 goto specific_found
;
12113 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12114 " at %L", target_name
, name
, &p
->where
);
12117 /* Once we've found the specific binding, check it is not ambiguous with
12118 other specifics already found or inherited for the same GENERIC. */
12120 gcc_assert (target
->specific
);
12122 /* This must really be a specific binding! */
12123 if (target
->specific
->is_generic
)
12125 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12126 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12130 /* Check those already resolved on this type directly. */
12131 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12132 if (g
!= target
&& g
->specific
12133 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12136 /* Check for ambiguity with inherited specific targets. */
12137 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12138 overridden_tbp
= overridden_tbp
->overridden
)
12139 if (overridden_tbp
->is_generic
)
12141 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12143 gcc_assert (g
->specific
);
12144 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12150 /* If we attempt to "overwrite" a specific binding, this is an error. */
12151 if (p
->overridden
&& !p
->overridden
->is_generic
)
12153 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12154 " the same name", name
, &p
->where
);
12158 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12159 all must have the same attributes here. */
12160 first_target
= p
->u
.generic
->specific
->u
.specific
;
12161 gcc_assert (first_target
);
12162 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12163 p
->function
= first_target
->n
.sym
->attr
.function
;
12169 /* Resolve a GENERIC procedure binding for a derived type. */
12172 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12174 gfc_symbol
* super_type
;
12176 /* Find the overridden binding if any. */
12177 st
->n
.tb
->overridden
= NULL
;
12178 super_type
= gfc_get_derived_super_type (derived
);
12181 gfc_symtree
* overridden
;
12182 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12185 if (overridden
&& overridden
->n
.tb
)
12186 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12189 /* Resolve using worker function. */
12190 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12194 /* Retrieve the target-procedure of an operator binding and do some checks in
12195 common for intrinsic and user-defined type-bound operators. */
12198 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12200 gfc_symbol
* target_proc
;
12202 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12203 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12204 gcc_assert (target_proc
);
12206 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12207 if (target
->specific
->nopass
)
12209 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12213 return target_proc
;
12217 /* Resolve a type-bound intrinsic operator. */
12220 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12221 gfc_typebound_proc
* p
)
12223 gfc_symbol
* super_type
;
12224 gfc_tbp_generic
* target
;
12226 /* If there's already an error here, do nothing (but don't fail again). */
12230 /* Operators should always be GENERIC bindings. */
12231 gcc_assert (p
->is_generic
);
12233 /* Look for an overridden binding. */
12234 super_type
= gfc_get_derived_super_type (derived
);
12235 if (super_type
&& super_type
->f2k_derived
)
12236 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12239 p
->overridden
= NULL
;
12241 /* Resolve general GENERIC properties using worker function. */
12242 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
12245 /* Check the targets to be procedures of correct interface. */
12246 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12248 gfc_symbol
* target_proc
;
12250 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12254 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12257 /* Add target to non-typebound operator list. */
12258 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12259 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12261 gfc_interface
*head
, *intr
;
12262 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
12264 head
= derived
->ns
->op
[op
];
12265 intr
= gfc_get_interface ();
12266 intr
->sym
= target_proc
;
12267 intr
->where
= p
->where
;
12269 derived
->ns
->op
[op
] = intr
;
12281 /* Resolve a type-bound user operator (tree-walker callback). */
12283 static gfc_symbol
* resolve_bindings_derived
;
12284 static bool resolve_bindings_result
;
12286 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12289 resolve_typebound_user_op (gfc_symtree
* stree
)
12291 gfc_symbol
* super_type
;
12292 gfc_tbp_generic
* target
;
12294 gcc_assert (stree
&& stree
->n
.tb
);
12296 if (stree
->n
.tb
->error
)
12299 /* Operators should always be GENERIC bindings. */
12300 gcc_assert (stree
->n
.tb
->is_generic
);
12302 /* Find overridden procedure, if any. */
12303 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12304 if (super_type
&& super_type
->f2k_derived
)
12306 gfc_symtree
* overridden
;
12307 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12308 stree
->name
, true, NULL
);
12310 if (overridden
&& overridden
->n
.tb
)
12311 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12314 stree
->n
.tb
->overridden
= NULL
;
12316 /* Resolve basically using worker function. */
12317 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12320 /* Check the targets to be functions of correct interface. */
12321 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12323 gfc_symbol
* target_proc
;
12325 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12329 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12336 resolve_bindings_result
= false;
12337 stree
->n
.tb
->error
= 1;
12341 /* Resolve the type-bound procedures for a derived type. */
12344 resolve_typebound_procedure (gfc_symtree
* stree
)
12348 gfc_symbol
* me_arg
;
12349 gfc_symbol
* super_type
;
12350 gfc_component
* comp
;
12352 gcc_assert (stree
);
12354 /* Undefined specific symbol from GENERIC target definition. */
12358 if (stree
->n
.tb
->error
)
12361 /* If this is a GENERIC binding, use that routine. */
12362 if (stree
->n
.tb
->is_generic
)
12364 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12369 /* Get the target-procedure to check it. */
12370 gcc_assert (!stree
->n
.tb
->is_generic
);
12371 gcc_assert (stree
->n
.tb
->u
.specific
);
12372 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12373 where
= stree
->n
.tb
->where
;
12375 /* Default access should already be resolved from the parser. */
12376 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12378 if (stree
->n
.tb
->deferred
)
12380 if (!check_proc_interface (proc
, &where
))
12385 /* Check for F08:C465. */
12386 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12387 || (proc
->attr
.proc
!= PROC_MODULE
12388 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12389 || proc
->attr
.abstract
)
12391 gfc_error ("%qs must be a module procedure or an external procedure with"
12392 " an explicit interface at %L", proc
->name
, &where
);
12397 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12398 stree
->n
.tb
->function
= proc
->attr
.function
;
12400 /* Find the super-type of the current derived type. We could do this once and
12401 store in a global if speed is needed, but as long as not I believe this is
12402 more readable and clearer. */
12403 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12405 /* If PASS, resolve and check arguments if not already resolved / loaded
12406 from a .mod file. */
12407 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12409 gfc_formal_arglist
*dummy_args
;
12411 dummy_args
= gfc_sym_get_dummy_args (proc
);
12412 if (stree
->n
.tb
->pass_arg
)
12414 gfc_formal_arglist
*i
;
12416 /* If an explicit passing argument name is given, walk the arg-list
12417 and look for it. */
12420 stree
->n
.tb
->pass_arg_num
= 1;
12421 for (i
= dummy_args
; i
; i
= i
->next
)
12423 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12428 ++stree
->n
.tb
->pass_arg_num
;
12433 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12435 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12436 stree
->n
.tb
->pass_arg
);
12442 /* Otherwise, take the first one; there should in fact be at least
12444 stree
->n
.tb
->pass_arg_num
= 1;
12447 gfc_error ("Procedure %qs with PASS at %L must have at"
12448 " least one argument", proc
->name
, &where
);
12451 me_arg
= dummy_args
->sym
;
12454 /* Now check that the argument-type matches and the passed-object
12455 dummy argument is generally fine. */
12457 gcc_assert (me_arg
);
12459 if (me_arg
->ts
.type
!= BT_CLASS
)
12461 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12462 " at %L", proc
->name
, &where
);
12466 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12467 != resolve_bindings_derived
)
12469 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12470 " the derived-type %qs", me_arg
->name
, proc
->name
,
12471 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12475 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12476 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12478 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12479 " scalar", proc
->name
, &where
);
12482 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12484 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12485 " be ALLOCATABLE", proc
->name
, &where
);
12488 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12490 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12491 " be POINTER", proc
->name
, &where
);
12496 /* If we are extending some type, check that we don't override a procedure
12497 flagged NON_OVERRIDABLE. */
12498 stree
->n
.tb
->overridden
= NULL
;
12501 gfc_symtree
* overridden
;
12502 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12503 stree
->name
, true, NULL
);
12507 if (overridden
->n
.tb
)
12508 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12510 if (!gfc_check_typebound_override (stree
, overridden
))
12515 /* See if there's a name collision with a component directly in this type. */
12516 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12517 if (!strcmp (comp
->name
, stree
->name
))
12519 gfc_error ("Procedure %qs at %L has the same name as a component of"
12521 stree
->name
, &where
, resolve_bindings_derived
->name
);
12525 /* Try to find a name collision with an inherited component. */
12526 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12528 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12529 " component of %qs",
12530 stree
->name
, &where
, resolve_bindings_derived
->name
);
12534 stree
->n
.tb
->error
= 0;
12538 resolve_bindings_result
= false;
12539 stree
->n
.tb
->error
= 1;
12544 resolve_typebound_procedures (gfc_symbol
* derived
)
12547 gfc_symbol
* super_type
;
12549 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12552 super_type
= gfc_get_derived_super_type (derived
);
12554 resolve_symbol (super_type
);
12556 resolve_bindings_derived
= derived
;
12557 resolve_bindings_result
= true;
12559 if (derived
->f2k_derived
->tb_sym_root
)
12560 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12561 &resolve_typebound_procedure
);
12563 if (derived
->f2k_derived
->tb_uop_root
)
12564 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12565 &resolve_typebound_user_op
);
12567 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12569 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12570 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12571 (gfc_intrinsic_op
)op
, p
))
12572 resolve_bindings_result
= false;
12575 return resolve_bindings_result
;
12579 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12580 to give all identical derived types the same backend_decl. */
12582 add_dt_to_dt_list (gfc_symbol
*derived
)
12584 gfc_dt_list
*dt_list
;
12586 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12587 if (derived
== dt_list
->derived
)
12590 dt_list
= gfc_get_dt_list ();
12591 dt_list
->next
= gfc_derived_types
;
12592 dt_list
->derived
= derived
;
12593 gfc_derived_types
= dt_list
;
12597 /* Ensure that a derived-type is really not abstract, meaning that every
12598 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12601 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12606 if (!ensure_not_abstract_walker (sub
, st
->left
))
12608 if (!ensure_not_abstract_walker (sub
, st
->right
))
12611 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12613 gfc_symtree
* overriding
;
12614 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12617 gcc_assert (overriding
->n
.tb
);
12618 if (overriding
->n
.tb
->deferred
)
12620 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12621 " %qs is DEFERRED and not overridden",
12622 sub
->name
, &sub
->declared_at
, st
->name
);
12631 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12633 /* The algorithm used here is to recursively travel up the ancestry of sub
12634 and for each ancestor-type, check all bindings. If any of them is
12635 DEFERRED, look it up starting from sub and see if the found (overriding)
12636 binding is not DEFERRED.
12637 This is not the most efficient way to do this, but it should be ok and is
12638 clearer than something sophisticated. */
12640 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12642 if (!ancestor
->attr
.abstract
)
12645 /* Walk bindings of this ancestor. */
12646 if (ancestor
->f2k_derived
)
12649 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12654 /* Find next ancestor type and recurse on it. */
12655 ancestor
= gfc_get_derived_super_type (ancestor
);
12657 return ensure_not_abstract (sub
, ancestor
);
12663 /* This check for typebound defined assignments is done recursively
12664 since the order in which derived types are resolved is not always in
12665 order of the declarations. */
12668 check_defined_assignments (gfc_symbol
*derived
)
12672 for (c
= derived
->components
; c
; c
= c
->next
)
12674 if (c
->ts
.type
!= BT_DERIVED
12676 || c
->attr
.allocatable
12677 || c
->attr
.proc_pointer_comp
12678 || c
->attr
.class_pointer
12679 || c
->attr
.proc_pointer
)
12682 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12683 || (c
->ts
.u
.derived
->f2k_derived
12684 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12686 derived
->attr
.defined_assign_comp
= 1;
12690 check_defined_assignments (c
->ts
.u
.derived
);
12691 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12693 derived
->attr
.defined_assign_comp
= 1;
12700 /* Resolve the components of a derived type. This does not have to wait until
12701 resolution stage, but can be done as soon as the dt declaration has been
12705 resolve_fl_derived0 (gfc_symbol
*sym
)
12707 gfc_symbol
* super_type
;
12710 if (sym
->attr
.unlimited_polymorphic
)
12713 super_type
= gfc_get_derived_super_type (sym
);
12716 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12718 gfc_error ("As extending type %qs at %L has a coarray component, "
12719 "parent type %qs shall also have one", sym
->name
,
12720 &sym
->declared_at
, super_type
->name
);
12724 /* Ensure the extended type gets resolved before we do. */
12725 if (super_type
&& !resolve_fl_derived0 (super_type
))
12728 /* An ABSTRACT type must be extensible. */
12729 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12731 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12732 sym
->name
, &sym
->declared_at
);
12736 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12739 bool success
= true;
12741 for ( ; c
!= NULL
; c
= c
->next
)
12743 if (c
->attr
.artificial
)
12747 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12748 && c
->attr
.codimension
12749 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12751 gfc_error ("Coarray component %qs at %L must be allocatable with "
12752 "deferred shape", c
->name
, &c
->loc
);
12758 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12759 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12761 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12762 "shall not be a coarray", c
->name
, &c
->loc
);
12768 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12769 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12770 || c
->attr
.allocatable
))
12772 gfc_error ("Component %qs at %L with coarray component "
12773 "shall be a nonpointer, nonallocatable scalar",
12780 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12782 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12783 "is not an array pointer", c
->name
, &c
->loc
);
12788 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12790 gfc_symbol
*ifc
= c
->ts
.interface
;
12792 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
12799 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12801 /* Resolve interface and copy attributes. */
12802 if (ifc
->formal
&& !ifc
->formal_ns
)
12803 resolve_symbol (ifc
);
12804 if (ifc
->attr
.intrinsic
)
12805 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12809 c
->ts
= ifc
->result
->ts
;
12810 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12811 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12812 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12813 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12814 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12819 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12820 c
->attr
.pointer
= ifc
->attr
.pointer
;
12821 c
->attr
.dimension
= ifc
->attr
.dimension
;
12822 c
->as
= gfc_copy_array_spec (ifc
->as
);
12823 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12825 c
->ts
.interface
= ifc
;
12826 c
->attr
.function
= ifc
->attr
.function
;
12827 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12829 c
->attr
.pure
= ifc
->attr
.pure
;
12830 c
->attr
.elemental
= ifc
->attr
.elemental
;
12831 c
->attr
.recursive
= ifc
->attr
.recursive
;
12832 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12833 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12834 /* Copy char length. */
12835 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12837 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12838 if (cl
->length
&& !cl
->resolved
12839 && !gfc_resolve_expr (cl
->length
))
12849 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12851 /* Since PPCs are not implicitly typed, a PPC without an explicit
12852 interface must be a subroutine. */
12853 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12856 /* Procedure pointer components: Check PASS arg. */
12857 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12858 && !sym
->attr
.vtype
)
12860 gfc_symbol
* me_arg
;
12862 if (c
->tb
->pass_arg
)
12864 gfc_formal_arglist
* i
;
12866 /* If an explicit passing argument name is given, walk the arg-list
12867 and look for it. */
12870 c
->tb
->pass_arg_num
= 1;
12871 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12873 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12878 c
->tb
->pass_arg_num
++;
12883 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12884 "at %L has no argument %qs", c
->name
,
12885 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12893 /* Otherwise, take the first one; there should in fact be at least
12895 c
->tb
->pass_arg_num
= 1;
12896 if (!c
->ts
.interface
->formal
)
12898 gfc_error ("Procedure pointer component %qs with PASS at %L "
12899 "must have at least one argument",
12905 me_arg
= c
->ts
.interface
->formal
->sym
;
12908 /* Now check that the argument-type matches. */
12909 gcc_assert (me_arg
);
12910 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12911 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12912 || (me_arg
->ts
.type
== BT_CLASS
12913 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12915 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12916 " the derived type %qs", me_arg
->name
, c
->name
,
12917 me_arg
->name
, &c
->loc
, sym
->name
);
12923 /* Check for C453. */
12924 if (me_arg
->attr
.dimension
)
12926 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12927 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12934 if (me_arg
->attr
.pointer
)
12936 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12937 "may not have the POINTER attribute", me_arg
->name
,
12938 c
->name
, me_arg
->name
, &c
->loc
);
12944 if (me_arg
->attr
.allocatable
)
12946 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12947 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12948 me_arg
->name
, &c
->loc
);
12954 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12956 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12957 " at %L", c
->name
, &c
->loc
);
12964 /* Check type-spec if this is not the parent-type component. */
12965 if (((sym
->attr
.is_class
12966 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12967 || c
!= sym
->components
->ts
.u
.derived
->components
))
12968 || (!sym
->attr
.is_class
12969 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12970 && !sym
->attr
.vtype
12971 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12974 /* If this type is an extension, set the accessibility of the parent
12977 && ((sym
->attr
.is_class
12978 && c
== sym
->components
->ts
.u
.derived
->components
)
12979 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12980 && strcmp (super_type
->name
, c
->name
) == 0)
12981 c
->attr
.access
= super_type
->attr
.access
;
12983 /* If this type is an extension, see if this component has the same name
12984 as an inherited type-bound procedure. */
12985 if (super_type
&& !sym
->attr
.is_class
12986 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12988 gfc_error ("Component %qs of %qs at %L has the same name as an"
12989 " inherited type-bound procedure",
12990 c
->name
, sym
->name
, &c
->loc
);
12994 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12995 && !c
->ts
.deferred
)
12997 if (c
->ts
.u
.cl
->length
== NULL
12998 || (!resolve_charlen(c
->ts
.u
.cl
))
12999 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13001 gfc_error ("Character length of component %qs needs to "
13002 "be a constant specification expression at %L",
13004 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13009 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13010 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13012 gfc_error ("Character component %qs of %qs at %L with deferred "
13013 "length must be a POINTER or ALLOCATABLE",
13014 c
->name
, sym
->name
, &c
->loc
);
13018 /* Add the hidden deferred length field. */
13019 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
13020 && !sym
->attr
.is_class
)
13022 char name
[GFC_MAX_SYMBOL_LEN
+9];
13023 gfc_component
*strlen
;
13024 sprintf (name
, "_%s_length", c
->name
);
13025 strlen
= gfc_find_component (sym
, name
, true, true);
13026 if (strlen
== NULL
)
13028 if (!gfc_add_component (sym
, name
, &strlen
))
13030 strlen
->ts
.type
= BT_INTEGER
;
13031 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13032 strlen
->attr
.access
= ACCESS_PRIVATE
;
13033 strlen
->attr
.artificial
= 1;
13037 if (c
->ts
.type
== BT_DERIVED
13038 && sym
->component_access
!= ACCESS_PRIVATE
13039 && gfc_check_symbol_access (sym
)
13040 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13041 && !c
->ts
.u
.derived
->attr
.use_assoc
13042 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13043 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13044 "PRIVATE type and cannot be a component of "
13045 "%qs, which is PUBLIC at %L", c
->name
,
13046 sym
->name
, &sym
->declared_at
))
13049 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13051 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13052 "type %s", c
->name
, &c
->loc
, sym
->name
);
13056 if (sym
->attr
.sequence
)
13058 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13060 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13061 "not have the SEQUENCE attribute",
13062 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13067 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13068 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13069 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13070 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13071 CLASS_DATA (c
)->ts
.u
.derived
13072 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13074 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13075 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13076 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13078 gfc_error ("The pointer component %qs of %qs at %L is a type "
13079 "that has not been declared", c
->name
, sym
->name
,
13084 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13085 && CLASS_DATA (c
)->attr
.class_pointer
13086 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13087 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13088 && !UNLIMITED_POLY (c
))
13090 gfc_error ("The pointer component %qs of %qs at %L is a type "
13091 "that has not been declared", c
->name
, sym
->name
,
13097 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
13098 && (!c
->attr
.class_ok
13099 || !(CLASS_DATA (c
)->attr
.class_pointer
13100 || CLASS_DATA (c
)->attr
.allocatable
)))
13102 gfc_error ("Component %qs with CLASS at %L must be allocatable "
13103 "or pointer", c
->name
, &c
->loc
);
13104 /* Prevent a recurrence of the error. */
13105 c
->ts
.type
= BT_UNKNOWN
;
13109 /* Ensure that all the derived type components are put on the
13110 derived type list; even in formal namespaces, where derived type
13111 pointer components might not have been declared. */
13112 if (c
->ts
.type
== BT_DERIVED
13114 && c
->ts
.u
.derived
->components
13116 && sym
!= c
->ts
.u
.derived
)
13117 add_dt_to_dt_list (c
->ts
.u
.derived
);
13119 if (!gfc_resolve_array_spec (c
->as
,
13120 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13121 || c
->attr
.allocatable
)))
13124 if (c
->initializer
&& !sym
->attr
.vtype
13125 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13132 check_defined_assignments (sym
);
13134 if (!sym
->attr
.defined_assign_comp
&& super_type
)
13135 sym
->attr
.defined_assign_comp
13136 = super_type
->attr
.defined_assign_comp
;
13138 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13139 all DEFERRED bindings are overridden. */
13140 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
13141 && !sym
->attr
.is_class
13142 && !ensure_not_abstract (sym
, super_type
))
13145 /* Add derived type to the derived type list. */
13146 add_dt_to_dt_list (sym
);
13152 /* The following procedure does the full resolution of a derived type,
13153 including resolution of all type-bound procedures (if present). In contrast
13154 to 'resolve_fl_derived0' this can only be done after the module has been
13155 parsed completely. */
13158 resolve_fl_derived (gfc_symbol
*sym
)
13160 gfc_symbol
*gen_dt
= NULL
;
13162 if (sym
->attr
.unlimited_polymorphic
)
13165 if (!sym
->attr
.is_class
)
13166 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
13167 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
13168 && (!gen_dt
->generic
->sym
->attr
.use_assoc
13169 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
13170 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
13171 "%qs at %L being the same name as derived "
13172 "type at %L", sym
->name
,
13173 gen_dt
->generic
->sym
== sym
13174 ? gen_dt
->generic
->next
->sym
->name
13175 : gen_dt
->generic
->sym
->name
,
13176 gen_dt
->generic
->sym
== sym
13177 ? &gen_dt
->generic
->next
->sym
->declared_at
13178 : &gen_dt
->generic
->sym
->declared_at
,
13179 &sym
->declared_at
))
13182 /* Resolve the finalizer procedures. */
13183 if (!gfc_resolve_finalizers (sym
, NULL
))
13186 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
13188 /* Fix up incomplete CLASS symbols. */
13189 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
13190 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
13192 /* Nothing more to do for unlimited polymorphic entities. */
13193 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
13195 else if (vptr
->ts
.u
.derived
== NULL
)
13197 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
13199 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
13203 if (!resolve_fl_derived0 (sym
))
13206 /* Resolve the type-bound procedures. */
13207 if (!resolve_typebound_procedures (sym
))
13215 resolve_fl_namelist (gfc_symbol
*sym
)
13220 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13222 /* Check again, the check in match only works if NAMELIST comes
13224 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
13226 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13227 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13231 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
13232 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13233 "with assumed shape in namelist %qs at %L",
13234 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13237 if (is_non_constant_shape_array (nl
->sym
)
13238 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13239 "with nonconstant shape in namelist %qs at %L",
13240 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13243 if (nl
->sym
->ts
.type
== BT_CHARACTER
13244 && (nl
->sym
->ts
.u
.cl
->length
== NULL
13245 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13246 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13247 "nonconstant character length in "
13248 "namelist %qs at %L", nl
->sym
->name
,
13249 sym
->name
, &sym
->declared_at
))
13252 /* FIXME: Once UDDTIO is implemented, the following can be
13254 if (nl
->sym
->ts
.type
== BT_CLASS
)
13256 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13257 "polymorphic and requires a defined input/output "
13258 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13262 if (nl
->sym
->ts
.type
== BT_DERIVED
13263 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13264 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13266 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13267 "namelist %qs at %L with ALLOCATABLE "
13268 "or POINTER components", nl
->sym
->name
,
13269 sym
->name
, &sym
->declared_at
))
13272 /* FIXME: Once UDDTIO is implemented, the following can be
13274 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13275 "ALLOCATABLE or POINTER components and thus requires "
13276 "a defined input/output procedure", nl
->sym
->name
,
13277 sym
->name
, &sym
->declared_at
);
13282 /* Reject PRIVATE objects in a PUBLIC namelist. */
13283 if (gfc_check_symbol_access (sym
))
13285 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13287 if (!nl
->sym
->attr
.use_assoc
13288 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13289 && !gfc_check_symbol_access (nl
->sym
))
13291 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13292 "cannot be member of PUBLIC namelist %qs at %L",
13293 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13297 /* Types with private components that came here by USE-association. */
13298 if (nl
->sym
->ts
.type
== BT_DERIVED
13299 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13301 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13302 "components and cannot be member of namelist %qs at %L",
13303 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13307 /* Types with private components that are defined in the same module. */
13308 if (nl
->sym
->ts
.type
== BT_DERIVED
13309 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13310 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13312 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13313 "cannot be a member of PUBLIC namelist %qs at %L",
13314 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13321 /* 14.1.2 A module or internal procedure represent local entities
13322 of the same type as a namelist member and so are not allowed. */
13323 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13325 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13328 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13329 if ((nl
->sym
== sym
->ns
->proc_name
)
13331 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13336 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13337 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13339 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13340 "attribute in %qs at %L", nlsym
->name
,
13341 &sym
->declared_at
);
13351 resolve_fl_parameter (gfc_symbol
*sym
)
13353 /* A parameter array's shape needs to be constant. */
13354 if (sym
->as
!= NULL
13355 && (sym
->as
->type
== AS_DEFERRED
13356 || is_non_constant_shape_array (sym
)))
13358 gfc_error ("Parameter array %qs at %L cannot be automatic "
13359 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13363 /* Make sure a parameter that has been implicitly typed still
13364 matches the implicit type, since PARAMETER statements can precede
13365 IMPLICIT statements. */
13366 if (sym
->attr
.implicit_type
13367 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13370 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13371 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13375 /* Make sure the types of derived parameters are consistent. This
13376 type checking is deferred until resolution because the type may
13377 refer to a derived type from the host. */
13378 if (sym
->ts
.type
== BT_DERIVED
13379 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13381 gfc_error ("Incompatible derived type in PARAMETER at %L",
13382 &sym
->value
->where
);
13389 /* Do anything necessary to resolve a symbol. Right now, we just
13390 assume that an otherwise unknown symbol is a variable. This sort
13391 of thing commonly happens for symbols in module. */
13394 resolve_symbol (gfc_symbol
*sym
)
13396 int check_constant
, mp_flag
;
13397 gfc_symtree
*symtree
;
13398 gfc_symtree
*this_symtree
;
13401 symbol_attribute class_attr
;
13402 gfc_array_spec
*as
;
13403 bool saved_specification_expr
;
13409 if (sym
->attr
.artificial
)
13412 if (sym
->attr
.unlimited_polymorphic
)
13415 if (sym
->attr
.flavor
== FL_UNKNOWN
13416 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13417 && !sym
->attr
.generic
&& !sym
->attr
.external
13418 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13419 && sym
->ts
.type
== BT_UNKNOWN
))
13422 /* If we find that a flavorless symbol is an interface in one of the
13423 parent namespaces, find its symtree in this namespace, free the
13424 symbol and set the symtree to point to the interface symbol. */
13425 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13427 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13428 if (symtree
&& (symtree
->n
.sym
->generic
||
13429 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13430 && sym
->ns
->construct_entities
)))
13432 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13434 if (this_symtree
->n
.sym
== sym
)
13436 symtree
->n
.sym
->refs
++;
13437 gfc_release_symbol (sym
);
13438 this_symtree
->n
.sym
= symtree
->n
.sym
;
13444 /* Otherwise give it a flavor according to such attributes as
13446 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13447 && sym
->attr
.intrinsic
== 0)
13448 sym
->attr
.flavor
= FL_VARIABLE
;
13449 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13451 sym
->attr
.flavor
= FL_PROCEDURE
;
13452 if (sym
->attr
.dimension
)
13453 sym
->attr
.function
= 1;
13457 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13458 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13460 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13461 && !resolve_procedure_interface (sym
))
13464 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13465 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13467 if (sym
->attr
.external
)
13468 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13469 "at %L", &sym
->declared_at
);
13471 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13472 "at %L", &sym
->declared_at
);
13477 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13480 /* Symbols that are module procedures with results (functions) have
13481 the types and array specification copied for type checking in
13482 procedures that call them, as well as for saving to a module
13483 file. These symbols can't stand the scrutiny that their results
13485 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13487 /* Make sure that the intrinsic is consistent with its internal
13488 representation. This needs to be done before assigning a default
13489 type to avoid spurious warnings. */
13490 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13491 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13494 /* Resolve associate names. */
13496 resolve_assoc_var (sym
, true);
13498 /* Assign default type to symbols that need one and don't have one. */
13499 if (sym
->ts
.type
== BT_UNKNOWN
)
13501 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13503 gfc_set_default_type (sym
, 1, NULL
);
13506 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13507 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13508 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13509 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13511 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13513 /* The specific case of an external procedure should emit an error
13514 in the case that there is no implicit type. */
13516 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13519 /* Result may be in another namespace. */
13520 resolve_symbol (sym
->result
);
13522 if (!sym
->result
->attr
.proc_pointer
)
13524 sym
->ts
= sym
->result
->ts
;
13525 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13526 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13527 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13528 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13529 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13534 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13536 bool saved_specification_expr
= specification_expr
;
13537 specification_expr
= true;
13538 gfc_resolve_array_spec (sym
->result
->as
, false);
13539 specification_expr
= saved_specification_expr
;
13542 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13544 as
= CLASS_DATA (sym
)->as
;
13545 class_attr
= CLASS_DATA (sym
)->attr
;
13546 class_attr
.pointer
= class_attr
.class_pointer
;
13550 class_attr
= sym
->attr
;
13555 if (sym
->attr
.contiguous
13556 && (!class_attr
.dimension
13557 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13558 && !class_attr
.pointer
)))
13560 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13561 "array pointer or an assumed-shape or assumed-rank array",
13562 sym
->name
, &sym
->declared_at
);
13566 /* Assumed size arrays and assumed shape arrays must be dummy
13567 arguments. Array-spec's of implied-shape should have been resolved to
13568 AS_EXPLICIT already. */
13572 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13573 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13574 || as
->type
== AS_ASSUMED_SHAPE
)
13575 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13577 if (as
->type
== AS_ASSUMED_SIZE
)
13578 gfc_error ("Assumed size array at %L must be a dummy argument",
13579 &sym
->declared_at
);
13581 gfc_error ("Assumed shape array at %L must be a dummy argument",
13582 &sym
->declared_at
);
13585 /* TS 29113, C535a. */
13586 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13587 && !sym
->attr
.select_type_temporary
)
13589 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13590 &sym
->declared_at
);
13593 if (as
->type
== AS_ASSUMED_RANK
13594 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13596 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13597 "CODIMENSION attribute", &sym
->declared_at
);
13602 /* Make sure symbols with known intent or optional are really dummy
13603 variable. Because of ENTRY statement, this has to be deferred
13604 until resolution time. */
13606 if (!sym
->attr
.dummy
13607 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13609 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13613 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13615 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13616 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13620 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13622 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13623 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13625 gfc_error ("Character dummy variable %qs at %L with VALUE "
13626 "attribute must have constant length",
13627 sym
->name
, &sym
->declared_at
);
13631 if (sym
->ts
.is_c_interop
13632 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13634 gfc_error ("C interoperable character dummy variable %qs at %L "
13635 "with VALUE attribute must have length one",
13636 sym
->name
, &sym
->declared_at
);
13641 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13642 && sym
->ts
.u
.derived
->attr
.generic
)
13644 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13645 if (!sym
->ts
.u
.derived
)
13647 gfc_error ("The derived type %qs at %L is of type %qs, "
13648 "which has not been defined", sym
->name
,
13649 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13650 sym
->ts
.type
= BT_UNKNOWN
;
13655 /* Use the same constraints as TYPE(*), except for the type check
13656 and that only scalars and assumed-size arrays are permitted. */
13657 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13659 if (!sym
->attr
.dummy
)
13661 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13662 "a dummy argument", sym
->name
, &sym
->declared_at
);
13666 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13667 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13668 && sym
->ts
.type
!= BT_COMPLEX
)
13670 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13671 "of type TYPE(*) or of an numeric intrinsic type",
13672 sym
->name
, &sym
->declared_at
);
13676 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13677 || sym
->attr
.pointer
|| sym
->attr
.value
)
13679 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13680 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13681 "attribute", sym
->name
, &sym
->declared_at
);
13685 if (sym
->attr
.intent
== INTENT_OUT
)
13687 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13688 "have the INTENT(OUT) attribute",
13689 sym
->name
, &sym
->declared_at
);
13692 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13694 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13695 "either be a scalar or an assumed-size array",
13696 sym
->name
, &sym
->declared_at
);
13700 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13701 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13703 sym
->ts
.type
= BT_ASSUMED
;
13704 sym
->as
= gfc_get_array_spec ();
13705 sym
->as
->type
= AS_ASSUMED_SIZE
;
13707 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13709 else if (sym
->ts
.type
== BT_ASSUMED
)
13711 /* TS 29113, C407a. */
13712 if (!sym
->attr
.dummy
)
13714 gfc_error ("Assumed type of variable %s at %L is only permitted "
13715 "for dummy variables", sym
->name
, &sym
->declared_at
);
13718 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13719 || sym
->attr
.pointer
|| sym
->attr
.value
)
13721 gfc_error ("Assumed-type variable %s at %L may not have the "
13722 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13723 sym
->name
, &sym
->declared_at
);
13726 if (sym
->attr
.intent
== INTENT_OUT
)
13728 gfc_error ("Assumed-type variable %s at %L may not have the "
13729 "INTENT(OUT) attribute",
13730 sym
->name
, &sym
->declared_at
);
13733 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13735 gfc_error ("Assumed-type variable %s at %L shall not be an "
13736 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13741 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13742 do this for something that was implicitly typed because that is handled
13743 in gfc_set_default_type. Handle dummy arguments and procedure
13744 definitions separately. Also, anything that is use associated is not
13745 handled here but instead is handled in the module it is declared in.
13746 Finally, derived type definitions are allowed to be BIND(C) since that
13747 only implies that they're interoperable, and they are checked fully for
13748 interoperability when a variable is declared of that type. */
13749 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13750 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13751 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13755 /* First, make sure the variable is declared at the
13756 module-level scope (J3/04-007, Section 15.3). */
13757 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13758 sym
->attr
.in_common
== 0)
13760 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13761 "is neither a COMMON block nor declared at the "
13762 "module level scope", sym
->name
, &(sym
->declared_at
));
13765 else if (sym
->common_head
!= NULL
)
13767 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13771 /* If type() declaration, we need to verify that the components
13772 of the given type are all C interoperable, etc. */
13773 if (sym
->ts
.type
== BT_DERIVED
&&
13774 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13776 /* Make sure the user marked the derived type as BIND(C). If
13777 not, call the verify routine. This could print an error
13778 for the derived type more than once if multiple variables
13779 of that type are declared. */
13780 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13781 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13785 /* Verify the variable itself as C interoperable if it
13786 is BIND(C). It is not possible for this to succeed if
13787 the verify_bind_c_derived_type failed, so don't have to handle
13788 any error returned by verify_bind_c_derived_type. */
13789 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13790 sym
->common_block
);
13795 /* clear the is_bind_c flag to prevent reporting errors more than
13796 once if something failed. */
13797 sym
->attr
.is_bind_c
= 0;
13802 /* If a derived type symbol has reached this point, without its
13803 type being declared, we have an error. Notice that most
13804 conditions that produce undefined derived types have already
13805 been dealt with. However, the likes of:
13806 implicit type(t) (t) ..... call foo (t) will get us here if
13807 the type is not declared in the scope of the implicit
13808 statement. Change the type to BT_UNKNOWN, both because it is so
13809 and to prevent an ICE. */
13810 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13811 && sym
->ts
.u
.derived
->components
== NULL
13812 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13814 gfc_error ("The derived type %qs at %L is of type %qs, "
13815 "which has not been defined", sym
->name
,
13816 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13817 sym
->ts
.type
= BT_UNKNOWN
;
13821 /* Make sure that the derived type has been resolved and that the
13822 derived type is visible in the symbol's namespace, if it is a
13823 module function and is not PRIVATE. */
13824 if (sym
->ts
.type
== BT_DERIVED
13825 && sym
->ts
.u
.derived
->attr
.use_assoc
13826 && sym
->ns
->proc_name
13827 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13828 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13831 /* Unless the derived-type declaration is use associated, Fortran 95
13832 does not allow public entries of private derived types.
13833 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13834 161 in 95-006r3. */
13835 if (sym
->ts
.type
== BT_DERIVED
13836 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13837 && !sym
->ts
.u
.derived
->attr
.use_assoc
13838 && gfc_check_symbol_access (sym
)
13839 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13840 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
13841 "derived type %qs",
13842 (sym
->attr
.flavor
== FL_PARAMETER
)
13843 ? "parameter" : "variable",
13844 sym
->name
, &sym
->declared_at
,
13845 sym
->ts
.u
.derived
->name
))
13848 /* F2008, C1302. */
13849 if (sym
->ts
.type
== BT_DERIVED
13850 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13851 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13852 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13853 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13855 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13856 "type LOCK_TYPE must be a coarray", sym
->name
,
13857 &sym
->declared_at
);
13861 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13862 default initialization is defined (5.1.2.4.4). */
13863 if (sym
->ts
.type
== BT_DERIVED
13865 && sym
->attr
.intent
== INTENT_OUT
13867 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13869 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13871 if (c
->initializer
)
13873 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
13874 "ASSUMED SIZE and so cannot have a default initializer",
13875 sym
->name
, &sym
->declared_at
);
13882 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13883 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13885 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
13886 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13891 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13892 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13893 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13894 || class_attr
.codimension
)
13895 && (sym
->attr
.result
|| sym
->result
== sym
))
13897 gfc_error ("Function result %qs at %L shall not be a coarray or have "
13898 "a coarray component", sym
->name
, &sym
->declared_at
);
13903 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13904 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13906 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13907 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13912 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13913 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13914 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13915 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13916 || class_attr
.allocatable
))
13918 gfc_error ("Variable %qs at %L with coarray component shall be a "
13919 "nonpointer, nonallocatable scalar, which is not a coarray",
13920 sym
->name
, &sym
->declared_at
);
13924 /* F2008, C526. The function-result case was handled above. */
13925 if (class_attr
.codimension
13926 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13927 || sym
->attr
.select_type_temporary
13928 || sym
->ns
->save_all
13929 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13930 || sym
->ns
->proc_name
->attr
.is_main_program
13931 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13933 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
13934 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13938 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13939 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13941 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
13942 "deferred shape", sym
->name
, &sym
->declared_at
);
13945 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13946 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13948 gfc_error ("Allocatable coarray variable %qs at %L must have "
13949 "deferred shape", sym
->name
, &sym
->declared_at
);
13954 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13955 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13956 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13957 || (class_attr
.codimension
&& class_attr
.allocatable
))
13958 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13960 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
13961 "allocatable coarray or have coarray components",
13962 sym
->name
, &sym
->declared_at
);
13966 if (class_attr
.codimension
&& sym
->attr
.dummy
13967 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13969 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
13970 "procedure %qs", sym
->name
, &sym
->declared_at
,
13971 sym
->ns
->proc_name
->name
);
13975 if (sym
->ts
.type
== BT_LOGICAL
13976 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13977 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13978 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13981 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13982 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13984 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13985 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
13986 "%L with non-C_Bool kind in BIND(C) procedure "
13987 "%qs", sym
->name
, &sym
->declared_at
,
13988 sym
->ns
->proc_name
->name
))
13990 else if (!gfc_logical_kinds
[i
].c_bool
13991 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13992 "%qs at %L with non-C_Bool kind in "
13993 "BIND(C) procedure %qs", sym
->name
,
13995 sym
->attr
.function
? sym
->name
13996 : sym
->ns
->proc_name
->name
))
14000 switch (sym
->attr
.flavor
)
14003 if (!resolve_fl_variable (sym
, mp_flag
))
14008 if (!resolve_fl_procedure (sym
, mp_flag
))
14013 if (!resolve_fl_namelist (sym
))
14018 if (!resolve_fl_parameter (sym
))
14026 /* Resolve array specifier. Check as well some constraints
14027 on COMMON blocks. */
14029 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
14031 /* Set the formal_arg_flag so that check_conflict will not throw
14032 an error for host associated variables in the specification
14033 expression for an array_valued function. */
14034 if (sym
->attr
.function
&& sym
->as
)
14035 formal_arg_flag
= 1;
14037 saved_specification_expr
= specification_expr
;
14038 specification_expr
= true;
14039 gfc_resolve_array_spec (sym
->as
, check_constant
);
14040 specification_expr
= saved_specification_expr
;
14042 formal_arg_flag
= 0;
14044 /* Resolve formal namespaces. */
14045 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
14046 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
14047 gfc_resolve (sym
->formal_ns
);
14049 /* Make sure the formal namespace is present. */
14050 if (sym
->formal
&& !sym
->formal_ns
)
14052 gfc_formal_arglist
*formal
= sym
->formal
;
14053 while (formal
&& !formal
->sym
)
14054 formal
= formal
->next
;
14058 sym
->formal_ns
= formal
->sym
->ns
;
14059 if (sym
->ns
!= formal
->sym
->ns
)
14060 sym
->formal_ns
->refs
++;
14064 /* Check threadprivate restrictions. */
14065 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
14066 && (!sym
->attr
.in_common
14067 && sym
->module
== NULL
14068 && (sym
->ns
->proc_name
== NULL
14069 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14070 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
14072 /* Check omp declare target restrictions. */
14073 if (sym
->attr
.omp_declare_target
14074 && sym
->attr
.flavor
== FL_VARIABLE
14076 && !sym
->ns
->save_all
14077 && (!sym
->attr
.in_common
14078 && sym
->module
== NULL
14079 && (sym
->ns
->proc_name
== NULL
14080 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14081 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14082 sym
->name
, &sym
->declared_at
);
14084 /* If we have come this far we can apply default-initializers, as
14085 described in 14.7.5, to those variables that have not already
14086 been assigned one. */
14087 if (sym
->ts
.type
== BT_DERIVED
14089 && !sym
->attr
.allocatable
14090 && !sym
->attr
.alloc_comp
)
14092 symbol_attribute
*a
= &sym
->attr
;
14094 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
14095 && !a
->in_common
&& !a
->use_assoc
14096 && !a
->result
&& !a
->function
)
14097 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
14098 apply_default_init (sym
);
14099 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
14100 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14101 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14102 /* Mark the result symbol to be referenced, when it has allocatable
14104 sym
->result
->attr
.referenced
= 1;
14107 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
14108 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
14109 && !CLASS_DATA (sym
)->attr
.class_pointer
14110 && !CLASS_DATA (sym
)->attr
.allocatable
)
14111 apply_default_init (sym
);
14113 /* If this symbol has a type-spec, check it. */
14114 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
14115 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
14116 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
14121 /************* Resolve DATA statements *************/
14125 gfc_data_value
*vnode
;
14131 /* Advance the values structure to point to the next value in the data list. */
14134 next_data_value (void)
14136 while (mpz_cmp_ui (values
.left
, 0) == 0)
14139 if (values
.vnode
->next
== NULL
)
14142 values
.vnode
= values
.vnode
->next
;
14143 mpz_set (values
.left
, values
.vnode
->repeat
);
14151 check_data_variable (gfc_data_variable
*var
, locus
*where
)
14157 ar_type mark
= AR_UNKNOWN
;
14159 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
14165 if (!gfc_resolve_expr (var
->expr
))
14169 mpz_init_set_si (offset
, 0);
14172 if (e
->expr_type
!= EXPR_VARIABLE
)
14173 gfc_internal_error ("check_data_variable(): Bad expression");
14175 sym
= e
->symtree
->n
.sym
;
14177 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
14179 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
14180 sym
->name
, &sym
->declared_at
);
14183 if (e
->ref
== NULL
&& sym
->as
)
14185 gfc_error ("DATA array %qs at %L must be specified in a previous"
14186 " declaration", sym
->name
, where
);
14190 has_pointer
= sym
->attr
.pointer
;
14192 if (gfc_is_coindexed (e
))
14194 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
14199 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14201 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
14205 && ref
->type
== REF_ARRAY
14206 && ref
->u
.ar
.type
!= AR_FULL
)
14208 gfc_error ("DATA element %qs at %L is a pointer and so must "
14209 "be a full array", sym
->name
, where
);
14214 if (e
->rank
== 0 || has_pointer
)
14216 mpz_init_set_ui (size
, 1);
14223 /* Find the array section reference. */
14224 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14226 if (ref
->type
!= REF_ARRAY
)
14228 if (ref
->u
.ar
.type
== AR_ELEMENT
)
14234 /* Set marks according to the reference pattern. */
14235 switch (ref
->u
.ar
.type
)
14243 /* Get the start position of array section. */
14244 gfc_get_section_index (ar
, section_index
, &offset
);
14249 gcc_unreachable ();
14252 if (!gfc_array_size (e
, &size
))
14254 gfc_error ("Nonconstant array section at %L in DATA statement",
14256 mpz_clear (offset
);
14263 while (mpz_cmp_ui (size
, 0) > 0)
14265 if (!next_data_value ())
14267 gfc_error ("DATA statement at %L has more variables than values",
14273 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14277 /* If we have more than one element left in the repeat count,
14278 and we have more than one element left in the target variable,
14279 then create a range assignment. */
14280 /* FIXME: Only done for full arrays for now, since array sections
14282 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14283 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14287 if (mpz_cmp (size
, values
.left
) >= 0)
14289 mpz_init_set (range
, values
.left
);
14290 mpz_sub (size
, size
, values
.left
);
14291 mpz_set_ui (values
.left
, 0);
14295 mpz_init_set (range
, size
);
14296 mpz_sub (values
.left
, values
.left
, size
);
14297 mpz_set_ui (size
, 0);
14300 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14303 mpz_add (offset
, offset
, range
);
14310 /* Assign initial value to symbol. */
14313 mpz_sub_ui (values
.left
, values
.left
, 1);
14314 mpz_sub_ui (size
, size
, 1);
14316 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14321 if (mark
== AR_FULL
)
14322 mpz_add_ui (offset
, offset
, 1);
14324 /* Modify the array section indexes and recalculate the offset
14325 for next element. */
14326 else if (mark
== AR_SECTION
)
14327 gfc_advance_section (section_index
, ar
, &offset
);
14331 if (mark
== AR_SECTION
)
14333 for (i
= 0; i
< ar
->dimen
; i
++)
14334 mpz_clear (section_index
[i
]);
14338 mpz_clear (offset
);
14344 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14346 /* Iterate over a list of elements in a DATA statement. */
14349 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14352 iterator_stack frame
;
14353 gfc_expr
*e
, *start
, *end
, *step
;
14354 bool retval
= true;
14356 mpz_init (frame
.value
);
14359 start
= gfc_copy_expr (var
->iter
.start
);
14360 end
= gfc_copy_expr (var
->iter
.end
);
14361 step
= gfc_copy_expr (var
->iter
.step
);
14363 if (!gfc_simplify_expr (start
, 1)
14364 || start
->expr_type
!= EXPR_CONSTANT
)
14366 gfc_error ("start of implied-do loop at %L could not be "
14367 "simplified to a constant value", &start
->where
);
14371 if (!gfc_simplify_expr (end
, 1)
14372 || end
->expr_type
!= EXPR_CONSTANT
)
14374 gfc_error ("end of implied-do loop at %L could not be "
14375 "simplified to a constant value", &start
->where
);
14379 if (!gfc_simplify_expr (step
, 1)
14380 || step
->expr_type
!= EXPR_CONSTANT
)
14382 gfc_error ("step of implied-do loop at %L could not be "
14383 "simplified to a constant value", &start
->where
);
14388 mpz_set (trip
, end
->value
.integer
);
14389 mpz_sub (trip
, trip
, start
->value
.integer
);
14390 mpz_add (trip
, trip
, step
->value
.integer
);
14392 mpz_div (trip
, trip
, step
->value
.integer
);
14394 mpz_set (frame
.value
, start
->value
.integer
);
14396 frame
.prev
= iter_stack
;
14397 frame
.variable
= var
->iter
.var
->symtree
;
14398 iter_stack
= &frame
;
14400 while (mpz_cmp_ui (trip
, 0) > 0)
14402 if (!traverse_data_var (var
->list
, where
))
14408 e
= gfc_copy_expr (var
->expr
);
14409 if (!gfc_simplify_expr (e
, 1))
14416 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14418 mpz_sub_ui (trip
, trip
, 1);
14422 mpz_clear (frame
.value
);
14425 gfc_free_expr (start
);
14426 gfc_free_expr (end
);
14427 gfc_free_expr (step
);
14429 iter_stack
= frame
.prev
;
14434 /* Type resolve variables in the variable list of a DATA statement. */
14437 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14441 for (; var
; var
= var
->next
)
14443 if (var
->expr
== NULL
)
14444 t
= traverse_data_list (var
, where
);
14446 t
= check_data_variable (var
, where
);
14456 /* Resolve the expressions and iterators associated with a data statement.
14457 This is separate from the assignment checking because data lists should
14458 only be resolved once. */
14461 resolve_data_variables (gfc_data_variable
*d
)
14463 for (; d
; d
= d
->next
)
14465 if (d
->list
== NULL
)
14467 if (!gfc_resolve_expr (d
->expr
))
14472 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14475 if (!resolve_data_variables (d
->list
))
14484 /* Resolve a single DATA statement. We implement this by storing a pointer to
14485 the value list into static variables, and then recursively traversing the
14486 variables list, expanding iterators and such. */
14489 resolve_data (gfc_data
*d
)
14492 if (!resolve_data_variables (d
->var
))
14495 values
.vnode
= d
->value
;
14496 if (d
->value
== NULL
)
14497 mpz_set_ui (values
.left
, 0);
14499 mpz_set (values
.left
, d
->value
->repeat
);
14501 if (!traverse_data_var (d
->var
, &d
->where
))
14504 /* At this point, we better not have any values left. */
14506 if (next_data_value ())
14507 gfc_error ("DATA statement at %L has more values than variables",
14512 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14513 accessed by host or use association, is a dummy argument to a pure function,
14514 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14515 is storage associated with any such variable, shall not be used in the
14516 following contexts: (clients of this function). */
14518 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14519 procedure. Returns zero if assignment is OK, nonzero if there is a
14522 gfc_impure_variable (gfc_symbol
*sym
)
14527 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14530 /* Check if the symbol's ns is inside the pure procedure. */
14531 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14535 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14539 proc
= sym
->ns
->proc_name
;
14540 if (sym
->attr
.dummy
14541 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14542 || proc
->attr
.function
))
14545 /* TODO: Sort out what can be storage associated, if anything, and include
14546 it here. In principle equivalences should be scanned but it does not
14547 seem to be possible to storage associate an impure variable this way. */
14552 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14553 current namespace is inside a pure procedure. */
14556 gfc_pure (gfc_symbol
*sym
)
14558 symbol_attribute attr
;
14563 /* Check if the current namespace or one of its parents
14564 belongs to a pure procedure. */
14565 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14567 sym
= ns
->proc_name
;
14571 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14579 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14583 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14584 checks if the current namespace is implicitly pure. Note that this
14585 function returns false for a PURE procedure. */
14588 gfc_implicit_pure (gfc_symbol
*sym
)
14594 /* Check if the current procedure is implicit_pure. Walk up
14595 the procedure list until we find a procedure. */
14596 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14598 sym
= ns
->proc_name
;
14602 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14607 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14608 && !sym
->attr
.pure
;
14613 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14619 /* Check if the current procedure is implicit_pure. Walk up
14620 the procedure list until we find a procedure. */
14621 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14623 sym
= ns
->proc_name
;
14627 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14632 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14633 sym
->attr
.implicit_pure
= 0;
14635 sym
->attr
.pure
= 0;
14639 /* Test whether the current procedure is elemental or not. */
14642 gfc_elemental (gfc_symbol
*sym
)
14644 symbol_attribute attr
;
14647 sym
= gfc_current_ns
->proc_name
;
14652 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14656 /* Warn about unused labels. */
14659 warn_unused_fortran_label (gfc_st_label
*label
)
14664 warn_unused_fortran_label (label
->left
);
14666 if (label
->defined
== ST_LABEL_UNKNOWN
)
14669 switch (label
->referenced
)
14671 case ST_LABEL_UNKNOWN
:
14672 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
14676 case ST_LABEL_BAD_TARGET
:
14677 gfc_warning (0, "Label %d at %L defined but cannot be used",
14678 label
->value
, &label
->where
);
14685 warn_unused_fortran_label (label
->right
);
14689 /* Returns the sequence type of a symbol or sequence. */
14692 sequence_type (gfc_typespec ts
)
14701 if (ts
.u
.derived
->components
== NULL
)
14702 return SEQ_NONDEFAULT
;
14704 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14705 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14706 if (sequence_type (c
->ts
) != result
)
14712 if (ts
.kind
!= gfc_default_character_kind
)
14713 return SEQ_NONDEFAULT
;
14715 return SEQ_CHARACTER
;
14718 if (ts
.kind
!= gfc_default_integer_kind
)
14719 return SEQ_NONDEFAULT
;
14721 return SEQ_NUMERIC
;
14724 if (!(ts
.kind
== gfc_default_real_kind
14725 || ts
.kind
== gfc_default_double_kind
))
14726 return SEQ_NONDEFAULT
;
14728 return SEQ_NUMERIC
;
14731 if (ts
.kind
!= gfc_default_complex_kind
)
14732 return SEQ_NONDEFAULT
;
14734 return SEQ_NUMERIC
;
14737 if (ts
.kind
!= gfc_default_logical_kind
)
14738 return SEQ_NONDEFAULT
;
14740 return SEQ_NUMERIC
;
14743 return SEQ_NONDEFAULT
;
14748 /* Resolve derived type EQUIVALENCE object. */
14751 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14753 gfc_component
*c
= derived
->components
;
14758 /* Shall not be an object of nonsequence derived type. */
14759 if (!derived
->attr
.sequence
)
14761 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14762 "attribute to be an EQUIVALENCE object", sym
->name
,
14767 /* Shall not have allocatable components. */
14768 if (derived
->attr
.alloc_comp
)
14770 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14771 "components to be an EQUIVALENCE object",sym
->name
,
14776 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14778 gfc_error ("Derived type variable %qs at %L with default "
14779 "initialization cannot be in EQUIVALENCE with a variable "
14780 "in COMMON", sym
->name
, &e
->where
);
14784 for (; c
; c
= c
->next
)
14786 if (c
->ts
.type
== BT_DERIVED
14787 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14790 /* Shall not be an object of sequence derived type containing a pointer
14791 in the structure. */
14792 if (c
->attr
.pointer
)
14794 gfc_error ("Derived type variable %qs at %L with pointer "
14795 "component(s) cannot be an EQUIVALENCE object",
14796 sym
->name
, &e
->where
);
14804 /* Resolve equivalence object.
14805 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14806 an allocatable array, an object of nonsequence derived type, an object of
14807 sequence derived type containing a pointer at any level of component
14808 selection, an automatic object, a function name, an entry name, a result
14809 name, a named constant, a structure component, or a subobject of any of
14810 the preceding objects. A substring shall not have length zero. A
14811 derived type shall not have components with default initialization nor
14812 shall two objects of an equivalence group be initialized.
14813 Either all or none of the objects shall have an protected attribute.
14814 The simple constraints are done in symbol.c(check_conflict) and the rest
14815 are implemented here. */
14818 resolve_equivalence (gfc_equiv
*eq
)
14821 gfc_symbol
*first_sym
;
14824 locus
*last_where
= NULL
;
14825 seq_type eq_type
, last_eq_type
;
14826 gfc_typespec
*last_ts
;
14827 int object
, cnt_protected
;
14830 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14832 first_sym
= eq
->expr
->symtree
->n
.sym
;
14836 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14840 e
->ts
= e
->symtree
->n
.sym
->ts
;
14841 /* match_varspec might not know yet if it is seeing
14842 array reference or substring reference, as it doesn't
14844 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14846 gfc_ref
*ref
= e
->ref
;
14847 sym
= e
->symtree
->n
.sym
;
14849 if (sym
->attr
.dimension
)
14851 ref
->u
.ar
.as
= sym
->as
;
14855 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14856 if (e
->ts
.type
== BT_CHARACTER
14858 && ref
->type
== REF_ARRAY
14859 && ref
->u
.ar
.dimen
== 1
14860 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14861 && ref
->u
.ar
.stride
[0] == NULL
)
14863 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14864 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14867 /* Optimize away the (:) reference. */
14868 if (start
== NULL
&& end
== NULL
)
14871 e
->ref
= ref
->next
;
14873 e
->ref
->next
= ref
->next
;
14878 ref
->type
= REF_SUBSTRING
;
14880 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14882 ref
->u
.ss
.start
= start
;
14883 if (end
== NULL
&& e
->ts
.u
.cl
)
14884 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14885 ref
->u
.ss
.end
= end
;
14886 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14893 /* Any further ref is an error. */
14896 gcc_assert (ref
->type
== REF_ARRAY
);
14897 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14903 if (!gfc_resolve_expr (e
))
14906 sym
= e
->symtree
->n
.sym
;
14908 if (sym
->attr
.is_protected
)
14910 if (cnt_protected
> 0 && cnt_protected
!= object
)
14912 gfc_error ("Either all or none of the objects in the "
14913 "EQUIVALENCE set at %L shall have the "
14914 "PROTECTED attribute",
14919 /* Shall not equivalence common block variables in a PURE procedure. */
14920 if (sym
->ns
->proc_name
14921 && sym
->ns
->proc_name
->attr
.pure
14922 && sym
->attr
.in_common
)
14924 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
14925 "object in the pure procedure %qs",
14926 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14930 /* Shall not be a named constant. */
14931 if (e
->expr_type
== EXPR_CONSTANT
)
14933 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
14934 "object", sym
->name
, &e
->where
);
14938 if (e
->ts
.type
== BT_DERIVED
14939 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14942 /* Check that the types correspond correctly:
14944 A numeric sequence structure may be equivalenced to another sequence
14945 structure, an object of default integer type, default real type, double
14946 precision real type, default logical type such that components of the
14947 structure ultimately only become associated to objects of the same
14948 kind. A character sequence structure may be equivalenced to an object
14949 of default character kind or another character sequence structure.
14950 Other objects may be equivalenced only to objects of the same type and
14951 kind parameters. */
14953 /* Identical types are unconditionally OK. */
14954 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14955 goto identical_types
;
14957 last_eq_type
= sequence_type (*last_ts
);
14958 eq_type
= sequence_type (sym
->ts
);
14960 /* Since the pair of objects is not of the same type, mixed or
14961 non-default sequences can be rejected. */
14963 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14964 "statement at %L with different type objects";
14966 && last_eq_type
== SEQ_MIXED
14967 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14968 || (eq_type
== SEQ_MIXED
14969 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14972 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14973 "statement at %L with objects of different type";
14975 && last_eq_type
== SEQ_NONDEFAULT
14976 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14977 || (eq_type
== SEQ_NONDEFAULT
14978 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14981 msg
="Non-CHARACTER object %qs in default CHARACTER "
14982 "EQUIVALENCE statement at %L";
14983 if (last_eq_type
== SEQ_CHARACTER
14984 && eq_type
!= SEQ_CHARACTER
14985 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14988 msg
="Non-NUMERIC object %qs in default NUMERIC "
14989 "EQUIVALENCE statement at %L";
14990 if (last_eq_type
== SEQ_NUMERIC
14991 && eq_type
!= SEQ_NUMERIC
14992 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14997 last_where
= &e
->where
;
15002 /* Shall not be an automatic array. */
15003 if (e
->ref
->type
== REF_ARRAY
15004 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
15006 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15007 "an EQUIVALENCE object", sym
->name
, &e
->where
);
15014 /* Shall not be a structure component. */
15015 if (r
->type
== REF_COMPONENT
)
15017 gfc_error ("Structure component %qs at %L cannot be an "
15018 "EQUIVALENCE object",
15019 r
->u
.c
.component
->name
, &e
->where
);
15023 /* A substring shall not have length zero. */
15024 if (r
->type
== REF_SUBSTRING
)
15026 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
15028 gfc_error ("Substring at %L has length zero",
15029 &r
->u
.ss
.start
->where
);
15039 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15042 resolve_fntype (gfc_namespace
*ns
)
15044 gfc_entry_list
*el
;
15047 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
15050 /* If there are any entries, ns->proc_name is the entry master
15051 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15053 sym
= ns
->entries
->sym
;
15055 sym
= ns
->proc_name
;
15056 if (sym
->result
== sym
15057 && sym
->ts
.type
== BT_UNKNOWN
15058 && !gfc_set_default_type (sym
, 0, NULL
)
15059 && !sym
->attr
.untyped
)
15061 gfc_error ("Function %qs at %L has no IMPLICIT type",
15062 sym
->name
, &sym
->declared_at
);
15063 sym
->attr
.untyped
= 1;
15066 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
15067 && !sym
->attr
.contained
15068 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15069 && gfc_check_symbol_access (sym
))
15071 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
15072 "%L of PRIVATE type %qs", sym
->name
,
15073 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15077 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
15079 if (el
->sym
->result
== el
->sym
15080 && el
->sym
->ts
.type
== BT_UNKNOWN
15081 && !gfc_set_default_type (el
->sym
, 0, NULL
)
15082 && !el
->sym
->attr
.untyped
)
15084 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
15085 el
->sym
->name
, &el
->sym
->declared_at
);
15086 el
->sym
->attr
.untyped
= 1;
15092 /* 12.3.2.1.1 Defined operators. */
15095 check_uop_procedure (gfc_symbol
*sym
, locus where
)
15097 gfc_formal_arglist
*formal
;
15099 if (!sym
->attr
.function
)
15101 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
15102 sym
->name
, &where
);
15106 if (sym
->ts
.type
== BT_CHARACTER
15107 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
15108 && !(sym
->result
&& sym
->result
->ts
.u
.cl
15109 && sym
->result
->ts
.u
.cl
->length
))
15111 gfc_error ("User operator procedure %qs at %L cannot be assumed "
15112 "character length", sym
->name
, &where
);
15116 formal
= gfc_sym_get_dummy_args (sym
);
15117 if (!formal
|| !formal
->sym
)
15119 gfc_error ("User operator procedure %qs at %L must have at least "
15120 "one argument", sym
->name
, &where
);
15124 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15126 gfc_error ("First argument of operator interface at %L must be "
15127 "INTENT(IN)", &where
);
15131 if (formal
->sym
->attr
.optional
)
15133 gfc_error ("First argument of operator interface at %L cannot be "
15134 "optional", &where
);
15138 formal
= formal
->next
;
15139 if (!formal
|| !formal
->sym
)
15142 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15144 gfc_error ("Second argument of operator interface at %L must be "
15145 "INTENT(IN)", &where
);
15149 if (formal
->sym
->attr
.optional
)
15151 gfc_error ("Second argument of operator interface at %L cannot be "
15152 "optional", &where
);
15158 gfc_error ("Operator interface at %L must have, at most, two "
15159 "arguments", &where
);
15167 gfc_resolve_uops (gfc_symtree
*symtree
)
15169 gfc_interface
*itr
;
15171 if (symtree
== NULL
)
15174 gfc_resolve_uops (symtree
->left
);
15175 gfc_resolve_uops (symtree
->right
);
15177 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
15178 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
15182 /* Examine all of the expressions associated with a program unit,
15183 assign types to all intermediate expressions, make sure that all
15184 assignments are to compatible types and figure out which names
15185 refer to which functions or subroutines. It doesn't check code
15186 block, which is handled by gfc_resolve_code. */
15189 resolve_types (gfc_namespace
*ns
)
15195 gfc_namespace
* old_ns
= gfc_current_ns
;
15197 if (ns
->types_resolved
)
15200 /* Check that all IMPLICIT types are ok. */
15201 if (!ns
->seen_implicit_none
)
15204 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
15205 if (ns
->set_flag
[letter
]
15206 && !resolve_typespec_used (&ns
->default_type
[letter
],
15207 &ns
->implicit_loc
[letter
], NULL
))
15211 gfc_current_ns
= ns
;
15213 resolve_entries (ns
);
15215 resolve_common_vars (ns
->blank_common
.head
, false);
15216 resolve_common_blocks (ns
->common_root
);
15218 resolve_contained_functions (ns
);
15220 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
15221 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15222 resolve_formal_arglist (ns
->proc_name
);
15224 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
15226 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
15227 resolve_charlen (cl
);
15229 gfc_traverse_ns (ns
, resolve_symbol
);
15231 resolve_fntype (ns
);
15233 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15235 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
15236 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
15237 "also be PURE", n
->proc_name
->name
,
15238 &n
->proc_name
->declared_at
);
15244 gfc_do_concurrent_flag
= 0;
15245 gfc_check_interfaces (ns
);
15247 gfc_traverse_ns (ns
, resolve_values
);
15253 for (d
= ns
->data
; d
; d
= d
->next
)
15257 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
15259 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
15261 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
15262 resolve_equivalence (eq
);
15264 /* Warn about unused labels. */
15265 if (warn_unused_label
)
15266 warn_unused_fortran_label (ns
->st_labels
);
15268 gfc_resolve_uops (ns
->uop_root
);
15270 gfc_resolve_omp_declare_simd (ns
);
15272 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
15274 ns
->types_resolved
= 1;
15276 gfc_current_ns
= old_ns
;
15280 /* Call gfc_resolve_code recursively. */
15283 resolve_codes (gfc_namespace
*ns
)
15286 bitmap_obstack old_obstack
;
15288 if (ns
->resolved
== 1)
15291 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15294 gfc_current_ns
= ns
;
15296 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15297 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
15300 /* Set to an out of range value. */
15301 current_entry_id
= -1;
15303 old_obstack
= labels_obstack
;
15304 bitmap_obstack_initialize (&labels_obstack
);
15306 gfc_resolve_oacc_declare (ns
);
15307 gfc_resolve_code (ns
->code
, ns
);
15309 bitmap_obstack_release (&labels_obstack
);
15310 labels_obstack
= old_obstack
;
15314 /* This function is called after a complete program unit has been compiled.
15315 Its purpose is to examine all of the expressions associated with a program
15316 unit, assign types to all intermediate expressions, make sure that all
15317 assignments are to compatible types and figure out which names refer to
15318 which functions or subroutines. */
15321 gfc_resolve (gfc_namespace
*ns
)
15323 gfc_namespace
*old_ns
;
15324 code_stack
*old_cs_base
;
15325 struct gfc_omp_saved_state old_omp_state
;
15331 old_ns
= gfc_current_ns
;
15332 old_cs_base
= cs_base
;
15334 /* As gfc_resolve can be called during resolution of an OpenMP construct
15335 body, we should clear any state associated to it, so that say NS's
15336 DO loops are not interpreted as OpenMP loops. */
15337 gfc_omp_save_and_clear_state (&old_omp_state
);
15339 resolve_types (ns
);
15340 component_assignment_level
= 0;
15341 resolve_codes (ns
);
15343 gfc_current_ns
= old_ns
;
15344 cs_base
= old_cs_base
;
15347 gfc_run_passes (ns
);
15349 gfc_omp_restore_state (&old_omp_state
);