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
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and gfc_resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 int gfc_do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type %qs used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface %qs at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface %qs at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface %qs at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure %qs not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "%qs at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "%qs at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "%qs at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
394 " of pure function %qs at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument %qs of pure function %qs at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
407 " of pure subroutine %qs at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument %qs of pure subroutine %qs at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
421 gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L"
422 " may not be polymorphic", sym
->name
, proc
->name
,
428 if (proc
->attr
.implicit_pure
)
430 if (sym
->attr
.flavor
== FL_PROCEDURE
)
433 proc
->attr
.implicit_pure
= 0;
435 else if (!sym
->attr
.pointer
)
437 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
439 proc
->attr
.implicit_pure
= 0;
441 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
443 proc
->attr
.implicit_pure
= 0;
447 if (gfc_elemental (proc
))
450 if (sym
->attr
.codimension
451 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
452 && CLASS_DATA (sym
)->attr
.codimension
))
454 gfc_error ("Coarray dummy argument %qs at %L to elemental "
455 "procedure", sym
->name
, &sym
->declared_at
);
459 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->as
))
462 gfc_error ("Argument %qs of elemental procedure at %L must "
463 "be scalar", sym
->name
, &sym
->declared_at
);
467 if (sym
->attr
.allocatable
468 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
469 && CLASS_DATA (sym
)->attr
.allocatable
))
471 gfc_error ("Argument %qs of elemental procedure at %L cannot "
472 "have the ALLOCATABLE attribute", sym
->name
,
477 if (sym
->attr
.pointer
478 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
479 && CLASS_DATA (sym
)->attr
.class_pointer
))
481 gfc_error ("Argument %qs of elemental procedure at %L cannot "
482 "have the POINTER attribute", sym
->name
,
487 if (sym
->attr
.flavor
== FL_PROCEDURE
)
489 gfc_error ("Dummy procedure %qs not allowed in elemental "
490 "procedure %qs at %L", sym
->name
, proc
->name
,
495 /* Fortran 2008 Corrigendum 1, C1290a. */
496 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
498 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
499 "have its INTENT specified or have the VALUE "
500 "attribute", sym
->name
, proc
->name
,
506 /* Each dummy shall be specified to be scalar. */
507 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
511 gfc_error ("Argument %qs of statement function at %L must "
512 "be scalar", sym
->name
, &sym
->declared_at
);
516 if (sym
->ts
.type
== BT_CHARACTER
)
518 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
519 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
521 gfc_error ("Character-valued argument %qs of statement "
522 "function at %L must have constant length",
523 sym
->name
, &sym
->declared_at
);
533 /* Work function called when searching for symbols that have argument lists
534 associated with them. */
537 find_arglists (gfc_symbol
*sym
)
539 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
540 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
543 resolve_formal_arglist (sym
);
547 /* Given a namespace, resolve all formal argument lists within the namespace.
551 resolve_formal_arglists (gfc_namespace
*ns
)
556 gfc_traverse_ns (ns
, find_arglists
);
561 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
565 /* If this namespace is not a function or an entry master function,
567 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
568 || sym
->attr
.entry_master
)
571 /* Try to find out of what the return type is. */
572 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
574 t
= gfc_set_default_type (sym
->result
, 0, ns
);
576 if (!t
&& !sym
->result
->attr
.untyped
)
578 if (sym
->result
== sym
)
579 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
580 sym
->name
, &sym
->declared_at
);
581 else if (!sym
->result
->attr
.proc_pointer
)
582 gfc_error ("Result %qs of contained function %qs at %L has "
583 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
584 &sym
->result
->declared_at
);
585 sym
->result
->attr
.untyped
= 1;
589 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
590 type, lists the only ways a character length value of * can be used:
591 dummy arguments of procedures, named constants, and function results
592 in external functions. Internal function results and results of module
593 procedures are not on this list, ergo, not permitted. */
595 if (sym
->result
->ts
.type
== BT_CHARACTER
)
597 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
598 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
600 /* See if this is a module-procedure and adapt error message
603 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
604 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
606 gfc_error ("Character-valued %s %qs at %L must not be"
608 module_proc
? _("module procedure")
609 : _("internal function"),
610 sym
->name
, &sym
->declared_at
);
616 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
617 introduce duplicates. */
620 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
622 gfc_formal_arglist
*f
, *new_arglist
;
625 for (; new_args
!= NULL
; new_args
= new_args
->next
)
627 new_sym
= new_args
->sym
;
628 /* See if this arg is already in the formal argument list. */
629 for (f
= proc
->formal
; f
; f
= f
->next
)
631 if (new_sym
== f
->sym
)
638 /* Add a new argument. Argument order is not important. */
639 new_arglist
= gfc_get_formal_arglist ();
640 new_arglist
->sym
= new_sym
;
641 new_arglist
->next
= proc
->formal
;
642 proc
->formal
= new_arglist
;
647 /* Flag the arguments that are not present in all entries. */
650 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
652 gfc_formal_arglist
*f
, *head
;
655 for (f
= proc
->formal
; f
; f
= f
->next
)
660 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
662 if (new_args
->sym
== f
->sym
)
669 f
->sym
->attr
.not_always_present
= 1;
674 /* Resolve alternate entry points. If a symbol has multiple entry points we
675 create a new master symbol for the main routine, and turn the existing
676 symbol into an entry point. */
679 resolve_entries (gfc_namespace
*ns
)
681 gfc_namespace
*old_ns
;
685 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
686 static int master_count
= 0;
688 if (ns
->proc_name
== NULL
)
691 /* No need to do anything if this procedure doesn't have alternate entry
696 /* We may already have resolved alternate entry points. */
697 if (ns
->proc_name
->attr
.entry_master
)
700 /* If this isn't a procedure something has gone horribly wrong. */
701 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
703 /* Remember the current namespace. */
704 old_ns
= gfc_current_ns
;
708 /* Add the main entry point to the list of entry points. */
709 el
= gfc_get_entry_list ();
710 el
->sym
= ns
->proc_name
;
712 el
->next
= ns
->entries
;
714 ns
->proc_name
->attr
.entry
= 1;
716 /* If it is a module function, it needs to be in the right namespace
717 so that gfc_get_fake_result_decl can gather up the results. The
718 need for this arose in get_proc_name, where these beasts were
719 left in their own namespace, to keep prior references linked to
720 the entry declaration.*/
721 if (ns
->proc_name
->attr
.function
722 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
725 /* Do the same for entries where the master is not a module
726 procedure. These are retained in the module namespace because
727 of the module procedure declaration. */
728 for (el
= el
->next
; el
; el
= el
->next
)
729 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
730 && el
->sym
->attr
.mod_proc
)
734 /* Add an entry statement for it. */
735 c
= gfc_get_code (EXEC_ENTRY
);
740 /* Create a new symbol for the master function. */
741 /* Give the internal function a unique name (within this file).
742 Also include the function name so the user has some hope of figuring
743 out what is going on. */
744 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
745 master_count
++, ns
->proc_name
->name
);
746 gfc_get_ha_symbol (name
, &proc
);
747 gcc_assert (proc
!= NULL
);
749 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
750 if (ns
->proc_name
->attr
.subroutine
)
751 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
755 gfc_typespec
*ts
, *fts
;
756 gfc_array_spec
*as
, *fas
;
757 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
759 fas
= ns
->entries
->sym
->as
;
760 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
761 fts
= &ns
->entries
->sym
->result
->ts
;
762 if (fts
->type
== BT_UNKNOWN
)
763 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
764 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
766 ts
= &el
->sym
->result
->ts
;
768 as
= as
? as
: el
->sym
->result
->as
;
769 if (ts
->type
== BT_UNKNOWN
)
770 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
772 if (! gfc_compare_types (ts
, fts
)
773 || (el
->sym
->result
->attr
.dimension
774 != ns
->entries
->sym
->result
->attr
.dimension
)
775 || (el
->sym
->result
->attr
.pointer
776 != ns
->entries
->sym
->result
->attr
.pointer
))
778 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
779 && gfc_compare_array_spec (as
, fas
) == 0)
780 gfc_error ("Function %s at %L has entries with mismatched "
781 "array specifications", ns
->entries
->sym
->name
,
782 &ns
->entries
->sym
->declared_at
);
783 /* The characteristics need to match and thus both need to have
784 the same string length, i.e. both len=*, or both len=4.
785 Having both len=<variable> is also possible, but difficult to
786 check at compile time. */
787 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
788 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
789 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
791 && ts
->u
.cl
->length
->expr_type
792 != fts
->u
.cl
->length
->expr_type
)
794 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
795 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
796 fts
->u
.cl
->length
->value
.integer
) != 0)))
797 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
798 "entries returning variables of different "
799 "string lengths", ns
->entries
->sym
->name
,
800 &ns
->entries
->sym
->declared_at
);
805 sym
= ns
->entries
->sym
->result
;
806 /* All result types the same. */
808 if (sym
->attr
.dimension
)
809 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
810 if (sym
->attr
.pointer
)
811 gfc_add_pointer (&proc
->attr
, NULL
);
815 /* Otherwise the result will be passed through a union by
817 proc
->attr
.mixed_entry_master
= 1;
818 for (el
= ns
->entries
; el
; el
= el
->next
)
820 sym
= el
->sym
->result
;
821 if (sym
->attr
.dimension
)
823 if (el
== ns
->entries
)
824 gfc_error ("FUNCTION result %s can't be an array in "
825 "FUNCTION %s at %L", sym
->name
,
826 ns
->entries
->sym
->name
, &sym
->declared_at
);
828 gfc_error ("ENTRY result %s can't be an array in "
829 "FUNCTION %s at %L", sym
->name
,
830 ns
->entries
->sym
->name
, &sym
->declared_at
);
832 else if (sym
->attr
.pointer
)
834 if (el
== ns
->entries
)
835 gfc_error ("FUNCTION result %s can't be a POINTER in "
836 "FUNCTION %s at %L", sym
->name
,
837 ns
->entries
->sym
->name
, &sym
->declared_at
);
839 gfc_error ("ENTRY result %s can't be a POINTER in "
840 "FUNCTION %s at %L", sym
->name
,
841 ns
->entries
->sym
->name
, &sym
->declared_at
);
846 if (ts
->type
== BT_UNKNOWN
)
847 ts
= gfc_get_default_type (sym
->name
, NULL
);
851 if (ts
->kind
== gfc_default_integer_kind
)
855 if (ts
->kind
== gfc_default_real_kind
856 || ts
->kind
== gfc_default_double_kind
)
860 if (ts
->kind
== gfc_default_complex_kind
)
864 if (ts
->kind
== gfc_default_logical_kind
)
868 /* We will issue error elsewhere. */
876 if (el
== ns
->entries
)
877 gfc_error ("FUNCTION result %s can't be of type %s "
878 "in FUNCTION %s at %L", sym
->name
,
879 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 gfc_error ("ENTRY result %s can't be of type %s "
883 "in FUNCTION %s at %L", sym
->name
,
884 gfc_typename (ts
), ns
->entries
->sym
->name
,
891 proc
->attr
.access
= ACCESS_PRIVATE
;
892 proc
->attr
.entry_master
= 1;
894 /* Merge all the entry point arguments. */
895 for (el
= ns
->entries
; el
; el
= el
->next
)
896 merge_argument_lists (proc
, el
->sym
->formal
);
898 /* Check the master formal arguments for any that are not
899 present in all entry points. */
900 for (el
= ns
->entries
; el
; el
= el
->next
)
901 check_argument_lists (proc
, el
->sym
->formal
);
903 /* Use the master function for the function body. */
904 ns
->proc_name
= proc
;
906 /* Finalize the new symbols. */
907 gfc_commit_symbols ();
909 /* Restore the original namespace. */
910 gfc_current_ns
= old_ns
;
914 /* Resolve common variables. */
916 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
918 gfc_symbol
*csym
= sym
;
920 for (; csym
; csym
= csym
->common_next
)
922 if (csym
->value
|| csym
->attr
.data
)
924 if (!csym
->ns
->is_block_data
)
925 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
926 "but only in BLOCK DATA initialization is "
927 "allowed", csym
->name
, &csym
->declared_at
);
928 else if (!named_common
)
929 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
930 "in a blank COMMON but initialization is only "
931 "allowed in named common blocks", csym
->name
,
935 if (UNLIMITED_POLY (csym
))
936 gfc_error_now ("%qs in cannot appear in COMMON at %L "
937 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
939 if (csym
->ts
.type
!= BT_DERIVED
)
942 if (!(csym
->ts
.u
.derived
->attr
.sequence
943 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
944 gfc_error_now ("Derived type variable %qs in COMMON at %L "
945 "has neither the SEQUENCE nor the BIND(C) "
946 "attribute", csym
->name
, &csym
->declared_at
);
947 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
948 gfc_error_now ("Derived type variable %qs in COMMON at %L "
949 "has an ultimate component that is "
950 "allocatable", csym
->name
, &csym
->declared_at
);
951 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
952 gfc_error_now ("Derived type variable %qs in COMMON at %L "
953 "may not have default initializer", csym
->name
,
956 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
957 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
961 /* Resolve common blocks. */
963 resolve_common_blocks (gfc_symtree
*common_root
)
968 if (common_root
== NULL
)
971 if (common_root
->left
)
972 resolve_common_blocks (common_root
->left
);
973 if (common_root
->right
)
974 resolve_common_blocks (common_root
->right
);
976 resolve_common_vars (common_root
->n
.common
->head
, true);
978 /* The common name is a global name - in Fortran 2003 also if it has a
979 C binding name, since Fortran 2008 only the C binding name is a global
981 if (!common_root
->n
.common
->binding_label
982 || gfc_notification_std (GFC_STD_F2008
))
984 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
985 common_root
->n
.common
->name
);
987 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
988 && gsym
->type
== GSYM_COMMON
989 && ((common_root
->n
.common
->binding_label
990 && (!gsym
->binding_label
991 || strcmp (common_root
->n
.common
->binding_label
,
992 gsym
->binding_label
) != 0))
993 || (!common_root
->n
.common
->binding_label
994 && gsym
->binding_label
)))
996 gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global "
997 "identifier and must thus have the same binding name "
998 "as the same-named COMMON block at %L: %s vs %s",
999 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1001 common_root
->n
.common
->binding_label
1002 ? common_root
->n
.common
->binding_label
: "(blank)",
1003 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
1008 && !common_root
->n
.common
->binding_label
)
1010 gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier "
1012 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1016 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1018 gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at "
1019 "%L sharing the identifier with global non-COMMON-block "
1020 "entity at %L", common_root
->n
.common
->name
,
1021 &common_root
->n
.common
->where
, &gsym
->where
);
1026 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1027 gsym
->type
= GSYM_COMMON
;
1028 gsym
->where
= common_root
->n
.common
->where
;
1034 if (common_root
->n
.common
->binding_label
)
1036 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1037 common_root
->n
.common
->binding_label
);
1038 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1040 gfc_error_1 ("COMMON block at %L with binding label %s uses the same "
1041 "global identifier as entity at %L",
1042 &common_root
->n
.common
->where
,
1043 common_root
->n
.common
->binding_label
, &gsym
->where
);
1048 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1049 gsym
->type
= GSYM_COMMON
;
1050 gsym
->where
= common_root
->n
.common
->where
;
1056 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1060 if (sym
->attr
.flavor
== FL_PARAMETER
)
1061 gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L",
1062 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1064 if (sym
->attr
.external
)
1065 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1066 sym
->name
, &common_root
->n
.common
->where
);
1068 if (sym
->attr
.intrinsic
)
1069 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1070 sym
->name
, &common_root
->n
.common
->where
);
1071 else if (sym
->attr
.result
1072 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1073 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1074 "that is also a function result", sym
->name
,
1075 &common_root
->n
.common
->where
);
1076 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1077 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1078 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1079 "that is also a global procedure", sym
->name
,
1080 &common_root
->n
.common
->where
);
1084 /* Resolve contained function types. Because contained functions can call one
1085 another, they have to be worked out before any of the contained procedures
1088 The good news is that if a function doesn't already have a type, the only
1089 way it can get one is through an IMPLICIT type or a RESULT variable, because
1090 by definition contained functions are contained namespace they're contained
1091 in, not in a sibling or parent namespace. */
1094 resolve_contained_functions (gfc_namespace
*ns
)
1096 gfc_namespace
*child
;
1099 resolve_formal_arglists (ns
);
1101 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1103 /* Resolve alternate entry points first. */
1104 resolve_entries (child
);
1106 /* Then check function return types. */
1107 resolve_contained_fntype (child
->proc_name
, child
);
1108 for (el
= child
->entries
; el
; el
= el
->next
)
1109 resolve_contained_fntype (el
->sym
, child
);
1114 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1117 /* Resolve all of the elements of a structure constructor and make sure that
1118 the types are correct. The 'init' flag indicates that the given
1119 constructor is an initializer. */
1122 resolve_structure_cons (gfc_expr
*expr
, int init
)
1124 gfc_constructor
*cons
;
1125 gfc_component
*comp
;
1131 if (expr
->ts
.type
== BT_DERIVED
)
1132 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1134 cons
= gfc_constructor_first (expr
->value
.constructor
);
1136 /* A constructor may have references if it is the result of substituting a
1137 parameter variable. In this case we just pull out the component we
1140 comp
= expr
->ref
->u
.c
.sym
->components
;
1142 comp
= expr
->ts
.u
.derived
->components
;
1144 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1151 if (!gfc_resolve_expr (cons
->expr
))
1157 rank
= comp
->as
? comp
->as
->rank
: 0;
1158 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1159 rank
= CLASS_DATA (comp
)->as
->rank
;
1161 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1162 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1164 gfc_error ("The rank of the element in the structure "
1165 "constructor at %L does not match that of the "
1166 "component (%d/%d)", &cons
->expr
->where
,
1167 cons
->expr
->rank
, rank
);
1171 /* If we don't have the right type, try to convert it. */
1173 if (!comp
->attr
.proc_pointer
&&
1174 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1176 if (strcmp (comp
->name
, "_extends") == 0)
1178 /* Can afford to be brutal with the _extends initializer.
1179 The derived type can get lost because it is PRIVATE
1180 but it is not usage constrained by the standard. */
1181 cons
->expr
->ts
= comp
->ts
;
1183 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1185 gfc_error ("The element in the structure constructor at %L, "
1186 "for pointer component %qs, is %s but should be %s",
1187 &cons
->expr
->where
, comp
->name
,
1188 gfc_basic_typename (cons
->expr
->ts
.type
),
1189 gfc_basic_typename (comp
->ts
.type
));
1194 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1200 /* For strings, the length of the constructor should be the same as
1201 the one of the structure, ensure this if the lengths are known at
1202 compile time and when we are dealing with PARAMETER or structure
1204 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1205 && comp
->ts
.u
.cl
->length
1206 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1207 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1208 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1209 && cons
->expr
->rank
!= 0
1210 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1211 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1213 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1214 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1216 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1217 to make use of the gfc_resolve_character_array_constructor
1218 machinery. The expression is later simplified away to
1219 an array of string literals. */
1220 gfc_expr
*para
= cons
->expr
;
1221 cons
->expr
= gfc_get_expr ();
1222 cons
->expr
->ts
= para
->ts
;
1223 cons
->expr
->where
= para
->where
;
1224 cons
->expr
->expr_type
= EXPR_ARRAY
;
1225 cons
->expr
->rank
= para
->rank
;
1226 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1227 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1228 para
, &cons
->expr
->where
);
1230 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1233 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1234 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1236 gfc_charlen
*cl
, *cl2
;
1239 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1241 if (cl
== cons
->expr
->ts
.u
.cl
)
1249 cl2
->next
= cl
->next
;
1251 gfc_free_expr (cl
->length
);
1255 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1256 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1257 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1258 gfc_resolve_character_array_constructor (cons
->expr
);
1262 if (cons
->expr
->expr_type
== EXPR_NULL
1263 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1264 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1265 || (comp
->ts
.type
== BT_CLASS
1266 && (CLASS_DATA (comp
)->attr
.class_pointer
1267 || CLASS_DATA (comp
)->attr
.allocatable
))))
1270 gfc_error ("The NULL in the structure constructor at %L is "
1271 "being applied to component %qs, which is neither "
1272 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1276 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1278 /* Check procedure pointer interface. */
1279 gfc_symbol
*s2
= NULL
;
1284 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1287 s2
= c2
->ts
.interface
;
1290 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1292 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1293 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1295 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1297 s2
= cons
->expr
->symtree
->n
.sym
;
1298 name
= cons
->expr
->symtree
->n
.sym
->name
;
1301 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1302 err
, sizeof (err
), NULL
, NULL
))
1304 gfc_error ("Interface mismatch for procedure-pointer component "
1305 "%qs in structure constructor at %L: %s",
1306 comp
->name
, &cons
->expr
->where
, err
);
1311 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1312 || cons
->expr
->expr_type
== EXPR_NULL
)
1315 a
= gfc_expr_attr (cons
->expr
);
1317 if (!a
.pointer
&& !a
.target
)
1320 gfc_error ("The element in the structure constructor at %L, "
1321 "for pointer component %qs should be a POINTER or "
1322 "a TARGET", &cons
->expr
->where
, comp
->name
);
1327 /* F08:C461. Additional checks for pointer initialization. */
1331 gfc_error ("Pointer initialization target at %L "
1332 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1337 gfc_error ("Pointer initialization target at %L "
1338 "must have the SAVE attribute", &cons
->expr
->where
);
1342 /* F2003, C1272 (3). */
1343 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1344 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1345 || gfc_is_coindexed (cons
->expr
));
1346 if (impure
&& gfc_pure (NULL
))
1349 gfc_error ("Invalid expression in the structure constructor for "
1350 "pointer component %qs at %L in PURE procedure",
1351 comp
->name
, &cons
->expr
->where
);
1355 gfc_unset_implicit_pure (NULL
);
1362 /****************** Expression name resolution ******************/
1364 /* Returns 0 if a symbol was not declared with a type or
1365 attribute declaration statement, nonzero otherwise. */
1368 was_declared (gfc_symbol
*sym
)
1374 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1377 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1378 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1379 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1380 || a
.asynchronous
|| a
.codimension
)
1387 /* Determine if a symbol is generic or not. */
1390 generic_sym (gfc_symbol
*sym
)
1394 if (sym
->attr
.generic
||
1395 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1398 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1401 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1408 return generic_sym (s
);
1415 /* Determine if a symbol is specific or not. */
1418 specific_sym (gfc_symbol
*sym
)
1422 if (sym
->attr
.if_source
== IFSRC_IFBODY
1423 || sym
->attr
.proc
== PROC_MODULE
1424 || sym
->attr
.proc
== PROC_INTERNAL
1425 || sym
->attr
.proc
== PROC_ST_FUNCTION
1426 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1427 || sym
->attr
.external
)
1430 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1433 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1435 return (s
== NULL
) ? 0 : specific_sym (s
);
1439 /* Figure out if the procedure is specific, generic or unknown. */
1442 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1446 procedure_kind (gfc_symbol
*sym
)
1448 if (generic_sym (sym
))
1449 return PTYPE_GENERIC
;
1451 if (specific_sym (sym
))
1452 return PTYPE_SPECIFIC
;
1454 return PTYPE_UNKNOWN
;
1457 /* Check references to assumed size arrays. The flag need_full_assumed_size
1458 is nonzero when matching actual arguments. */
1460 static int need_full_assumed_size
= 0;
1463 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1465 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1468 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1469 What should it be? */
1470 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1471 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1472 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1474 gfc_error ("The upper bound in the last dimension must "
1475 "appear in the reference to the assumed size "
1476 "array %qs at %L", sym
->name
, &e
->where
);
1483 /* Look for bad assumed size array references in argument expressions
1484 of elemental and array valued intrinsic procedures. Since this is
1485 called from procedure resolution functions, it only recurses at
1489 resolve_assumed_size_actual (gfc_expr
*e
)
1494 switch (e
->expr_type
)
1497 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1502 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1503 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1514 /* Check a generic procedure, passed as an actual argument, to see if
1515 there is a matching specific name. If none, it is an error, and if
1516 more than one, the reference is ambiguous. */
1518 count_specific_procs (gfc_expr
*e
)
1525 sym
= e
->symtree
->n
.sym
;
1527 for (p
= sym
->generic
; p
; p
= p
->next
)
1528 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1530 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1536 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1540 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1541 "argument at %L", sym
->name
, &e
->where
);
1547 /* See if a call to sym could possibly be a not allowed RECURSION because of
1548 a missing RECURSIVE declaration. This means that either sym is the current
1549 context itself, or sym is the parent of a contained procedure calling its
1550 non-RECURSIVE containing procedure.
1551 This also works if sym is an ENTRY. */
1554 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1556 gfc_symbol
* proc_sym
;
1557 gfc_symbol
* context_proc
;
1558 gfc_namespace
* real_context
;
1560 if (sym
->attr
.flavor
== FL_PROGRAM
1561 || sym
->attr
.flavor
== FL_DERIVED
)
1564 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1566 /* If we've got an ENTRY, find real procedure. */
1567 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1568 proc_sym
= sym
->ns
->entries
->sym
;
1572 /* If sym is RECURSIVE, all is well of course. */
1573 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1576 /* Find the context procedure's "real" symbol if it has entries.
1577 We look for a procedure symbol, so recurse on the parents if we don't
1578 find one (like in case of a BLOCK construct). */
1579 for (real_context
= context
; ; real_context
= real_context
->parent
)
1581 /* We should find something, eventually! */
1582 gcc_assert (real_context
);
1584 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1585 : real_context
->proc_name
);
1587 /* In some special cases, there may not be a proc_name, like for this
1589 real(bad_kind()) function foo () ...
1590 when checking the call to bad_kind ().
1591 In these cases, we simply return here and assume that the
1596 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1600 /* A call from sym's body to itself is recursion, of course. */
1601 if (context_proc
== proc_sym
)
1604 /* The same is true if context is a contained procedure and sym the
1606 if (context_proc
->attr
.contained
)
1608 gfc_symbol
* parent_proc
;
1610 gcc_assert (context
->parent
);
1611 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1612 : context
->parent
->proc_name
);
1614 if (parent_proc
== proc_sym
)
1622 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1623 its typespec and formal argument list. */
1626 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1628 gfc_intrinsic_sym
* isym
= NULL
;
1634 /* Already resolved. */
1635 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1638 /* We already know this one is an intrinsic, so we don't call
1639 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1640 gfc_find_subroutine directly to check whether it is a function or
1643 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1645 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1646 isym
= gfc_intrinsic_subroutine_by_id (id
);
1648 else if (sym
->intmod_sym_id
)
1650 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1651 isym
= gfc_intrinsic_function_by_id (id
);
1653 else if (!sym
->attr
.subroutine
)
1654 isym
= gfc_find_function (sym
->name
);
1656 if (isym
&& !sym
->attr
.subroutine
)
1658 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1659 && !sym
->attr
.implicit_type
)
1660 gfc_warning (OPT_Wsurprising
,
1661 "Type specified for intrinsic function %qs at %L is"
1662 " ignored", sym
->name
, &sym
->declared_at
);
1664 if (!sym
->attr
.function
&&
1665 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1670 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1672 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1674 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1675 " specifier", sym
->name
, &sym
->declared_at
);
1679 if (!sym
->attr
.subroutine
&&
1680 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1685 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1690 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1692 sym
->attr
.pure
= isym
->pure
;
1693 sym
->attr
.elemental
= isym
->elemental
;
1695 /* Check it is actually available in the standard settings. */
1696 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1698 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1699 "available in the current standard settings but %s. Use "
1700 "an appropriate %<-std=*%> option or enable "
1701 "%<-fall-intrinsics%> in order to use it.",
1702 sym
->name
, &sym
->declared_at
, symstd
);
1710 /* Resolve a procedure expression, like passing it to a called procedure or as
1711 RHS for a procedure pointer assignment. */
1714 resolve_procedure_expression (gfc_expr
* expr
)
1718 if (expr
->expr_type
!= EXPR_VARIABLE
)
1720 gcc_assert (expr
->symtree
);
1722 sym
= expr
->symtree
->n
.sym
;
1724 if (sym
->attr
.intrinsic
)
1725 gfc_resolve_intrinsic (sym
, &expr
->where
);
1727 if (sym
->attr
.flavor
!= FL_PROCEDURE
1728 || (sym
->attr
.function
&& sym
->result
== sym
))
1731 /* A non-RECURSIVE procedure that is used as procedure expression within its
1732 own body is in danger of being called recursively. */
1733 if (is_illegal_recursion (sym
, gfc_current_ns
))
1734 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1735 " itself recursively. Declare it RECURSIVE or use"
1736 " %<-frecursive%>", sym
->name
, &expr
->where
);
1742 /* Resolve an actual argument list. Most of the time, this is just
1743 resolving the expressions in the list.
1744 The exception is that we sometimes have to decide whether arguments
1745 that look like procedure arguments are really simple variable
1749 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1750 bool no_formal_args
)
1753 gfc_symtree
*parent_st
;
1755 gfc_component
*comp
;
1756 int save_need_full_assumed_size
;
1757 bool return_value
= false;
1758 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1761 first_actual_arg
= true;
1763 for (; arg
; arg
= arg
->next
)
1768 /* Check the label is a valid branching target. */
1771 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1773 gfc_error ("Label %d referenced at %L is never defined",
1774 arg
->label
->value
, &arg
->label
->where
);
1778 first_actual_arg
= false;
1782 if (e
->expr_type
== EXPR_VARIABLE
1783 && e
->symtree
->n
.sym
->attr
.generic
1785 && count_specific_procs (e
) != 1)
1788 if (e
->ts
.type
!= BT_PROCEDURE
)
1790 save_need_full_assumed_size
= need_full_assumed_size
;
1791 if (e
->expr_type
!= EXPR_VARIABLE
)
1792 need_full_assumed_size
= 0;
1793 if (!gfc_resolve_expr (e
))
1795 need_full_assumed_size
= save_need_full_assumed_size
;
1799 /* See if the expression node should really be a variable reference. */
1801 sym
= e
->symtree
->n
.sym
;
1803 if (sym
->attr
.flavor
== FL_PROCEDURE
1804 || sym
->attr
.intrinsic
1805 || sym
->attr
.external
)
1809 /* If a procedure is not already determined to be something else
1810 check if it is intrinsic. */
1811 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1812 sym
->attr
.intrinsic
= 1;
1814 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1816 gfc_error ("Statement function %qs at %L is not allowed as an "
1817 "actual argument", sym
->name
, &e
->where
);
1820 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1821 sym
->attr
.subroutine
);
1822 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1824 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1825 "actual argument", sym
->name
, &e
->where
);
1828 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1829 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1831 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1832 " used as actual argument at %L",
1833 sym
->name
, &e
->where
))
1837 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1839 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1840 "allowed as an actual argument at %L", sym
->name
,
1844 /* Check if a generic interface has a specific procedure
1845 with the same name before emitting an error. */
1846 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1849 /* Just in case a specific was found for the expression. */
1850 sym
= e
->symtree
->n
.sym
;
1852 /* If the symbol is the function that names the current (or
1853 parent) scope, then we really have a variable reference. */
1855 if (gfc_is_function_return_value (sym
, sym
->ns
))
1858 /* If all else fails, see if we have a specific intrinsic. */
1859 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1861 gfc_intrinsic_sym
*isym
;
1863 isym
= gfc_find_function (sym
->name
);
1864 if (isym
== NULL
|| !isym
->specific
)
1866 gfc_error ("Unable to find a specific INTRINSIC procedure "
1867 "for the reference %qs at %L", sym
->name
,
1872 sym
->attr
.intrinsic
= 1;
1873 sym
->attr
.function
= 1;
1876 if (!gfc_resolve_expr (e
))
1881 /* See if the name is a module procedure in a parent unit. */
1883 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1886 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1888 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1892 if (parent_st
== NULL
)
1895 sym
= parent_st
->n
.sym
;
1896 e
->symtree
= parent_st
; /* Point to the right thing. */
1898 if (sym
->attr
.flavor
== FL_PROCEDURE
1899 || sym
->attr
.intrinsic
1900 || sym
->attr
.external
)
1902 if (!gfc_resolve_expr (e
))
1908 e
->expr_type
= EXPR_VARIABLE
;
1910 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1911 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1912 && CLASS_DATA (sym
)->as
))
1914 e
->rank
= sym
->ts
.type
== BT_CLASS
1915 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1916 e
->ref
= gfc_get_ref ();
1917 e
->ref
->type
= REF_ARRAY
;
1918 e
->ref
->u
.ar
.type
= AR_FULL
;
1919 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1920 ? CLASS_DATA (sym
)->as
: sym
->as
;
1923 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1924 primary.c (match_actual_arg). If above code determines that it
1925 is a variable instead, it needs to be resolved as it was not
1926 done at the beginning of this function. */
1927 save_need_full_assumed_size
= need_full_assumed_size
;
1928 if (e
->expr_type
!= EXPR_VARIABLE
)
1929 need_full_assumed_size
= 0;
1930 if (!gfc_resolve_expr (e
))
1932 need_full_assumed_size
= save_need_full_assumed_size
;
1935 /* Check argument list functions %VAL, %LOC and %REF. There is
1936 nothing to do for %REF. */
1937 if (arg
->name
&& arg
->name
[0] == '%')
1939 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1941 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1943 gfc_error ("By-value argument at %L is not of numeric "
1950 gfc_error ("By-value argument at %L cannot be an array or "
1951 "an array section", &e
->where
);
1955 /* Intrinsics are still PROC_UNKNOWN here. However,
1956 since same file external procedures are not resolvable
1957 in gfortran, it is a good deal easier to leave them to
1959 if (ptype
!= PROC_UNKNOWN
1960 && ptype
!= PROC_DUMMY
1961 && ptype
!= PROC_EXTERNAL
1962 && ptype
!= PROC_MODULE
)
1964 gfc_error ("By-value argument at %L is not allowed "
1965 "in this context", &e
->where
);
1970 /* Statement functions have already been excluded above. */
1971 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1972 && e
->ts
.type
== BT_PROCEDURE
)
1974 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1976 gfc_error ("Passing internal procedure at %L by location "
1977 "not allowed", &e
->where
);
1983 comp
= gfc_get_proc_ptr_comp(e
);
1984 if (comp
&& comp
->attr
.elemental
)
1986 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1987 "allowed as an actual argument at %L", comp
->name
,
1991 /* Fortran 2008, C1237. */
1992 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1993 && gfc_has_ultimate_pointer (e
))
1995 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1996 "component", &e
->where
);
2000 first_actual_arg
= false;
2003 return_value
= true;
2006 actual_arg
= actual_arg_sav
;
2007 first_actual_arg
= first_actual_arg_sav
;
2009 return return_value
;
2013 /* Do the checks of the actual argument list that are specific to elemental
2014 procedures. If called with c == NULL, we have a function, otherwise if
2015 expr == NULL, we have a subroutine. */
2018 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2020 gfc_actual_arglist
*arg0
;
2021 gfc_actual_arglist
*arg
;
2022 gfc_symbol
*esym
= NULL
;
2023 gfc_intrinsic_sym
*isym
= NULL
;
2025 gfc_intrinsic_arg
*iformal
= NULL
;
2026 gfc_formal_arglist
*eformal
= NULL
;
2027 bool formal_optional
= false;
2028 bool set_by_optional
= false;
2032 /* Is this an elemental procedure? */
2033 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2035 if (expr
->value
.function
.esym
!= NULL
2036 && expr
->value
.function
.esym
->attr
.elemental
)
2038 arg0
= expr
->value
.function
.actual
;
2039 esym
= expr
->value
.function
.esym
;
2041 else if (expr
->value
.function
.isym
!= NULL
2042 && expr
->value
.function
.isym
->elemental
)
2044 arg0
= expr
->value
.function
.actual
;
2045 isym
= expr
->value
.function
.isym
;
2050 else if (c
&& c
->ext
.actual
!= NULL
)
2052 arg0
= c
->ext
.actual
;
2054 if (c
->resolved_sym
)
2055 esym
= c
->resolved_sym
;
2057 esym
= c
->symtree
->n
.sym
;
2060 if (!esym
->attr
.elemental
)
2066 /* The rank of an elemental is the rank of its array argument(s). */
2067 for (arg
= arg0
; arg
; arg
= arg
->next
)
2069 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2071 rank
= arg
->expr
->rank
;
2072 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2073 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2074 set_by_optional
= true;
2076 /* Function specific; set the result rank and shape. */
2080 if (!expr
->shape
&& arg
->expr
->shape
)
2082 expr
->shape
= gfc_get_shape (rank
);
2083 for (i
= 0; i
< rank
; i
++)
2084 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2091 /* If it is an array, it shall not be supplied as an actual argument
2092 to an elemental procedure unless an array of the same rank is supplied
2093 as an actual argument corresponding to a nonoptional dummy argument of
2094 that elemental procedure(12.4.1.5). */
2095 formal_optional
= false;
2097 iformal
= isym
->formal
;
2099 eformal
= esym
->formal
;
2101 for (arg
= arg0
; arg
; arg
= arg
->next
)
2105 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2106 formal_optional
= true;
2107 eformal
= eformal
->next
;
2109 else if (isym
&& iformal
)
2111 if (iformal
->optional
)
2112 formal_optional
= true;
2113 iformal
= iformal
->next
;
2116 formal_optional
= true;
2118 if (pedantic
&& arg
->expr
!= NULL
2119 && arg
->expr
->expr_type
== EXPR_VARIABLE
2120 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2123 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2124 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2126 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2127 "MISSING, it cannot be the actual argument of an "
2128 "ELEMENTAL procedure unless there is a non-optional "
2129 "argument with the same rank (12.4.1.5)",
2130 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2134 for (arg
= arg0
; arg
; arg
= arg
->next
)
2136 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2139 /* Being elemental, the last upper bound of an assumed size array
2140 argument must be present. */
2141 if (resolve_assumed_size_actual (arg
->expr
))
2144 /* Elemental procedure's array actual arguments must conform. */
2147 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2154 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2155 is an array, the intent inout/out variable needs to be also an array. */
2156 if (rank
> 0 && esym
&& expr
== NULL
)
2157 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2158 arg
= arg
->next
, eformal
= eformal
->next
)
2159 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2160 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2161 && arg
->expr
&& arg
->expr
->rank
== 0)
2163 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2164 "ELEMENTAL subroutine %qs is a scalar, but another "
2165 "actual argument is an array", &arg
->expr
->where
,
2166 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2167 : "INOUT", eformal
->sym
->name
, esym
->name
);
2174 /* This function does the checking of references to global procedures
2175 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2176 77 and 95 standards. It checks for a gsymbol for the name, making
2177 one if it does not already exist. If it already exists, then the
2178 reference being resolved must correspond to the type of gsymbol.
2179 Otherwise, the new symbol is equipped with the attributes of the
2180 reference. The corresponding code that is called in creating
2181 global entities is parse.c.
2183 In addition, for all but -std=legacy, the gsymbols are used to
2184 check the interfaces of external procedures from the same file.
2185 The namespace of the gsymbol is resolved and then, once this is
2186 done the interface is checked. */
2190 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2192 if (!gsym_ns
->proc_name
->attr
.recursive
)
2195 if (sym
->ns
== gsym_ns
)
2198 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2205 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2207 if (gsym_ns
->entries
)
2209 gfc_entry_list
*entry
= gsym_ns
->entries
;
2211 for (; entry
; entry
= entry
->next
)
2213 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2215 if (strcmp (gsym_ns
->proc_name
->name
,
2216 sym
->ns
->proc_name
->name
) == 0)
2220 && strcmp (gsym_ns
->proc_name
->name
,
2221 sym
->ns
->parent
->proc_name
->name
) == 0)
2230 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2233 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2235 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2237 for ( ; arg
; arg
= arg
->next
)
2242 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2244 strncpy (errmsg
, _("allocatable argument"), err_len
);
2247 else if (arg
->sym
->attr
.asynchronous
)
2249 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2252 else if (arg
->sym
->attr
.optional
)
2254 strncpy (errmsg
, _("optional argument"), err_len
);
2257 else if (arg
->sym
->attr
.pointer
)
2259 strncpy (errmsg
, _("pointer argument"), err_len
);
2262 else if (arg
->sym
->attr
.target
)
2264 strncpy (errmsg
, _("target argument"), err_len
);
2267 else if (arg
->sym
->attr
.value
)
2269 strncpy (errmsg
, _("value argument"), err_len
);
2272 else if (arg
->sym
->attr
.volatile_
)
2274 strncpy (errmsg
, _("volatile argument"), err_len
);
2277 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2279 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2282 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2284 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2287 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2289 strncpy (errmsg
, _("coarray argument"), err_len
);
2292 else if (false) /* (2d) TODO: parametrized derived type */
2294 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2297 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2299 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2302 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2304 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2307 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2309 /* As assumed-type is unlimited polymorphic (cf. above).
2310 See also TS 29113, Note 6.1. */
2311 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2316 if (sym
->attr
.function
)
2318 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2320 if (res
->attr
.dimension
) /* (3a) */
2322 strncpy (errmsg
, _("array result"), err_len
);
2325 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2327 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2330 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2331 && res
->ts
.u
.cl
->length
2332 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2334 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2339 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2341 strncpy (errmsg
, _("elemental procedure"), err_len
);
2344 else if (sym
->attr
.is_bind_c
) /* (5) */
2346 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2355 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2356 gfc_actual_arglist
**actual
, int sub
)
2360 enum gfc_symbol_type type
;
2363 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2365 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2367 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2368 gfc_global_used (gsym
, where
);
2370 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2371 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2372 && gsym
->type
!= GSYM_UNKNOWN
2373 && !gsym
->binding_label
2375 && gsym
->ns
->resolved
!= -1
2376 && gsym
->ns
->proc_name
2377 && not_in_recursive (sym
, gsym
->ns
)
2378 && not_entry_self_reference (sym
, gsym
->ns
))
2380 gfc_symbol
*def_sym
;
2382 /* Resolve the gsymbol namespace if needed. */
2383 if (!gsym
->ns
->resolved
)
2385 gfc_dt_list
*old_dt_list
;
2386 struct gfc_omp_saved_state old_omp_state
;
2388 /* Stash away derived types so that the backend_decls do not
2390 old_dt_list
= gfc_derived_types
;
2391 gfc_derived_types
= NULL
;
2392 /* And stash away openmp state. */
2393 gfc_omp_save_and_clear_state (&old_omp_state
);
2395 gfc_resolve (gsym
->ns
);
2397 /* Store the new derived types with the global namespace. */
2398 if (gfc_derived_types
)
2399 gsym
->ns
->derived_types
= gfc_derived_types
;
2401 /* Restore the derived types of this namespace. */
2402 gfc_derived_types
= old_dt_list
;
2403 /* And openmp state. */
2404 gfc_omp_restore_state (&old_omp_state
);
2407 /* Make sure that translation for the gsymbol occurs before
2408 the procedure currently being resolved. */
2409 ns
= gfc_global_ns_list
;
2410 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2412 if (ns
->sibling
== gsym
->ns
)
2414 ns
->sibling
= gsym
->ns
->sibling
;
2415 gsym
->ns
->sibling
= gfc_global_ns_list
;
2416 gfc_global_ns_list
= gsym
->ns
;
2421 def_sym
= gsym
->ns
->proc_name
;
2423 /* This can happen if a binding name has been specified. */
2424 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2425 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2427 if (def_sym
->attr
.entry_master
)
2429 gfc_entry_list
*entry
;
2430 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2431 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2433 def_sym
= entry
->sym
;
2438 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2440 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2441 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2442 gfc_typename (&def_sym
->ts
));
2446 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2447 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2449 gfc_error ("Explicit interface required for %qs at %L: %s",
2450 sym
->name
, &sym
->declared_at
, reason
);
2454 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2455 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2456 gfc_errors_to_warnings (true);
2458 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2459 reason
, sizeof(reason
), NULL
, NULL
))
2461 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2462 sym
->name
, &sym
->declared_at
, reason
);
2467 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2468 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2469 gfc_errors_to_warnings (true);
2471 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2472 gfc_procedure_use (def_sym
, actual
, where
);
2476 gfc_errors_to_warnings (false);
2478 if (gsym
->type
== GSYM_UNKNOWN
)
2481 gsym
->where
= *where
;
2488 /************* Function resolution *************/
2490 /* Resolve a function call known to be generic.
2491 Section 14.1.2.4.1. */
2494 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2498 if (sym
->attr
.generic
)
2500 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2503 expr
->value
.function
.name
= s
->name
;
2504 expr
->value
.function
.esym
= s
;
2506 if (s
->ts
.type
!= BT_UNKNOWN
)
2508 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2509 expr
->ts
= s
->result
->ts
;
2512 expr
->rank
= s
->as
->rank
;
2513 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2514 expr
->rank
= s
->result
->as
->rank
;
2516 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2521 /* TODO: Need to search for elemental references in generic
2525 if (sym
->attr
.intrinsic
)
2526 return gfc_intrinsic_func_interface (expr
, 0);
2533 resolve_generic_f (gfc_expr
*expr
)
2537 gfc_interface
*intr
= NULL
;
2539 sym
= expr
->symtree
->n
.sym
;
2543 m
= resolve_generic_f0 (expr
, sym
);
2546 else if (m
== MATCH_ERROR
)
2551 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2552 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2555 if (sym
->ns
->parent
== NULL
)
2557 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2561 if (!generic_sym (sym
))
2565 /* Last ditch attempt. See if the reference is to an intrinsic
2566 that possesses a matching interface. 14.1.2.4 */
2567 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2569 gfc_error ("There is no specific function for the generic %qs "
2570 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2576 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2579 return resolve_structure_cons (expr
, 0);
2582 m
= gfc_intrinsic_func_interface (expr
, 0);
2587 gfc_error ("Generic function %qs at %L is not consistent with a "
2588 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2595 /* Resolve a function call known to be specific. */
2598 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2602 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2604 if (sym
->attr
.dummy
)
2606 sym
->attr
.proc
= PROC_DUMMY
;
2610 sym
->attr
.proc
= PROC_EXTERNAL
;
2614 if (sym
->attr
.proc
== PROC_MODULE
2615 || sym
->attr
.proc
== PROC_ST_FUNCTION
2616 || sym
->attr
.proc
== PROC_INTERNAL
)
2619 if (sym
->attr
.intrinsic
)
2621 m
= gfc_intrinsic_func_interface (expr
, 1);
2625 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2626 "with an intrinsic", sym
->name
, &expr
->where
);
2634 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2637 expr
->ts
= sym
->result
->ts
;
2640 expr
->value
.function
.name
= sym
->name
;
2641 expr
->value
.function
.esym
= sym
;
2642 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2644 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2646 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2647 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2648 else if (sym
->as
!= NULL
)
2649 expr
->rank
= sym
->as
->rank
;
2656 resolve_specific_f (gfc_expr
*expr
)
2661 sym
= expr
->symtree
->n
.sym
;
2665 m
= resolve_specific_f0 (sym
, expr
);
2668 if (m
== MATCH_ERROR
)
2671 if (sym
->ns
->parent
== NULL
)
2674 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2680 gfc_error ("Unable to resolve the specific function %qs at %L",
2681 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2687 /* Resolve a procedure call not known to be generic nor specific. */
2690 resolve_unknown_f (gfc_expr
*expr
)
2695 sym
= expr
->symtree
->n
.sym
;
2697 if (sym
->attr
.dummy
)
2699 sym
->attr
.proc
= PROC_DUMMY
;
2700 expr
->value
.function
.name
= sym
->name
;
2704 /* See if we have an intrinsic function reference. */
2706 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2708 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2713 /* The reference is to an external name. */
2715 sym
->attr
.proc
= PROC_EXTERNAL
;
2716 expr
->value
.function
.name
= sym
->name
;
2717 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2719 if (sym
->as
!= NULL
)
2720 expr
->rank
= sym
->as
->rank
;
2722 /* Type of the expression is either the type of the symbol or the
2723 default type of the symbol. */
2726 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2728 if (sym
->ts
.type
!= BT_UNKNOWN
)
2732 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2734 if (ts
->type
== BT_UNKNOWN
)
2736 gfc_error ("Function %qs at %L has no IMPLICIT type",
2737 sym
->name
, &expr
->where
);
2748 /* Return true, if the symbol is an external procedure. */
2750 is_external_proc (gfc_symbol
*sym
)
2752 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2753 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2754 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2755 && !sym
->attr
.proc_pointer
2756 && !sym
->attr
.use_assoc
2764 /* Figure out if a function reference is pure or not. Also set the name
2765 of the function for a potential error message. Return nonzero if the
2766 function is PURE, zero if not. */
2768 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2771 pure_function (gfc_expr
*e
, const char **name
)
2774 gfc_component
*comp
;
2778 if (e
->symtree
!= NULL
2779 && e
->symtree
->n
.sym
!= NULL
2780 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2781 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2783 comp
= gfc_get_proc_ptr_comp (e
);
2786 pure
= gfc_pure (comp
->ts
.interface
);
2789 else if (e
->value
.function
.esym
)
2791 pure
= gfc_pure (e
->value
.function
.esym
);
2792 *name
= e
->value
.function
.esym
->name
;
2794 else if (e
->value
.function
.isym
)
2796 pure
= e
->value
.function
.isym
->pure
2797 || e
->value
.function
.isym
->elemental
;
2798 *name
= e
->value
.function
.isym
->name
;
2802 /* Implicit functions are not pure. */
2804 *name
= e
->value
.function
.name
;
2812 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2813 int *f ATTRIBUTE_UNUSED
)
2817 /* Don't bother recursing into other statement functions
2818 since they will be checked individually for purity. */
2819 if (e
->expr_type
!= EXPR_FUNCTION
2821 || e
->symtree
->n
.sym
== sym
2822 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2825 return pure_function (e
, &name
) ? false : true;
2830 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2832 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2836 /* Check if an impure function is allowed in the current context. */
2838 static bool check_pure_function (gfc_expr
*e
)
2840 const char *name
= NULL
;
2841 if (!pure_function (e
, &name
) && name
)
2845 gfc_error ("Reference to impure function %qs at %L inside a "
2846 "FORALL %s", name
, &e
->where
,
2847 forall_flag
== 2 ? "mask" : "block");
2850 else if (gfc_do_concurrent_flag
)
2852 gfc_error ("Reference to impure function %qs at %L inside a "
2853 "DO CONCURRENT %s", name
, &e
->where
,
2854 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2857 else if (gfc_pure (NULL
))
2859 gfc_error ("Reference to impure function %qs at %L "
2860 "within a PURE procedure", name
, &e
->where
);
2863 gfc_unset_implicit_pure (NULL
);
2869 /* Update current procedure's array_outer_dependency flag, considering
2870 a call to procedure SYM. */
2873 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2875 /* Check to see if this is a sibling function that has not yet
2877 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2878 for (; sibling
; sibling
= sibling
->sibling
)
2880 if (sibling
->proc_name
== sym
)
2882 gfc_resolve (sibling
);
2887 /* If SYM has references to outer arrays, so has the procedure calling
2888 SYM. If SYM is a procedure pointer, we can assume the worst. */
2889 if (sym
->attr
.array_outer_dependency
2890 || sym
->attr
.proc_pointer
)
2891 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2895 /* Resolve a function call, which means resolving the arguments, then figuring
2896 out which entity the name refers to. */
2899 resolve_function (gfc_expr
*expr
)
2901 gfc_actual_arglist
*arg
;
2905 procedure_type p
= PROC_INTRINSIC
;
2906 bool no_formal_args
;
2910 sym
= expr
->symtree
->n
.sym
;
2912 /* If this is a procedure pointer component, it has already been resolved. */
2913 if (gfc_is_proc_ptr_comp (expr
))
2916 if (sym
&& sym
->attr
.intrinsic
2917 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2920 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2922 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2926 /* If this ia a deferred TBP with an abstract interface (which may
2927 of course be referenced), expr->value.function.esym will be set. */
2928 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2930 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2931 sym
->name
, &expr
->where
);
2935 /* Switch off assumed size checking and do this again for certain kinds
2936 of procedure, once the procedure itself is resolved. */
2937 need_full_assumed_size
++;
2939 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2940 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2942 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2943 inquiry_argument
= true;
2944 no_formal_args
= sym
&& is_external_proc (sym
)
2945 && gfc_sym_get_dummy_args (sym
) == NULL
;
2947 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2950 inquiry_argument
= false;
2954 inquiry_argument
= false;
2956 /* Resume assumed_size checking. */
2957 need_full_assumed_size
--;
2959 /* If the procedure is external, check for usage. */
2960 if (sym
&& is_external_proc (sym
))
2961 resolve_global_procedure (sym
, &expr
->where
,
2962 &expr
->value
.function
.actual
, 0);
2964 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2966 && sym
->ts
.u
.cl
->length
== NULL
2968 && !sym
->ts
.deferred
2969 && expr
->value
.function
.esym
== NULL
2970 && !sym
->attr
.contained
)
2972 /* Internal procedures are taken care of in resolve_contained_fntype. */
2973 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2974 "be used at %L since it is not a dummy argument",
2975 sym
->name
, &expr
->where
);
2979 /* See if function is already resolved. */
2981 if (expr
->value
.function
.name
!= NULL
2982 || expr
->value
.function
.isym
!= NULL
)
2984 if (expr
->ts
.type
== BT_UNKNOWN
)
2990 /* Apply the rules of section 14.1.2. */
2992 switch (procedure_kind (sym
))
2995 t
= resolve_generic_f (expr
);
2998 case PTYPE_SPECIFIC
:
2999 t
= resolve_specific_f (expr
);
3003 t
= resolve_unknown_f (expr
);
3007 gfc_internal_error ("resolve_function(): bad function type");
3011 /* If the expression is still a function (it might have simplified),
3012 then we check to see if we are calling an elemental function. */
3014 if (expr
->expr_type
!= EXPR_FUNCTION
)
3017 temp
= need_full_assumed_size
;
3018 need_full_assumed_size
= 0;
3020 if (!resolve_elemental_actual (expr
, NULL
))
3023 if (omp_workshare_flag
3024 && expr
->value
.function
.esym
3025 && ! gfc_elemental (expr
->value
.function
.esym
))
3027 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3028 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3033 #define GENERIC_ID expr->value.function.isym->id
3034 else if (expr
->value
.function
.actual
!= NULL
3035 && expr
->value
.function
.isym
!= NULL
3036 && GENERIC_ID
!= GFC_ISYM_LBOUND
3037 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3038 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3039 && GENERIC_ID
!= GFC_ISYM_LEN
3040 && GENERIC_ID
!= GFC_ISYM_LOC
3041 && GENERIC_ID
!= GFC_ISYM_C_LOC
3042 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3044 /* Array intrinsics must also have the last upper bound of an
3045 assumed size array argument. UBOUND and SIZE have to be
3046 excluded from the check if the second argument is anything
3049 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3051 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3052 && arg
== expr
->value
.function
.actual
3053 && arg
->next
!= NULL
&& arg
->next
->expr
)
3055 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3058 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3061 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3066 if (arg
->expr
!= NULL
3067 && arg
->expr
->rank
> 0
3068 && resolve_assumed_size_actual (arg
->expr
))
3074 need_full_assumed_size
= temp
;
3076 if (!check_pure_function(expr
))
3079 /* Functions without the RECURSIVE attribution are not allowed to
3080 * call themselves. */
3081 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3084 esym
= expr
->value
.function
.esym
;
3086 if (is_illegal_recursion (esym
, gfc_current_ns
))
3088 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3089 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3090 " function %qs is not RECURSIVE",
3091 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3093 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3094 " is not RECURSIVE", esym
->name
, &expr
->where
);
3100 /* Character lengths of use associated functions may contains references to
3101 symbols not referenced from the current program unit otherwise. Make sure
3102 those symbols are marked as referenced. */
3104 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3105 && expr
->value
.function
.esym
->attr
.use_assoc
)
3107 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3110 /* Make sure that the expression has a typespec that works. */
3111 if (expr
->ts
.type
== BT_UNKNOWN
)
3113 if (expr
->symtree
->n
.sym
->result
3114 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3115 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3116 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3119 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3121 if (expr
->value
.function
.esym
)
3122 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3124 update_current_proc_array_outer_dependency (sym
);
3127 /* typebound procedure: Assume the worst. */
3128 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3134 /************* Subroutine resolution *************/
3137 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3144 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3148 else if (gfc_do_concurrent_flag
)
3150 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3154 else if (gfc_pure (NULL
))
3156 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3160 gfc_unset_implicit_pure (NULL
);
3166 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3170 if (sym
->attr
.generic
)
3172 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3175 c
->resolved_sym
= s
;
3176 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3181 /* TODO: Need to search for elemental references in generic interface. */
3184 if (sym
->attr
.intrinsic
)
3185 return gfc_intrinsic_sub_interface (c
, 0);
3192 resolve_generic_s (gfc_code
*c
)
3197 sym
= c
->symtree
->n
.sym
;
3201 m
= resolve_generic_s0 (c
, sym
);
3204 else if (m
== MATCH_ERROR
)
3208 if (sym
->ns
->parent
== NULL
)
3210 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3214 if (!generic_sym (sym
))
3218 /* Last ditch attempt. See if the reference is to an intrinsic
3219 that possesses a matching interface. 14.1.2.4 */
3220 sym
= c
->symtree
->n
.sym
;
3222 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3224 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3225 sym
->name
, &c
->loc
);
3229 m
= gfc_intrinsic_sub_interface (c
, 0);
3233 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3234 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3240 /* Resolve a subroutine call known to be specific. */
3243 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3247 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3249 if (sym
->attr
.dummy
)
3251 sym
->attr
.proc
= PROC_DUMMY
;
3255 sym
->attr
.proc
= PROC_EXTERNAL
;
3259 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3262 if (sym
->attr
.intrinsic
)
3264 m
= gfc_intrinsic_sub_interface (c
, 1);
3268 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3269 "with an intrinsic", sym
->name
, &c
->loc
);
3277 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3279 c
->resolved_sym
= sym
;
3280 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3288 resolve_specific_s (gfc_code
*c
)
3293 sym
= c
->symtree
->n
.sym
;
3297 m
= resolve_specific_s0 (c
, sym
);
3300 if (m
== MATCH_ERROR
)
3303 if (sym
->ns
->parent
== NULL
)
3306 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3312 sym
= c
->symtree
->n
.sym
;
3313 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3314 sym
->name
, &c
->loc
);
3320 /* Resolve a subroutine call not known to be generic nor specific. */
3323 resolve_unknown_s (gfc_code
*c
)
3327 sym
= c
->symtree
->n
.sym
;
3329 if (sym
->attr
.dummy
)
3331 sym
->attr
.proc
= PROC_DUMMY
;
3335 /* See if we have an intrinsic function reference. */
3337 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3339 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3344 /* The reference is to an external name. */
3347 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3349 c
->resolved_sym
= sym
;
3351 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3355 /* Resolve a subroutine call. Although it was tempting to use the same code
3356 for functions, subroutines and functions are stored differently and this
3357 makes things awkward. */
3360 resolve_call (gfc_code
*c
)
3363 procedure_type ptype
= PROC_INTRINSIC
;
3364 gfc_symbol
*csym
, *sym
;
3365 bool no_formal_args
;
3367 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3369 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3371 gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
3372 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3376 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3379 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3380 sym
= st
? st
->n
.sym
: NULL
;
3381 if (sym
&& csym
!= sym
3382 && sym
->ns
== gfc_current_ns
3383 && sym
->attr
.flavor
== FL_PROCEDURE
3384 && sym
->attr
.contained
)
3387 if (csym
->attr
.generic
)
3388 c
->symtree
->n
.sym
= sym
;
3391 csym
= c
->symtree
->n
.sym
;
3395 /* If this ia a deferred TBP, c->expr1 will be set. */
3396 if (!c
->expr1
&& csym
)
3398 if (csym
->attr
.abstract
)
3400 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3401 csym
->name
, &c
->loc
);
3405 /* Subroutines without the RECURSIVE attribution are not allowed to
3407 if (is_illegal_recursion (csym
, gfc_current_ns
))
3409 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3410 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3411 "as subroutine %qs is not RECURSIVE",
3412 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3414 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3415 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3421 /* Switch off assumed size checking and do this again for certain kinds
3422 of procedure, once the procedure itself is resolved. */
3423 need_full_assumed_size
++;
3426 ptype
= csym
->attr
.proc
;
3428 no_formal_args
= csym
&& is_external_proc (csym
)
3429 && gfc_sym_get_dummy_args (csym
) == NULL
;
3430 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3433 /* Resume assumed_size checking. */
3434 need_full_assumed_size
--;
3436 /* If external, check for usage. */
3437 if (csym
&& is_external_proc (csym
))
3438 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3441 if (c
->resolved_sym
== NULL
)
3443 c
->resolved_isym
= NULL
;
3444 switch (procedure_kind (csym
))
3447 t
= resolve_generic_s (c
);
3450 case PTYPE_SPECIFIC
:
3451 t
= resolve_specific_s (c
);
3455 t
= resolve_unknown_s (c
);
3459 gfc_internal_error ("resolve_subroutine(): bad function type");
3463 /* Some checks of elemental subroutine actual arguments. */
3464 if (!resolve_elemental_actual (NULL
, c
))
3468 update_current_proc_array_outer_dependency (csym
);
3470 /* Typebound procedure: Assume the worst. */
3471 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3477 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3478 op1->shape and op2->shape are non-NULL return true if their shapes
3479 match. If both op1->shape and op2->shape are non-NULL return false
3480 if their shapes do not match. If either op1->shape or op2->shape is
3481 NULL, return true. */
3484 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3491 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3493 for (i
= 0; i
< op1
->rank
; i
++)
3495 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3497 gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
3498 &op1
->where
, &op2
->where
);
3509 /* Resolve an operator expression node. This can involve replacing the
3510 operation with a user defined function call. */
3513 resolve_operator (gfc_expr
*e
)
3515 gfc_expr
*op1
, *op2
;
3517 bool dual_locus_error
;
3520 /* Resolve all subnodes-- give them types. */
3522 switch (e
->value
.op
.op
)
3525 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3528 /* Fall through... */
3531 case INTRINSIC_UPLUS
:
3532 case INTRINSIC_UMINUS
:
3533 case INTRINSIC_PARENTHESES
:
3534 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3539 /* Typecheck the new node. */
3541 op1
= e
->value
.op
.op1
;
3542 op2
= e
->value
.op
.op2
;
3543 dual_locus_error
= false;
3545 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3546 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3548 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3552 switch (e
->value
.op
.op
)
3554 case INTRINSIC_UPLUS
:
3555 case INTRINSIC_UMINUS
:
3556 if (op1
->ts
.type
== BT_INTEGER
3557 || op1
->ts
.type
== BT_REAL
3558 || op1
->ts
.type
== BT_COMPLEX
)
3564 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3565 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3568 case INTRINSIC_PLUS
:
3569 case INTRINSIC_MINUS
:
3570 case INTRINSIC_TIMES
:
3571 case INTRINSIC_DIVIDE
:
3572 case INTRINSIC_POWER
:
3573 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3575 gfc_type_convert_binary (e
, 1);
3580 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3581 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3582 gfc_typename (&op2
->ts
));
3585 case INTRINSIC_CONCAT
:
3586 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3587 && op1
->ts
.kind
== op2
->ts
.kind
)
3589 e
->ts
.type
= BT_CHARACTER
;
3590 e
->ts
.kind
= op1
->ts
.kind
;
3595 _("Operands of string concatenation operator at %%L are %s/%s"),
3596 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3602 case INTRINSIC_NEQV
:
3603 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3605 e
->ts
.type
= BT_LOGICAL
;
3606 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3607 if (op1
->ts
.kind
< e
->ts
.kind
)
3608 gfc_convert_type (op1
, &e
->ts
, 2);
3609 else if (op2
->ts
.kind
< e
->ts
.kind
)
3610 gfc_convert_type (op2
, &e
->ts
, 2);
3614 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3615 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3616 gfc_typename (&op2
->ts
));
3621 if (op1
->ts
.type
== BT_LOGICAL
)
3623 e
->ts
.type
= BT_LOGICAL
;
3624 e
->ts
.kind
= op1
->ts
.kind
;
3628 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3629 gfc_typename (&op1
->ts
));
3633 case INTRINSIC_GT_OS
:
3635 case INTRINSIC_GE_OS
:
3637 case INTRINSIC_LT_OS
:
3639 case INTRINSIC_LE_OS
:
3640 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3642 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3646 /* Fall through... */
3649 case INTRINSIC_EQ_OS
:
3651 case INTRINSIC_NE_OS
:
3652 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3653 && op1
->ts
.kind
== op2
->ts
.kind
)
3655 e
->ts
.type
= BT_LOGICAL
;
3656 e
->ts
.kind
= gfc_default_logical_kind
;
3660 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3662 gfc_type_convert_binary (e
, 1);
3664 e
->ts
.type
= BT_LOGICAL
;
3665 e
->ts
.kind
= gfc_default_logical_kind
;
3667 if (warn_compare_reals
)
3669 gfc_intrinsic_op op
= e
->value
.op
.op
;
3671 /* Type conversion has made sure that the types of op1 and op2
3672 agree, so it is only necessary to check the first one. */
3673 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3674 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3675 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3679 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3680 msg
= "Equality comparison for %s at %L";
3682 msg
= "Inequality comparison for %s at %L";
3684 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3691 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3693 _("Logicals at %%L must be compared with %s instead of %s"),
3694 (e
->value
.op
.op
== INTRINSIC_EQ
3695 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3696 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3699 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3700 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3701 gfc_typename (&op2
->ts
));
3705 case INTRINSIC_USER
:
3706 if (e
->value
.op
.uop
->op
== NULL
)
3707 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3708 else if (op2
== NULL
)
3709 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3710 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3713 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3714 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3715 gfc_typename (&op2
->ts
));
3716 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3721 case INTRINSIC_PARENTHESES
:
3723 if (e
->ts
.type
== BT_CHARACTER
)
3724 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3728 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3731 /* Deal with arrayness of an operand through an operator. */
3735 switch (e
->value
.op
.op
)
3737 case INTRINSIC_PLUS
:
3738 case INTRINSIC_MINUS
:
3739 case INTRINSIC_TIMES
:
3740 case INTRINSIC_DIVIDE
:
3741 case INTRINSIC_POWER
:
3742 case INTRINSIC_CONCAT
:
3746 case INTRINSIC_NEQV
:
3748 case INTRINSIC_EQ_OS
:
3750 case INTRINSIC_NE_OS
:
3752 case INTRINSIC_GT_OS
:
3754 case INTRINSIC_GE_OS
:
3756 case INTRINSIC_LT_OS
:
3758 case INTRINSIC_LE_OS
:
3760 if (op1
->rank
== 0 && op2
->rank
== 0)
3763 if (op1
->rank
== 0 && op2
->rank
!= 0)
3765 e
->rank
= op2
->rank
;
3767 if (e
->shape
== NULL
)
3768 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3771 if (op1
->rank
!= 0 && op2
->rank
== 0)
3773 e
->rank
= op1
->rank
;
3775 if (e
->shape
== NULL
)
3776 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3779 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3781 if (op1
->rank
== op2
->rank
)
3783 e
->rank
= op1
->rank
;
3784 if (e
->shape
== NULL
)
3786 t
= compare_shapes (op1
, op2
);
3790 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3795 /* Allow higher level expressions to work. */
3798 /* Try user-defined operators, and otherwise throw an error. */
3799 dual_locus_error
= true;
3801 _("Inconsistent ranks for operator at %%L and %%L"));
3808 case INTRINSIC_PARENTHESES
:
3810 case INTRINSIC_UPLUS
:
3811 case INTRINSIC_UMINUS
:
3812 /* Simply copy arrayness attribute */
3813 e
->rank
= op1
->rank
;
3815 if (e
->shape
== NULL
)
3816 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3824 /* Attempt to simplify the expression. */
3827 t
= gfc_simplify_expr (e
, 0);
3828 /* Some calls do not succeed in simplification and return false
3829 even though there is no error; e.g. variable references to
3830 PARAMETER arrays. */
3831 if (!gfc_is_constant_expr (e
))
3839 match m
= gfc_extend_expr (e
);
3842 if (m
== MATCH_ERROR
)
3846 if (dual_locus_error
)
3847 gfc_error (msg
, &op1
->where
, &op2
->where
);
3849 gfc_error (msg
, &e
->where
);
3855 /************** Array resolution subroutines **************/
3858 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3861 /* Compare two integer expressions. */
3863 static compare_result
3864 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3868 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3869 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3872 /* If either of the types isn't INTEGER, we must have
3873 raised an error earlier. */
3875 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3878 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3888 /* Compare an integer expression with an integer. */
3890 static compare_result
3891 compare_bound_int (gfc_expr
*a
, int b
)
3895 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3898 if (a
->ts
.type
!= BT_INTEGER
)
3899 gfc_internal_error ("compare_bound_int(): Bad expression");
3901 i
= mpz_cmp_si (a
->value
.integer
, b
);
3911 /* Compare an integer expression with a mpz_t. */
3913 static compare_result
3914 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3918 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3921 if (a
->ts
.type
!= BT_INTEGER
)
3922 gfc_internal_error ("compare_bound_int(): Bad expression");
3924 i
= mpz_cmp (a
->value
.integer
, b
);
3934 /* Compute the last value of a sequence given by a triplet.
3935 Return 0 if it wasn't able to compute the last value, or if the
3936 sequence if empty, and 1 otherwise. */
3939 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3940 gfc_expr
*stride
, mpz_t last
)
3944 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3945 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3946 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3949 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3950 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3953 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3955 if (compare_bound (start
, end
) == CMP_GT
)
3957 mpz_set (last
, end
->value
.integer
);
3961 if (compare_bound_int (stride
, 0) == CMP_GT
)
3963 /* Stride is positive */
3964 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3969 /* Stride is negative */
3970 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3975 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3976 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3977 mpz_sub (last
, end
->value
.integer
, rem
);
3984 /* Compare a single dimension of an array reference to the array
3988 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3992 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3994 gcc_assert (ar
->stride
[i
] == NULL
);
3995 /* This implies [*] as [*:] and [*:3] are not possible. */
3996 if (ar
->start
[i
] == NULL
)
3998 gcc_assert (ar
->end
[i
] == NULL
);
4003 /* Given start, end and stride values, calculate the minimum and
4004 maximum referenced indexes. */
4006 switch (ar
->dimen_type
[i
])
4009 case DIMEN_THIS_IMAGE
:
4014 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4017 gfc_warning (0, "Array reference at %L is out of bounds "
4018 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4019 mpz_get_si (ar
->start
[i
]->value
.integer
),
4020 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4022 gfc_warning (0, "Array reference at %L is out of bounds "
4023 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4024 mpz_get_si (ar
->start
[i
]->value
.integer
),
4025 mpz_get_si (as
->lower
[i
]->value
.integer
),
4029 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4032 gfc_warning (0, "Array reference at %L is out of bounds "
4033 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4034 mpz_get_si (ar
->start
[i
]->value
.integer
),
4035 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4037 gfc_warning (0, "Array reference at %L is out of bounds "
4038 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4039 mpz_get_si (ar
->start
[i
]->value
.integer
),
4040 mpz_get_si (as
->upper
[i
]->value
.integer
),
4049 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4050 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4052 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4054 /* Check for zero stride, which is not allowed. */
4055 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4057 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4061 /* if start == len || (stride > 0 && start < len)
4062 || (stride < 0 && start > len),
4063 then the array section contains at least one element. In this
4064 case, there is an out-of-bounds access if
4065 (start < lower || start > upper). */
4066 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4067 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4068 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4069 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4070 && comp_start_end
== CMP_GT
))
4072 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4074 gfc_warning (0, "Lower array reference at %L is out of bounds "
4075 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4076 mpz_get_si (AR_START
->value
.integer
),
4077 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4080 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4082 gfc_warning (0, "Lower array reference at %L is out of bounds "
4083 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4084 mpz_get_si (AR_START
->value
.integer
),
4085 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4090 /* If we can compute the highest index of the array section,
4091 then it also has to be between lower and upper. */
4092 mpz_init (last_value
);
4093 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4096 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4098 gfc_warning (0, "Upper array reference at %L is out of bounds "
4099 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4100 mpz_get_si (last_value
),
4101 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4102 mpz_clear (last_value
);
4105 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4107 gfc_warning (0, "Upper array reference at %L is out of bounds "
4108 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4109 mpz_get_si (last_value
),
4110 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4111 mpz_clear (last_value
);
4115 mpz_clear (last_value
);
4123 gfc_internal_error ("check_dimension(): Bad array reference");
4130 /* Compare an array reference with an array specification. */
4133 compare_spec_to_ref (gfc_array_ref
*ar
)
4140 /* TODO: Full array sections are only allowed as actual parameters. */
4141 if (as
->type
== AS_ASSUMED_SIZE
4142 && (/*ar->type == AR_FULL
4143 ||*/ (ar
->type
== AR_SECTION
4144 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4146 gfc_error ("Rightmost upper bound of assumed size array section "
4147 "not specified at %L", &ar
->where
);
4151 if (ar
->type
== AR_FULL
)
4154 if (as
->rank
!= ar
->dimen
)
4156 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4157 &ar
->where
, ar
->dimen
, as
->rank
);
4161 /* ar->codimen == 0 is a local array. */
4162 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4164 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4165 &ar
->where
, ar
->codimen
, as
->corank
);
4169 for (i
= 0; i
< as
->rank
; i
++)
4170 if (!check_dimension (i
, ar
, as
))
4173 /* Local access has no coarray spec. */
4174 if (ar
->codimen
!= 0)
4175 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4177 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4178 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4180 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4181 i
+ 1 - as
->rank
, &ar
->where
);
4184 if (!check_dimension (i
, ar
, as
))
4192 /* Resolve one part of an array index. */
4195 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4196 int force_index_integer_kind
)
4203 if (!gfc_resolve_expr (index
))
4206 if (check_scalar
&& index
->rank
!= 0)
4208 gfc_error ("Array index at %L must be scalar", &index
->where
);
4212 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4214 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4215 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4219 if (index
->ts
.type
== BT_REAL
)
4220 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4224 if ((index
->ts
.kind
!= gfc_index_integer_kind
4225 && force_index_integer_kind
)
4226 || index
->ts
.type
!= BT_INTEGER
)
4229 ts
.type
= BT_INTEGER
;
4230 ts
.kind
= gfc_index_integer_kind
;
4232 gfc_convert_type_warn (index
, &ts
, 2, 0);
4238 /* Resolve one part of an array index. */
4241 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4243 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4246 /* Resolve a dim argument to an intrinsic function. */
4249 gfc_resolve_dim_arg (gfc_expr
*dim
)
4254 if (!gfc_resolve_expr (dim
))
4259 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4264 if (dim
->ts
.type
!= BT_INTEGER
)
4266 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4270 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4275 ts
.type
= BT_INTEGER
;
4276 ts
.kind
= gfc_index_integer_kind
;
4278 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4284 /* Given an expression that contains array references, update those array
4285 references to point to the right array specifications. While this is
4286 filled in during matching, this information is difficult to save and load
4287 in a module, so we take care of it here.
4289 The idea here is that the original array reference comes from the
4290 base symbol. We traverse the list of reference structures, setting
4291 the stored reference to references. Component references can
4292 provide an additional array specification. */
4295 find_array_spec (gfc_expr
*e
)
4301 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4302 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4304 as
= e
->symtree
->n
.sym
->as
;
4306 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4311 gfc_internal_error ("find_array_spec(): Missing spec");
4318 c
= ref
->u
.c
.component
;
4319 if (c
->attr
.dimension
)
4322 gfc_internal_error ("find_array_spec(): unused as(1)");
4333 gfc_internal_error ("find_array_spec(): unused as(2)");
4337 /* Resolve an array reference. */
4340 resolve_array_ref (gfc_array_ref
*ar
)
4342 int i
, check_scalar
;
4345 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4347 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4349 /* Do not force gfc_index_integer_kind for the start. We can
4350 do fine with any integer kind. This avoids temporary arrays
4351 created for indexing with a vector. */
4352 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4354 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4356 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4361 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4365 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4369 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4370 if (e
->expr_type
== EXPR_VARIABLE
4371 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4372 ar
->start
[i
] = gfc_get_parentheses (e
);
4376 gfc_error ("Array index at %L is an array of rank %d",
4377 &ar
->c_where
[i
], e
->rank
);
4381 /* Fill in the upper bound, which may be lower than the
4382 specified one for something like a(2:10:5), which is
4383 identical to a(2:7:5). Only relevant for strides not equal
4384 to one. Don't try a division by zero. */
4385 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4386 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4387 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4388 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4392 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4394 if (ar
->end
[i
] == NULL
)
4397 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4399 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4401 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4402 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4404 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4415 if (ar
->type
== AR_FULL
)
4417 if (ar
->as
->rank
== 0)
4418 ar
->type
= AR_ELEMENT
;
4420 /* Make sure array is the same as array(:,:), this way
4421 we don't need to special case all the time. */
4422 ar
->dimen
= ar
->as
->rank
;
4423 for (i
= 0; i
< ar
->dimen
; i
++)
4425 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4427 gcc_assert (ar
->start
[i
] == NULL
);
4428 gcc_assert (ar
->end
[i
] == NULL
);
4429 gcc_assert (ar
->stride
[i
] == NULL
);
4433 /* If the reference type is unknown, figure out what kind it is. */
4435 if (ar
->type
== AR_UNKNOWN
)
4437 ar
->type
= AR_ELEMENT
;
4438 for (i
= 0; i
< ar
->dimen
; i
++)
4439 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4440 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4442 ar
->type
= AR_SECTION
;
4447 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4450 if (ar
->as
->corank
&& ar
->codimen
== 0)
4453 ar
->codimen
= ar
->as
->corank
;
4454 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4455 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4463 resolve_substring (gfc_ref
*ref
)
4465 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4467 if (ref
->u
.ss
.start
!= NULL
)
4469 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4472 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4474 gfc_error ("Substring start index at %L must be of type INTEGER",
4475 &ref
->u
.ss
.start
->where
);
4479 if (ref
->u
.ss
.start
->rank
!= 0)
4481 gfc_error ("Substring start index at %L must be scalar",
4482 &ref
->u
.ss
.start
->where
);
4486 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4487 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4488 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4490 gfc_error ("Substring start index at %L is less than one",
4491 &ref
->u
.ss
.start
->where
);
4496 if (ref
->u
.ss
.end
!= NULL
)
4498 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4501 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4503 gfc_error ("Substring end index at %L must be of type INTEGER",
4504 &ref
->u
.ss
.end
->where
);
4508 if (ref
->u
.ss
.end
->rank
!= 0)
4510 gfc_error ("Substring end index at %L must be scalar",
4511 &ref
->u
.ss
.end
->where
);
4515 if (ref
->u
.ss
.length
!= NULL
4516 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4517 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4518 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4520 gfc_error ("Substring end index at %L exceeds the string length",
4521 &ref
->u
.ss
.start
->where
);
4525 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4526 gfc_integer_kinds
[k
].huge
) == CMP_GT
4527 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4528 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4530 gfc_error ("Substring end index at %L is too large",
4531 &ref
->u
.ss
.end
->where
);
4540 /* This function supplies missing substring charlens. */
4543 gfc_resolve_substring_charlen (gfc_expr
*e
)
4546 gfc_expr
*start
, *end
;
4548 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4549 if (char_ref
->type
== REF_SUBSTRING
)
4555 gcc_assert (char_ref
->next
== NULL
);
4559 if (e
->ts
.u
.cl
->length
)
4560 gfc_free_expr (e
->ts
.u
.cl
->length
);
4561 else if (e
->expr_type
== EXPR_VARIABLE
4562 && e
->symtree
->n
.sym
->attr
.dummy
)
4566 e
->ts
.type
= BT_CHARACTER
;
4567 e
->ts
.kind
= gfc_default_character_kind
;
4570 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4572 if (char_ref
->u
.ss
.start
)
4573 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4575 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4577 if (char_ref
->u
.ss
.end
)
4578 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4579 else if (e
->expr_type
== EXPR_VARIABLE
)
4580 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4586 gfc_free_expr (start
);
4587 gfc_free_expr (end
);
4591 /* Length = (end - start +1). */
4592 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4593 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4594 gfc_get_int_expr (gfc_default_integer_kind
,
4597 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4598 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4600 /* Make sure that the length is simplified. */
4601 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4602 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4606 /* Resolve subtype references. */
4609 resolve_ref (gfc_expr
*expr
)
4611 int current_part_dimension
, n_components
, seen_part_dimension
;
4614 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4615 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4617 find_array_spec (expr
);
4621 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4625 if (!resolve_array_ref (&ref
->u
.ar
))
4633 if (!resolve_substring (ref
))
4638 /* Check constraints on part references. */
4640 current_part_dimension
= 0;
4641 seen_part_dimension
= 0;
4644 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4649 switch (ref
->u
.ar
.type
)
4652 /* Coarray scalar. */
4653 if (ref
->u
.ar
.as
->rank
== 0)
4655 current_part_dimension
= 0;
4660 current_part_dimension
= 1;
4664 current_part_dimension
= 0;
4668 gfc_internal_error ("resolve_ref(): Bad array reference");
4674 if (current_part_dimension
|| seen_part_dimension
)
4677 if (ref
->u
.c
.component
->attr
.pointer
4678 || ref
->u
.c
.component
->attr
.proc_pointer
4679 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4680 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4682 gfc_error ("Component to the right of a part reference "
4683 "with nonzero rank must not have the POINTER "
4684 "attribute at %L", &expr
->where
);
4687 else if (ref
->u
.c
.component
->attr
.allocatable
4688 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4689 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4692 gfc_error ("Component to the right of a part reference "
4693 "with nonzero rank must not have the ALLOCATABLE "
4694 "attribute at %L", &expr
->where
);
4706 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4707 || ref
->next
== NULL
)
4708 && current_part_dimension
4709 && seen_part_dimension
)
4711 gfc_error ("Two or more part references with nonzero rank must "
4712 "not be specified at %L", &expr
->where
);
4716 if (ref
->type
== REF_COMPONENT
)
4718 if (current_part_dimension
)
4719 seen_part_dimension
= 1;
4721 /* reset to make sure */
4722 current_part_dimension
= 0;
4730 /* Given an expression, determine its shape. This is easier than it sounds.
4731 Leaves the shape array NULL if it is not possible to determine the shape. */
4734 expression_shape (gfc_expr
*e
)
4736 mpz_t array
[GFC_MAX_DIMENSIONS
];
4739 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4742 for (i
= 0; i
< e
->rank
; i
++)
4743 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4746 e
->shape
= gfc_get_shape (e
->rank
);
4748 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4753 for (i
--; i
>= 0; i
--)
4754 mpz_clear (array
[i
]);
4758 /* Given a variable expression node, compute the rank of the expression by
4759 examining the base symbol and any reference structures it may have. */
4762 expression_rank (gfc_expr
*e
)
4767 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4768 could lead to serious confusion... */
4769 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4773 if (e
->expr_type
== EXPR_ARRAY
)
4775 /* Constructors can have a rank different from one via RESHAPE(). */
4777 if (e
->symtree
== NULL
)
4783 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4784 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4790 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4792 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4793 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4794 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4796 if (ref
->type
!= REF_ARRAY
)
4799 if (ref
->u
.ar
.type
== AR_FULL
)
4801 rank
= ref
->u
.ar
.as
->rank
;
4805 if (ref
->u
.ar
.type
== AR_SECTION
)
4807 /* Figure out the rank of the section. */
4809 gfc_internal_error ("expression_rank(): Two array specs");
4811 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4812 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4813 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4823 expression_shape (e
);
4828 add_caf_get_intrinsic (gfc_expr
*e
)
4830 gfc_expr
*wrapper
, *tmp_expr
;
4834 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4835 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4840 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4841 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4844 tmp_expr
= XCNEW (gfc_expr
);
4846 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4847 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4848 wrapper
->ts
= e
->ts
;
4849 wrapper
->rank
= e
->rank
;
4851 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4858 remove_caf_get_intrinsic (gfc_expr
*e
)
4860 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4861 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4862 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4863 e
->value
.function
.actual
->expr
= NULL
;
4864 gfc_free_actual_arglist (e
->value
.function
.actual
);
4865 gfc_free_shape (&e
->shape
, e
->rank
);
4871 /* Resolve a variable expression. */
4874 resolve_variable (gfc_expr
*e
)
4881 if (e
->symtree
== NULL
)
4883 sym
= e
->symtree
->n
.sym
;
4885 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4886 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4887 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4889 if (!actual_arg
|| inquiry_argument
)
4891 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4892 "be used as actual argument", sym
->name
, &e
->where
);
4896 /* TS 29113, 407b. */
4897 else if (e
->ts
.type
== BT_ASSUMED
)
4901 gfc_error ("Assumed-type variable %s at %L may only be used "
4902 "as actual argument", sym
->name
, &e
->where
);
4905 else if (inquiry_argument
&& !first_actual_arg
)
4907 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4908 for all inquiry functions in resolve_function; the reason is
4909 that the function-name resolution happens too late in that
4911 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4912 "an inquiry function shall be the first argument",
4913 sym
->name
, &e
->where
);
4917 /* TS 29113, C535b. */
4918 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4919 && CLASS_DATA (sym
)->as
4920 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4921 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4922 && sym
->as
->type
== AS_ASSUMED_RANK
))
4926 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4927 "actual argument", sym
->name
, &e
->where
);
4930 else if (inquiry_argument
&& !first_actual_arg
)
4932 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4933 for all inquiry functions in resolve_function; the reason is
4934 that the function-name resolution happens too late in that
4936 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4937 "to an inquiry function shall be the first argument",
4938 sym
->name
, &e
->where
);
4943 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4944 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4945 && e
->ref
->next
== NULL
))
4947 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4948 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4951 /* TS 29113, 407b. */
4952 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4953 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4954 && e
->ref
->next
== NULL
))
4956 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4957 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4961 /* TS 29113, C535b. */
4962 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4963 && CLASS_DATA (sym
)->as
4964 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4965 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4966 && sym
->as
->type
== AS_ASSUMED_RANK
))
4968 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4969 && e
->ref
->next
== NULL
))
4971 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4972 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4977 /* If this is an associate-name, it may be parsed with an array reference
4978 in error even though the target is scalar. Fail directly in this case.
4979 TODO Understand why class scalar expressions must be excluded. */
4980 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4982 if (sym
->ts
.type
== BT_CLASS
)
4983 gfc_fix_class_refs (e
);
4984 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4988 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4989 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4991 /* On the other hand, the parser may not have known this is an array;
4992 in this case, we have to add a FULL reference. */
4993 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4995 e
->ref
= gfc_get_ref ();
4996 e
->ref
->type
= REF_ARRAY
;
4997 e
->ref
->u
.ar
.type
= AR_FULL
;
4998 e
->ref
->u
.ar
.dimen
= 0;
5001 if (e
->ref
&& !resolve_ref (e
))
5004 if (sym
->attr
.flavor
== FL_PROCEDURE
5005 && (!sym
->attr
.function
5006 || (sym
->attr
.function
&& sym
->result
5007 && sym
->result
->attr
.proc_pointer
5008 && !sym
->result
->attr
.function
)))
5010 e
->ts
.type
= BT_PROCEDURE
;
5011 goto resolve_procedure
;
5014 if (sym
->ts
.type
!= BT_UNKNOWN
)
5015 gfc_variable_attr (e
, &e
->ts
);
5018 /* Must be a simple variable reference. */
5019 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5024 if (check_assumed_size_reference (sym
, e
))
5027 /* Deal with forward references to entries during gfc_resolve_code, to
5028 satisfy, at least partially, 12.5.2.5. */
5029 if (gfc_current_ns
->entries
5030 && current_entry_id
== sym
->entry_id
5033 && cs_base
->current
->op
!= EXEC_ENTRY
)
5035 gfc_entry_list
*entry
;
5036 gfc_formal_arglist
*formal
;
5038 bool seen
, saved_specification_expr
;
5040 /* If the symbol is a dummy... */
5041 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5043 entry
= gfc_current_ns
->entries
;
5046 /* ...test if the symbol is a parameter of previous entries. */
5047 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5048 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5050 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5057 /* If it has not been seen as a dummy, this is an error. */
5060 if (specification_expr
)
5061 gfc_error ("Variable %qs, used in a specification expression"
5062 ", is referenced at %L before the ENTRY statement "
5063 "in which it is a parameter",
5064 sym
->name
, &cs_base
->current
->loc
);
5066 gfc_error ("Variable %qs is used at %L before the ENTRY "
5067 "statement in which it is a parameter",
5068 sym
->name
, &cs_base
->current
->loc
);
5073 /* Now do the same check on the specification expressions. */
5074 saved_specification_expr
= specification_expr
;
5075 specification_expr
= true;
5076 if (sym
->ts
.type
== BT_CHARACTER
5077 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5081 for (n
= 0; n
< sym
->as
->rank
; n
++)
5083 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5085 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5088 specification_expr
= saved_specification_expr
;
5091 /* Update the symbol's entry level. */
5092 sym
->entry_id
= current_entry_id
+ 1;
5095 /* If a symbol has been host_associated mark it. This is used latter,
5096 to identify if aliasing is possible via host association. */
5097 if (sym
->attr
.flavor
== FL_VARIABLE
5098 && gfc_current_ns
->parent
5099 && (gfc_current_ns
->parent
== sym
->ns
5100 || (gfc_current_ns
->parent
->parent
5101 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5102 sym
->attr
.host_assoc
= 1;
5104 if (gfc_current_ns
->proc_name
5105 && sym
->attr
.dimension
5106 && (sym
->ns
!= gfc_current_ns
5107 || sym
->attr
.use_assoc
5108 || sym
->attr
.in_common
))
5109 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5112 if (t
&& !resolve_procedure_expression (e
))
5115 /* F2008, C617 and C1229. */
5116 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5117 && gfc_is_coindexed (e
))
5119 gfc_ref
*ref
, *ref2
= NULL
;
5121 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5123 if (ref
->type
== REF_COMPONENT
)
5125 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5129 for ( ; ref
; ref
= ref
->next
)
5130 if (ref
->type
== REF_COMPONENT
)
5133 /* Expression itself is not coindexed object. */
5134 if (ref
&& e
->ts
.type
== BT_CLASS
)
5136 gfc_error ("Polymorphic subobject of coindexed object at %L",
5141 /* Expression itself is coindexed object. */
5145 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5146 for ( ; c
; c
= c
->next
)
5147 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5149 gfc_error ("Coindexed object with polymorphic allocatable "
5150 "subcomponent at %L", &e
->where
);
5158 expression_rank (e
);
5160 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5161 add_caf_get_intrinsic (e
);
5167 /* Checks to see that the correct symbol has been host associated.
5168 The only situation where this arises is that in which a twice
5169 contained function is parsed after the host association is made.
5170 Therefore, on detecting this, change the symbol in the expression
5171 and convert the array reference into an actual arglist if the old
5172 symbol is a variable. */
5174 check_host_association (gfc_expr
*e
)
5176 gfc_symbol
*sym
, *old_sym
;
5180 gfc_actual_arglist
*arg
, *tail
= NULL
;
5181 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5183 /* If the expression is the result of substitution in
5184 interface.c(gfc_extend_expr) because there is no way in
5185 which the host association can be wrong. */
5186 if (e
->symtree
== NULL
5187 || e
->symtree
->n
.sym
== NULL
5188 || e
->user_operator
)
5191 old_sym
= e
->symtree
->n
.sym
;
5193 if (gfc_current_ns
->parent
5194 && old_sym
->ns
!= gfc_current_ns
)
5196 /* Use the 'USE' name so that renamed module symbols are
5197 correctly handled. */
5198 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5200 if (sym
&& old_sym
!= sym
5201 && sym
->ts
.type
== old_sym
->ts
.type
5202 && sym
->attr
.flavor
== FL_PROCEDURE
5203 && sym
->attr
.contained
)
5205 /* Clear the shape, since it might not be valid. */
5206 gfc_free_shape (&e
->shape
, e
->rank
);
5208 /* Give the expression the right symtree! */
5209 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5210 gcc_assert (st
!= NULL
);
5212 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5213 || e
->expr_type
== EXPR_FUNCTION
)
5215 /* Original was function so point to the new symbol, since
5216 the actual argument list is already attached to the
5218 e
->value
.function
.esym
= NULL
;
5223 /* Original was variable so convert array references into
5224 an actual arglist. This does not need any checking now
5225 since resolve_function will take care of it. */
5226 e
->value
.function
.actual
= NULL
;
5227 e
->expr_type
= EXPR_FUNCTION
;
5230 /* Ambiguity will not arise if the array reference is not
5231 the last reference. */
5232 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5233 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5236 gcc_assert (ref
->type
== REF_ARRAY
);
5238 /* Grab the start expressions from the array ref and
5239 copy them into actual arguments. */
5240 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5242 arg
= gfc_get_actual_arglist ();
5243 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5244 if (e
->value
.function
.actual
== NULL
)
5245 tail
= e
->value
.function
.actual
= arg
;
5253 /* Dump the reference list and set the rank. */
5254 gfc_free_ref_list (e
->ref
);
5256 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5259 gfc_resolve_expr (e
);
5263 /* This might have changed! */
5264 return e
->expr_type
== EXPR_FUNCTION
;
5269 gfc_resolve_character_operator (gfc_expr
*e
)
5271 gfc_expr
*op1
= e
->value
.op
.op1
;
5272 gfc_expr
*op2
= e
->value
.op
.op2
;
5273 gfc_expr
*e1
= NULL
;
5274 gfc_expr
*e2
= NULL
;
5276 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5278 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5279 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5280 else if (op1
->expr_type
== EXPR_CONSTANT
)
5281 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5282 op1
->value
.character
.length
);
5284 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5285 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5286 else if (op2
->expr_type
== EXPR_CONSTANT
)
5287 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5288 op2
->value
.character
.length
);
5290 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5300 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5301 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5302 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5303 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5304 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5310 /* Ensure that an character expression has a charlen and, if possible, a
5311 length expression. */
5314 fixup_charlen (gfc_expr
*e
)
5316 /* The cases fall through so that changes in expression type and the need
5317 for multiple fixes are picked up. In all circumstances, a charlen should
5318 be available for the middle end to hang a backend_decl on. */
5319 switch (e
->expr_type
)
5322 gfc_resolve_character_operator (e
);
5325 if (e
->expr_type
== EXPR_ARRAY
)
5326 gfc_resolve_character_array_constructor (e
);
5328 case EXPR_SUBSTRING
:
5329 if (!e
->ts
.u
.cl
&& e
->ref
)
5330 gfc_resolve_substring_charlen (e
);
5334 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5341 /* Update an actual argument to include the passed-object for type-bound
5342 procedures at the right position. */
5344 static gfc_actual_arglist
*
5345 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5348 gcc_assert (argpos
> 0);
5352 gfc_actual_arglist
* result
;
5354 result
= gfc_get_actual_arglist ();
5358 result
->name
= name
;
5364 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5366 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5371 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5374 extract_compcall_passed_object (gfc_expr
* e
)
5378 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5380 if (e
->value
.compcall
.base_object
)
5381 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5384 po
= gfc_get_expr ();
5385 po
->expr_type
= EXPR_VARIABLE
;
5386 po
->symtree
= e
->symtree
;
5387 po
->ref
= gfc_copy_ref (e
->ref
);
5388 po
->where
= e
->where
;
5391 if (!gfc_resolve_expr (po
))
5398 /* Update the arglist of an EXPR_COMPCALL expression to include the
5402 update_compcall_arglist (gfc_expr
* e
)
5405 gfc_typebound_proc
* tbp
;
5407 tbp
= e
->value
.compcall
.tbp
;
5412 po
= extract_compcall_passed_object (e
);
5416 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5422 gcc_assert (tbp
->pass_arg_num
> 0);
5423 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5431 /* Extract the passed object from a PPC call (a copy of it). */
5434 extract_ppc_passed_object (gfc_expr
*e
)
5439 po
= gfc_get_expr ();
5440 po
->expr_type
= EXPR_VARIABLE
;
5441 po
->symtree
= e
->symtree
;
5442 po
->ref
= gfc_copy_ref (e
->ref
);
5443 po
->where
= e
->where
;
5445 /* Remove PPC reference. */
5447 while ((*ref
)->next
)
5448 ref
= &(*ref
)->next
;
5449 gfc_free_ref_list (*ref
);
5452 if (!gfc_resolve_expr (po
))
5459 /* Update the actual arglist of a procedure pointer component to include the
5463 update_ppc_arglist (gfc_expr
* e
)
5467 gfc_typebound_proc
* tb
;
5469 ppc
= gfc_get_proc_ptr_comp (e
);
5477 else if (tb
->nopass
)
5480 po
= extract_ppc_passed_object (e
);
5487 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5492 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5494 gfc_error ("Base object for procedure-pointer component call at %L is of"
5495 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5499 gcc_assert (tb
->pass_arg_num
> 0);
5500 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5508 /* Check that the object a TBP is called on is valid, i.e. it must not be
5509 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5512 check_typebound_baseobject (gfc_expr
* e
)
5515 bool return_value
= false;
5517 base
= extract_compcall_passed_object (e
);
5521 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5523 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5527 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5529 gfc_error ("Base object for type-bound procedure call at %L is of"
5530 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5534 /* F08:C1230. If the procedure called is NOPASS,
5535 the base object must be scalar. */
5536 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5538 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5539 " be scalar", &e
->where
);
5543 return_value
= true;
5546 gfc_free_expr (base
);
5547 return return_value
;
5551 /* Resolve a call to a type-bound procedure, either function or subroutine,
5552 statically from the data in an EXPR_COMPCALL expression. The adapted
5553 arglist and the target-procedure symtree are returned. */
5556 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5557 gfc_actual_arglist
** actual
)
5559 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5560 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5562 /* Update the actual arglist for PASS. */
5563 if (!update_compcall_arglist (e
))
5566 *actual
= e
->value
.compcall
.actual
;
5567 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5569 gfc_free_ref_list (e
->ref
);
5571 e
->value
.compcall
.actual
= NULL
;
5573 /* If we find a deferred typebound procedure, check for derived types
5574 that an overriding typebound procedure has not been missed. */
5575 if (e
->value
.compcall
.name
5576 && !e
->value
.compcall
.tbp
->non_overridable
5577 && e
->value
.compcall
.base_object
5578 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5581 gfc_symbol
*derived
;
5583 /* Use the derived type of the base_object. */
5584 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5587 /* If necessary, go through the inheritance chain. */
5588 while (!st
&& derived
)
5590 /* Look for the typebound procedure 'name'. */
5591 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5592 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5593 e
->value
.compcall
.name
);
5595 derived
= gfc_get_derived_super_type (derived
);
5598 /* Now find the specific name in the derived type namespace. */
5599 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5600 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5601 derived
->ns
, 1, &st
);
5609 /* Get the ultimate declared type from an expression. In addition,
5610 return the last class/derived type reference and the copy of the
5611 reference list. If check_types is set true, derived types are
5612 identified as well as class references. */
5614 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5615 gfc_expr
*e
, bool check_types
)
5617 gfc_symbol
*declared
;
5624 *new_ref
= gfc_copy_ref (e
->ref
);
5626 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5628 if (ref
->type
!= REF_COMPONENT
)
5631 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5632 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5633 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5635 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5641 if (declared
== NULL
)
5642 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5648 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5649 which of the specific bindings (if any) matches the arglist and transform
5650 the expression into a call of that binding. */
5653 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5655 gfc_typebound_proc
* genproc
;
5656 const char* genname
;
5658 gfc_symbol
*derived
;
5660 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5661 genname
= e
->value
.compcall
.name
;
5662 genproc
= e
->value
.compcall
.tbp
;
5664 if (!genproc
->is_generic
)
5667 /* Try the bindings on this type and in the inheritance hierarchy. */
5668 for (; genproc
; genproc
= genproc
->overridden
)
5672 gcc_assert (genproc
->is_generic
);
5673 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5676 gfc_actual_arglist
* args
;
5679 gcc_assert (g
->specific
);
5681 if (g
->specific
->error
)
5684 target
= g
->specific
->u
.specific
->n
.sym
;
5686 /* Get the right arglist by handling PASS/NOPASS. */
5687 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5688 if (!g
->specific
->nopass
)
5691 po
= extract_compcall_passed_object (e
);
5694 gfc_free_actual_arglist (args
);
5698 gcc_assert (g
->specific
->pass_arg_num
> 0);
5699 gcc_assert (!g
->specific
->error
);
5700 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5701 g
->specific
->pass_arg
);
5703 resolve_actual_arglist (args
, target
->attr
.proc
,
5704 is_external_proc (target
)
5705 && gfc_sym_get_dummy_args (target
) == NULL
);
5707 /* Check if this arglist matches the formal. */
5708 matches
= gfc_arglist_matches_symbol (&args
, target
);
5710 /* Clean up and break out of the loop if we've found it. */
5711 gfc_free_actual_arglist (args
);
5714 e
->value
.compcall
.tbp
= g
->specific
;
5715 genname
= g
->specific_st
->name
;
5716 /* Pass along the name for CLASS methods, where the vtab
5717 procedure pointer component has to be referenced. */
5725 /* Nothing matching found! */
5726 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5727 " %qs at %L", genname
, &e
->where
);
5731 /* Make sure that we have the right specific instance for the name. */
5732 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5734 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5736 e
->value
.compcall
.tbp
= st
->n
.tb
;
5742 /* Resolve a call to a type-bound subroutine. */
5745 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5747 gfc_actual_arglist
* newactual
;
5748 gfc_symtree
* target
;
5750 /* Check that's really a SUBROUTINE. */
5751 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5753 gfc_error ("%qs at %L should be a SUBROUTINE",
5754 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5758 if (!check_typebound_baseobject (c
->expr1
))
5761 /* Pass along the name for CLASS methods, where the vtab
5762 procedure pointer component has to be referenced. */
5764 *name
= c
->expr1
->value
.compcall
.name
;
5766 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5769 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5771 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5773 /* Transform into an ordinary EXEC_CALL for now. */
5775 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5778 c
->ext
.actual
= newactual
;
5779 c
->symtree
= target
;
5780 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5782 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5784 gfc_free_expr (c
->expr1
);
5785 c
->expr1
= gfc_get_expr ();
5786 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5787 c
->expr1
->symtree
= target
;
5788 c
->expr1
->where
= c
->loc
;
5790 return resolve_call (c
);
5794 /* Resolve a component-call expression. */
5796 resolve_compcall (gfc_expr
* e
, const char **name
)
5798 gfc_actual_arglist
* newactual
;
5799 gfc_symtree
* target
;
5801 /* Check that's really a FUNCTION. */
5802 if (!e
->value
.compcall
.tbp
->function
)
5804 gfc_error ("%qs at %L should be a FUNCTION",
5805 e
->value
.compcall
.name
, &e
->where
);
5809 /* These must not be assign-calls! */
5810 gcc_assert (!e
->value
.compcall
.assign
);
5812 if (!check_typebound_baseobject (e
))
5815 /* Pass along the name for CLASS methods, where the vtab
5816 procedure pointer component has to be referenced. */
5818 *name
= e
->value
.compcall
.name
;
5820 if (!resolve_typebound_generic_call (e
, name
))
5822 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5824 /* Take the rank from the function's symbol. */
5825 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5826 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5828 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5829 arglist to the TBP's binding target. */
5831 if (!resolve_typebound_static (e
, &target
, &newactual
))
5834 e
->value
.function
.actual
= newactual
;
5835 e
->value
.function
.name
= NULL
;
5836 e
->value
.function
.esym
= target
->n
.sym
;
5837 e
->value
.function
.isym
= NULL
;
5838 e
->symtree
= target
;
5839 e
->ts
= target
->n
.sym
->ts
;
5840 e
->expr_type
= EXPR_FUNCTION
;
5842 /* Resolution is not necessary if this is a class subroutine; this
5843 function only has to identify the specific proc. Resolution of
5844 the call will be done next in resolve_typebound_call. */
5845 return gfc_resolve_expr (e
);
5849 static bool resolve_fl_derived (gfc_symbol
*sym
);
5852 /* Resolve a typebound function, or 'method'. First separate all
5853 the non-CLASS references by calling resolve_compcall directly. */
5856 resolve_typebound_function (gfc_expr
* e
)
5858 gfc_symbol
*declared
;
5870 /* Deal with typebound operators for CLASS objects. */
5871 expr
= e
->value
.compcall
.base_object
;
5872 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5873 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5875 /* If the base_object is not a variable, the corresponding actual
5876 argument expression must be stored in e->base_expression so
5877 that the corresponding tree temporary can be used as the base
5878 object in gfc_conv_procedure_call. */
5879 if (expr
->expr_type
!= EXPR_VARIABLE
)
5881 gfc_actual_arglist
*args
;
5883 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5885 if (expr
== args
->expr
)
5890 /* Since the typebound operators are generic, we have to ensure
5891 that any delays in resolution are corrected and that the vtab
5894 declared
= ts
.u
.derived
;
5895 c
= gfc_find_component (declared
, "_vptr", true, true);
5896 if (c
->ts
.u
.derived
== NULL
)
5897 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5899 if (!resolve_compcall (e
, &name
))
5902 /* Use the generic name if it is there. */
5903 name
= name
? name
: e
->value
.function
.esym
->name
;
5904 e
->symtree
= expr
->symtree
;
5905 e
->ref
= gfc_copy_ref (expr
->ref
);
5906 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5908 /* Trim away the extraneous references that emerge from nested
5909 use of interface.c (extend_expr). */
5910 if (class_ref
&& class_ref
->next
)
5912 gfc_free_ref_list (class_ref
->next
);
5913 class_ref
->next
= NULL
;
5915 else if (e
->ref
&& !class_ref
)
5917 gfc_free_ref_list (e
->ref
);
5921 gfc_add_vptr_component (e
);
5922 gfc_add_component_ref (e
, name
);
5923 e
->value
.function
.esym
= NULL
;
5924 if (expr
->expr_type
!= EXPR_VARIABLE
)
5925 e
->base_expr
= expr
;
5930 return resolve_compcall (e
, NULL
);
5932 if (!resolve_ref (e
))
5935 /* Get the CLASS declared type. */
5936 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5938 if (!resolve_fl_derived (declared
))
5941 /* Weed out cases of the ultimate component being a derived type. */
5942 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5943 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5945 gfc_free_ref_list (new_ref
);
5946 return resolve_compcall (e
, NULL
);
5949 c
= gfc_find_component (declared
, "_data", true, true);
5950 declared
= c
->ts
.u
.derived
;
5952 /* Treat the call as if it is a typebound procedure, in order to roll
5953 out the correct name for the specific function. */
5954 if (!resolve_compcall (e
, &name
))
5956 gfc_free_ref_list (new_ref
);
5963 /* Convert the expression to a procedure pointer component call. */
5964 e
->value
.function
.esym
= NULL
;
5970 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5971 gfc_add_vptr_component (e
);
5972 gfc_add_component_ref (e
, name
);
5974 /* Recover the typespec for the expression. This is really only
5975 necessary for generic procedures, where the additional call
5976 to gfc_add_component_ref seems to throw the collection of the
5977 correct typespec. */
5981 gfc_free_ref_list (new_ref
);
5986 /* Resolve a typebound subroutine, or 'method'. First separate all
5987 the non-CLASS references by calling resolve_typebound_call
5991 resolve_typebound_subroutine (gfc_code
*code
)
5993 gfc_symbol
*declared
;
6003 st
= code
->expr1
->symtree
;
6005 /* Deal with typebound operators for CLASS objects. */
6006 expr
= code
->expr1
->value
.compcall
.base_object
;
6007 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6008 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6010 /* If the base_object is not a variable, the corresponding actual
6011 argument expression must be stored in e->base_expression so
6012 that the corresponding tree temporary can be used as the base
6013 object in gfc_conv_procedure_call. */
6014 if (expr
->expr_type
!= EXPR_VARIABLE
)
6016 gfc_actual_arglist
*args
;
6018 args
= code
->expr1
->value
.function
.actual
;
6019 for (; args
; args
= args
->next
)
6020 if (expr
== args
->expr
)
6024 /* Since the typebound operators are generic, we have to ensure
6025 that any delays in resolution are corrected and that the vtab
6027 declared
= expr
->ts
.u
.derived
;
6028 c
= gfc_find_component (declared
, "_vptr", true, true);
6029 if (c
->ts
.u
.derived
== NULL
)
6030 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6032 if (!resolve_typebound_call (code
, &name
, NULL
))
6035 /* Use the generic name if it is there. */
6036 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6037 code
->expr1
->symtree
= expr
->symtree
;
6038 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6040 /* Trim away the extraneous references that emerge from nested
6041 use of interface.c (extend_expr). */
6042 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6043 if (class_ref
&& class_ref
->next
)
6045 gfc_free_ref_list (class_ref
->next
);
6046 class_ref
->next
= NULL
;
6048 else if (code
->expr1
->ref
&& !class_ref
)
6050 gfc_free_ref_list (code
->expr1
->ref
);
6051 code
->expr1
->ref
= NULL
;
6054 /* Now use the procedure in the vtable. */
6055 gfc_add_vptr_component (code
->expr1
);
6056 gfc_add_component_ref (code
->expr1
, name
);
6057 code
->expr1
->value
.function
.esym
= NULL
;
6058 if (expr
->expr_type
!= EXPR_VARIABLE
)
6059 code
->expr1
->base_expr
= expr
;
6064 return resolve_typebound_call (code
, NULL
, NULL
);
6066 if (!resolve_ref (code
->expr1
))
6069 /* Get the CLASS declared type. */
6070 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6072 /* Weed out cases of the ultimate component being a derived type. */
6073 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6074 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6076 gfc_free_ref_list (new_ref
);
6077 return resolve_typebound_call (code
, NULL
, NULL
);
6080 if (!resolve_typebound_call (code
, &name
, &overridable
))
6082 gfc_free_ref_list (new_ref
);
6085 ts
= code
->expr1
->ts
;
6089 /* Convert the expression to a procedure pointer component call. */
6090 code
->expr1
->value
.function
.esym
= NULL
;
6091 code
->expr1
->symtree
= st
;
6094 code
->expr1
->ref
= new_ref
;
6096 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6097 gfc_add_vptr_component (code
->expr1
);
6098 gfc_add_component_ref (code
->expr1
, name
);
6100 /* Recover the typespec for the expression. This is really only
6101 necessary for generic procedures, where the additional call
6102 to gfc_add_component_ref seems to throw the collection of the
6103 correct typespec. */
6104 code
->expr1
->ts
= ts
;
6107 gfc_free_ref_list (new_ref
);
6113 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6116 resolve_ppc_call (gfc_code
* c
)
6118 gfc_component
*comp
;
6120 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6121 gcc_assert (comp
!= NULL
);
6123 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6124 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6126 if (!comp
->attr
.subroutine
)
6127 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6129 if (!resolve_ref (c
->expr1
))
6132 if (!update_ppc_arglist (c
->expr1
))
6135 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6137 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6138 !(comp
->ts
.interface
6139 && comp
->ts
.interface
->formal
)))
6142 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6145 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6151 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6154 resolve_expr_ppc (gfc_expr
* e
)
6156 gfc_component
*comp
;
6158 comp
= gfc_get_proc_ptr_comp (e
);
6159 gcc_assert (comp
!= NULL
);
6161 /* Convert to EXPR_FUNCTION. */
6162 e
->expr_type
= EXPR_FUNCTION
;
6163 e
->value
.function
.isym
= NULL
;
6164 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6166 if (comp
->as
!= NULL
)
6167 e
->rank
= comp
->as
->rank
;
6169 if (!comp
->attr
.function
)
6170 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6172 if (!resolve_ref (e
))
6175 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6176 !(comp
->ts
.interface
6177 && comp
->ts
.interface
->formal
)))
6180 if (!update_ppc_arglist (e
))
6183 if (!check_pure_function(e
))
6186 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6193 gfc_is_expandable_expr (gfc_expr
*e
)
6195 gfc_constructor
*con
;
6197 if (e
->expr_type
== EXPR_ARRAY
)
6199 /* Traverse the constructor looking for variables that are flavor
6200 parameter. Parameters must be expanded since they are fully used at
6202 con
= gfc_constructor_first (e
->value
.constructor
);
6203 for (; con
; con
= gfc_constructor_next (con
))
6205 if (con
->expr
->expr_type
== EXPR_VARIABLE
6206 && con
->expr
->symtree
6207 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6208 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6210 if (con
->expr
->expr_type
== EXPR_ARRAY
6211 && gfc_is_expandable_expr (con
->expr
))
6219 /* Resolve an expression. That is, make sure that types of operands agree
6220 with their operators, intrinsic operators are converted to function calls
6221 for overloaded types and unresolved function references are resolved. */
6224 gfc_resolve_expr (gfc_expr
*e
)
6227 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6232 /* inquiry_argument only applies to variables. */
6233 inquiry_save
= inquiry_argument
;
6234 actual_arg_save
= actual_arg
;
6235 first_actual_arg_save
= first_actual_arg
;
6237 if (e
->expr_type
!= EXPR_VARIABLE
)
6239 inquiry_argument
= false;
6241 first_actual_arg
= false;
6244 switch (e
->expr_type
)
6247 t
= resolve_operator (e
);
6253 if (check_host_association (e
))
6254 t
= resolve_function (e
);
6256 t
= resolve_variable (e
);
6258 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6259 && e
->ref
->type
!= REF_SUBSTRING
)
6260 gfc_resolve_substring_charlen (e
);
6265 t
= resolve_typebound_function (e
);
6268 case EXPR_SUBSTRING
:
6269 t
= resolve_ref (e
);
6278 t
= resolve_expr_ppc (e
);
6283 if (!resolve_ref (e
))
6286 t
= gfc_resolve_array_constructor (e
);
6287 /* Also try to expand a constructor. */
6290 expression_rank (e
);
6291 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6292 gfc_expand_constructor (e
, false);
6295 /* This provides the opportunity for the length of constructors with
6296 character valued function elements to propagate the string length
6297 to the expression. */
6298 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6300 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6301 here rather then add a duplicate test for it above. */
6302 gfc_expand_constructor (e
, false);
6303 t
= gfc_resolve_character_array_constructor (e
);
6308 case EXPR_STRUCTURE
:
6309 t
= resolve_ref (e
);
6313 t
= resolve_structure_cons (e
, 0);
6317 t
= gfc_simplify_expr (e
, 0);
6321 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6324 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6327 inquiry_argument
= inquiry_save
;
6328 actual_arg
= actual_arg_save
;
6329 first_actual_arg
= first_actual_arg_save
;
6335 /* Resolve an expression from an iterator. They must be scalar and have
6336 INTEGER or (optionally) REAL type. */
6339 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6340 const char *name_msgid
)
6342 if (!gfc_resolve_expr (expr
))
6345 if (expr
->rank
!= 0)
6347 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6351 if (expr
->ts
.type
!= BT_INTEGER
)
6353 if (expr
->ts
.type
== BT_REAL
)
6356 return gfc_notify_std (GFC_STD_F95_DEL
,
6357 "%s at %L must be integer",
6358 _(name_msgid
), &expr
->where
);
6361 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6368 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6376 /* Resolve the expressions in an iterator structure. If REAL_OK is
6377 false allow only INTEGER type iterators, otherwise allow REAL types.
6378 Set own_scope to true for ac-implied-do and data-implied-do as those
6379 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6382 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6384 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6387 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6388 _("iterator variable")))
6391 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6392 "Start expression in DO loop"))
6395 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6396 "End expression in DO loop"))
6399 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6400 "Step expression in DO loop"))
6403 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6405 if ((iter
->step
->ts
.type
== BT_INTEGER
6406 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6407 || (iter
->step
->ts
.type
== BT_REAL
6408 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6410 gfc_error ("Step expression in DO loop at %L cannot be zero",
6411 &iter
->step
->where
);
6416 /* Convert start, end, and step to the same type as var. */
6417 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6418 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6419 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6421 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6422 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6423 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6425 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6426 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6427 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6429 if (iter
->start
->expr_type
== EXPR_CONSTANT
6430 && iter
->end
->expr_type
== EXPR_CONSTANT
6431 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6434 if (iter
->start
->ts
.type
== BT_INTEGER
)
6436 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6437 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6441 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6442 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6444 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6445 gfc_warning (OPT_Wzerotrip
,
6446 "DO loop at %L will be executed zero times",
6447 &iter
->step
->where
);
6454 /* Traversal function for find_forall_index. f == 2 signals that
6455 that variable itself is not to be checked - only the references. */
6458 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6460 if (expr
->expr_type
!= EXPR_VARIABLE
)
6463 /* A scalar assignment */
6464 if (!expr
->ref
|| *f
== 1)
6466 if (expr
->symtree
->n
.sym
== sym
)
6478 /* Check whether the FORALL index appears in the expression or not.
6479 Returns true if SYM is found in EXPR. */
6482 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6484 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6491 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6492 to be a scalar INTEGER variable. The subscripts and stride are scalar
6493 INTEGERs, and if stride is a constant it must be nonzero.
6494 Furthermore "A subscript or stride in a forall-triplet-spec shall
6495 not contain a reference to any index-name in the
6496 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6499 resolve_forall_iterators (gfc_forall_iterator
*it
)
6501 gfc_forall_iterator
*iter
, *iter2
;
6503 for (iter
= it
; iter
; iter
= iter
->next
)
6505 if (gfc_resolve_expr (iter
->var
)
6506 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6507 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6510 if (gfc_resolve_expr (iter
->start
)
6511 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6512 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6513 &iter
->start
->where
);
6514 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6515 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6517 if (gfc_resolve_expr (iter
->end
)
6518 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6519 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6521 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6522 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6524 if (gfc_resolve_expr (iter
->stride
))
6526 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6527 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6528 &iter
->stride
->where
, "INTEGER");
6530 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6531 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6532 gfc_error ("FORALL stride expression at %L cannot be zero",
6533 &iter
->stride
->where
);
6535 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6536 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6539 for (iter
= it
; iter
; iter
= iter
->next
)
6540 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6542 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6543 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6544 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6545 gfc_error ("FORALL index %qs may not appear in triplet "
6546 "specification at %L", iter
->var
->symtree
->name
,
6547 &iter2
->start
->where
);
6552 /* Given a pointer to a symbol that is a derived type, see if it's
6553 inaccessible, i.e. if it's defined in another module and the components are
6554 PRIVATE. The search is recursive if necessary. Returns zero if no
6555 inaccessible components are found, nonzero otherwise. */
6558 derived_inaccessible (gfc_symbol
*sym
)
6562 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6565 for (c
= sym
->components
; c
; c
= c
->next
)
6567 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6575 /* Resolve the argument of a deallocate expression. The expression must be
6576 a pointer or a full array. */
6579 resolve_deallocate_expr (gfc_expr
*e
)
6581 symbol_attribute attr
;
6582 int allocatable
, pointer
;
6588 if (!gfc_resolve_expr (e
))
6591 if (e
->expr_type
!= EXPR_VARIABLE
)
6594 sym
= e
->symtree
->n
.sym
;
6595 unlimited
= UNLIMITED_POLY(sym
);
6597 if (sym
->ts
.type
== BT_CLASS
)
6599 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6600 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6604 allocatable
= sym
->attr
.allocatable
;
6605 pointer
= sym
->attr
.pointer
;
6607 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6612 if (ref
->u
.ar
.type
!= AR_FULL
6613 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6614 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6619 c
= ref
->u
.c
.component
;
6620 if (c
->ts
.type
== BT_CLASS
)
6622 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6623 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6627 allocatable
= c
->attr
.allocatable
;
6628 pointer
= c
->attr
.pointer
;
6638 attr
= gfc_expr_attr (e
);
6640 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6643 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6649 if (gfc_is_coindexed (e
))
6651 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6656 && !gfc_check_vardef_context (e
, true, true, false,
6657 _("DEALLOCATE object")))
6659 if (!gfc_check_vardef_context (e
, false, true, false,
6660 _("DEALLOCATE object")))
6667 /* Returns true if the expression e contains a reference to the symbol sym. */
6669 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6671 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6678 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6680 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6684 /* Given the expression node e for an allocatable/pointer of derived type to be
6685 allocated, get the expression node to be initialized afterwards (needed for
6686 derived types with default initializers, and derived types with allocatable
6687 components that need nullification.) */
6690 gfc_expr_to_initialize (gfc_expr
*e
)
6696 result
= gfc_copy_expr (e
);
6698 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6699 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6700 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6702 ref
->u
.ar
.type
= AR_FULL
;
6704 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6705 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6710 gfc_free_shape (&result
->shape
, result
->rank
);
6712 /* Recalculate rank, shape, etc. */
6713 gfc_resolve_expr (result
);
6718 /* If the last ref of an expression is an array ref, return a copy of the
6719 expression with that one removed. Otherwise, a copy of the original
6720 expression. This is used for allocate-expressions and pointer assignment
6721 LHS, where there may be an array specification that needs to be stripped
6722 off when using gfc_check_vardef_context. */
6725 remove_last_array_ref (gfc_expr
* e
)
6730 e2
= gfc_copy_expr (e
);
6731 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6732 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6734 gfc_free_ref_list (*r
);
6743 /* Used in resolve_allocate_expr to check that a allocation-object and
6744 a source-expr are conformable. This does not catch all possible
6745 cases; in particular a runtime checking is needed. */
6748 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6751 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6753 /* First compare rank. */
6754 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6755 || (!tail
&& e1
->rank
!= e2
->rank
))
6757 gfc_error ("Source-expr at %L must be scalar or have the "
6758 "same rank as the allocate-object at %L",
6759 &e1
->where
, &e2
->where
);
6770 for (i
= 0; i
< e1
->rank
; i
++)
6772 if (tail
->u
.ar
.start
[i
] == NULL
)
6775 if (tail
->u
.ar
.end
[i
])
6777 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6778 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6779 mpz_add_ui (s
, s
, 1);
6783 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6786 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6788 gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
6789 "have the same shape", &e1
->where
, &e2
->where
);
6802 /* Resolve the expression in an ALLOCATE statement, doing the additional
6803 checks to see whether the expression is OK or not. The expression must
6804 have a trailing array reference that gives the size of the array. */
6807 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6809 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6813 symbol_attribute attr
;
6814 gfc_ref
*ref
, *ref2
;
6817 gfc_symbol
*sym
= NULL
;
6822 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6823 checking of coarrays. */
6824 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6825 if (ref
->next
== NULL
)
6828 if (ref
&& ref
->type
== REF_ARRAY
)
6829 ref
->u
.ar
.in_allocate
= true;
6831 if (!gfc_resolve_expr (e
))
6834 /* Make sure the expression is allocatable or a pointer. If it is
6835 pointer, the next-to-last reference must be a pointer. */
6839 sym
= e
->symtree
->n
.sym
;
6841 /* Check whether ultimate component is abstract and CLASS. */
6844 /* Is the allocate-object unlimited polymorphic? */
6845 unlimited
= UNLIMITED_POLY(e
);
6847 if (e
->expr_type
!= EXPR_VARIABLE
)
6850 attr
= gfc_expr_attr (e
);
6851 pointer
= attr
.pointer
;
6852 dimension
= attr
.dimension
;
6853 codimension
= attr
.codimension
;
6857 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6859 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6860 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6861 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6862 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6863 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6867 allocatable
= sym
->attr
.allocatable
;
6868 pointer
= sym
->attr
.pointer
;
6869 dimension
= sym
->attr
.dimension
;
6870 codimension
= sym
->attr
.codimension
;
6875 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6880 if (ref
->u
.ar
.codimen
> 0)
6883 for (n
= ref
->u
.ar
.dimen
;
6884 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6885 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6892 if (ref
->next
!= NULL
)
6900 gfc_error ("Coindexed allocatable object at %L",
6905 c
= ref
->u
.c
.component
;
6906 if (c
->ts
.type
== BT_CLASS
)
6908 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6909 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6910 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6911 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6912 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6916 allocatable
= c
->attr
.allocatable
;
6917 pointer
= c
->attr
.pointer
;
6918 dimension
= c
->attr
.dimension
;
6919 codimension
= c
->attr
.codimension
;
6920 is_abstract
= c
->attr
.abstract
;
6932 /* Check for F08:C628. */
6933 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6935 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6940 /* Some checks for the SOURCE tag. */
6943 /* Check F03:C631. */
6944 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6946 gfc_error_1 ("Type of entity at %L is type incompatible with "
6947 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6951 /* Check F03:C632 and restriction following Note 6.18. */
6952 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6955 /* Check F03:C633. */
6956 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6958 gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
6959 "shall have the same kind type parameter",
6960 &e
->where
, &code
->expr3
->where
);
6964 /* Check F2008, C642. */
6965 if (code
->expr3
->ts
.type
== BT_DERIVED
6966 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6967 || (code
->expr3
->ts
.u
.derived
->from_intmod
6968 == INTMOD_ISO_FORTRAN_ENV
6969 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6970 == ISOFORTRAN_LOCK_TYPE
)))
6972 gfc_error_1 ("The source-expr at %L shall neither be of type "
6973 "LOCK_TYPE nor have a LOCK_TYPE component if "
6974 "allocate-object at %L is a coarray",
6975 &code
->expr3
->where
, &e
->where
);
6980 /* Check F08:C629. */
6981 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6984 gcc_assert (e
->ts
.type
== BT_CLASS
);
6985 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6986 "type-spec or source-expr", sym
->name
, &e
->where
);
6990 /* Check F08:C632. */
6991 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
6992 && !UNLIMITED_POLY (e
))
6994 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6995 code
->ext
.alloc
.ts
.u
.cl
->length
);
6996 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6998 gfc_error ("Allocating %s at %L with type-spec requires the same "
6999 "character-length parameter as in the declaration",
7000 sym
->name
, &e
->where
);
7005 /* In the variable definition context checks, gfc_expr_attr is used
7006 on the expression. This is fooled by the array specification
7007 present in e, thus we have to eliminate that one temporarily. */
7008 e2
= remove_last_array_ref (e
);
7011 t
= gfc_check_vardef_context (e2
, true, true, false,
7012 _("ALLOCATE object"));
7014 t
= gfc_check_vardef_context (e2
, false, true, false,
7015 _("ALLOCATE object"));
7020 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7021 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7023 /* For class arrays, the initialization with SOURCE is done
7024 using _copy and trans_call. It is convenient to exploit that
7025 when the allocated type is different from the declared type but
7026 no SOURCE exists by setting expr3. */
7027 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7029 else if (!code
->expr3
)
7031 /* Set up default initializer if needed. */
7035 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7036 ts
= code
->ext
.alloc
.ts
;
7040 if (ts
.type
== BT_CLASS
)
7041 ts
= ts
.u
.derived
->components
->ts
;
7043 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7045 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
7046 init_st
->loc
= code
->loc
;
7047 init_st
->expr1
= gfc_expr_to_initialize (e
);
7048 init_st
->expr2
= init_e
;
7049 init_st
->next
= code
->next
;
7050 code
->next
= init_st
;
7053 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7055 /* Default initialization via MOLD (non-polymorphic). */
7056 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7059 gfc_resolve_expr (rhs
);
7060 gfc_free_expr (code
->expr3
);
7065 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7067 /* Make sure the vtab symbol is present when
7068 the module variables are generated. */
7069 gfc_typespec ts
= e
->ts
;
7071 ts
= code
->expr3
->ts
;
7072 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7073 ts
= code
->ext
.alloc
.ts
;
7075 gfc_find_derived_vtab (ts
.u
.derived
);
7078 e
= gfc_expr_to_initialize (e
);
7080 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7082 /* Again, make sure the vtab symbol is present when
7083 the module variables are generated. */
7084 gfc_typespec
*ts
= NULL
;
7086 ts
= &code
->expr3
->ts
;
7088 ts
= &code
->ext
.alloc
.ts
;
7095 e
= gfc_expr_to_initialize (e
);
7098 if (dimension
== 0 && codimension
== 0)
7101 /* Make sure the last reference node is an array specification. */
7103 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7104 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7106 gfc_error ("Array specification required in ALLOCATE statement "
7107 "at %L", &e
->where
);
7111 /* Make sure that the array section reference makes sense in the
7112 context of an ALLOCATE specification. */
7117 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7118 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7120 gfc_error ("Coarray specification required in ALLOCATE statement "
7121 "at %L", &e
->where
);
7125 for (i
= 0; i
< ar
->dimen
; i
++)
7127 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7130 switch (ar
->dimen_type
[i
])
7136 if (ar
->start
[i
] != NULL
7137 && ar
->end
[i
] != NULL
7138 && ar
->stride
[i
] == NULL
)
7141 /* Fall Through... */
7146 case DIMEN_THIS_IMAGE
:
7147 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7153 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7155 sym
= a
->expr
->symtree
->n
.sym
;
7157 /* TODO - check derived type components. */
7158 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7161 if ((ar
->start
[i
] != NULL
7162 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7163 || (ar
->end
[i
] != NULL
7164 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7166 gfc_error ("%qs must not appear in the array specification at "
7167 "%L in the same ALLOCATE statement where it is "
7168 "itself allocated", sym
->name
, &ar
->where
);
7174 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7176 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7177 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7179 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7181 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7182 "statement at %L", &e
->where
);
7188 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7189 && ar
->stride
[i
] == NULL
)
7192 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7205 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7207 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7208 gfc_alloc
*a
, *p
, *q
;
7211 errmsg
= code
->expr2
;
7213 /* Check the stat variable. */
7216 gfc_check_vardef_context (stat
, false, false, false,
7217 _("STAT variable"));
7219 if ((stat
->ts
.type
!= BT_INTEGER
7220 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7221 || stat
->ref
->type
== REF_COMPONENT
)))
7223 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7224 "variable", &stat
->where
);
7226 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7227 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7229 gfc_ref
*ref1
, *ref2
;
7232 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7233 ref1
= ref1
->next
, ref2
= ref2
->next
)
7235 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7237 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7246 gfc_error ("Stat-variable at %L shall not be %sd within "
7247 "the same %s statement", &stat
->where
, fcn
, fcn
);
7253 /* Check the errmsg variable. */
7257 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7260 gfc_check_vardef_context (errmsg
, false, false, false,
7261 _("ERRMSG variable"));
7263 if ((errmsg
->ts
.type
!= BT_CHARACTER
7265 && (errmsg
->ref
->type
== REF_ARRAY
7266 || errmsg
->ref
->type
== REF_COMPONENT
)))
7267 || errmsg
->rank
> 0 )
7268 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7269 "variable", &errmsg
->where
);
7271 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7272 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7274 gfc_ref
*ref1
, *ref2
;
7277 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7278 ref1
= ref1
->next
, ref2
= ref2
->next
)
7280 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7282 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7291 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7292 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7298 /* Check that an allocate-object appears only once in the statement. */
7300 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7303 for (q
= p
->next
; q
; q
= q
->next
)
7306 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7308 /* This is a potential collision. */
7309 gfc_ref
*pr
= pe
->ref
;
7310 gfc_ref
*qr
= qe
->ref
;
7312 /* Follow the references until
7313 a) They start to differ, in which case there is no error;
7314 you can deallocate a%b and a%c in a single statement
7315 b) Both of them stop, which is an error
7316 c) One of them stops, which is also an error. */
7319 if (pr
== NULL
&& qr
== NULL
)
7321 gfc_error_1 ("Allocate-object at %L also appears at %L",
7322 &pe
->where
, &qe
->where
);
7325 else if (pr
!= NULL
&& qr
== NULL
)
7327 gfc_error_1 ("Allocate-object at %L is subobject of"
7328 " object at %L", &pe
->where
, &qe
->where
);
7331 else if (pr
== NULL
&& qr
!= NULL
)
7333 gfc_error_1 ("Allocate-object at %L is subobject of"
7334 " object at %L", &qe
->where
, &pe
->where
);
7337 /* Here, pr != NULL && qr != NULL */
7338 gcc_assert(pr
->type
== qr
->type
);
7339 if (pr
->type
== REF_ARRAY
)
7341 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7343 gcc_assert (qr
->type
== REF_ARRAY
);
7345 if (pr
->next
&& qr
->next
)
7348 gfc_array_ref
*par
= &(pr
->u
.ar
);
7349 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7351 for (i
=0; i
<par
->dimen
; i
++)
7353 if ((par
->start
[i
] != NULL
7354 || qar
->start
[i
] != NULL
)
7355 && gfc_dep_compare_expr (par
->start
[i
],
7356 qar
->start
[i
]) != 0)
7363 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7376 if (strcmp (fcn
, "ALLOCATE") == 0)
7378 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7379 resolve_allocate_expr (a
->expr
, code
);
7383 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7384 resolve_deallocate_expr (a
->expr
);
7389 /************ SELECT CASE resolution subroutines ************/
7391 /* Callback function for our mergesort variant. Determines interval
7392 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7393 op1 > op2. Assumes we're not dealing with the default case.
7394 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7395 There are nine situations to check. */
7398 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7402 if (op1
->low
== NULL
) /* op1 = (:L) */
7404 /* op2 = (:N), so overlap. */
7406 /* op2 = (M:) or (M:N), L < M */
7407 if (op2
->low
!= NULL
7408 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7411 else if (op1
->high
== NULL
) /* op1 = (K:) */
7413 /* op2 = (M:), so overlap. */
7415 /* op2 = (:N) or (M:N), K > N */
7416 if (op2
->high
!= NULL
7417 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7420 else /* op1 = (K:L) */
7422 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7423 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7425 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7426 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7428 else /* op2 = (M:N) */
7432 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7435 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7444 /* Merge-sort a double linked case list, detecting overlap in the
7445 process. LIST is the head of the double linked case list before it
7446 is sorted. Returns the head of the sorted list if we don't see any
7447 overlap, or NULL otherwise. */
7450 check_case_overlap (gfc_case
*list
)
7452 gfc_case
*p
, *q
, *e
, *tail
;
7453 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7455 /* If the passed list was empty, return immediately. */
7462 /* Loop unconditionally. The only exit from this loop is a return
7463 statement, when we've finished sorting the case list. */
7470 /* Count the number of merges we do in this pass. */
7473 /* Loop while there exists a merge to be done. */
7478 /* Count this merge. */
7481 /* Cut the list in two pieces by stepping INSIZE places
7482 forward in the list, starting from P. */
7485 for (i
= 0; i
< insize
; i
++)
7494 /* Now we have two lists. Merge them! */
7495 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7497 /* See from which the next case to merge comes from. */
7500 /* P is empty so the next case must come from Q. */
7505 else if (qsize
== 0 || q
== NULL
)
7514 cmp
= compare_cases (p
, q
);
7517 /* The whole case range for P is less than the
7525 /* The whole case range for Q is greater than
7526 the case range for P. */
7533 /* The cases overlap, or they are the same
7534 element in the list. Either way, we must
7535 issue an error and get the next case from P. */
7536 /* FIXME: Sort P and Q by line number. */
7537 gfc_error_1 ("CASE label at %L overlaps with CASE "
7538 "label at %L", &p
->where
, &q
->where
);
7546 /* Add the next element to the merged list. */
7555 /* P has now stepped INSIZE places along, and so has Q. So
7556 they're the same. */
7561 /* If we have done only one merge or none at all, we've
7562 finished sorting the cases. */
7571 /* Otherwise repeat, merging lists twice the size. */
7577 /* Check to see if an expression is suitable for use in a CASE statement.
7578 Makes sure that all case expressions are scalar constants of the same
7579 type. Return false if anything is wrong. */
7582 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7584 if (e
== NULL
) return true;
7586 if (e
->ts
.type
!= case_expr
->ts
.type
)
7588 gfc_error ("Expression in CASE statement at %L must be of type %s",
7589 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7593 /* C805 (R808) For a given case-construct, each case-value shall be of
7594 the same type as case-expr. For character type, length differences
7595 are allowed, but the kind type parameters shall be the same. */
7597 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7599 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7600 &e
->where
, case_expr
->ts
.kind
);
7604 /* Convert the case value kind to that of case expression kind,
7607 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7608 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7612 gfc_error ("Expression in CASE statement at %L must be scalar",
7621 /* Given a completely parsed select statement, we:
7623 - Validate all expressions and code within the SELECT.
7624 - Make sure that the selection expression is not of the wrong type.
7625 - Make sure that no case ranges overlap.
7626 - Eliminate unreachable cases and unreachable code resulting from
7627 removing case labels.
7629 The standard does allow unreachable cases, e.g. CASE (5:3). But
7630 they are a hassle for code generation, and to prevent that, we just
7631 cut them out here. This is not necessary for overlapping cases
7632 because they are illegal and we never even try to generate code.
7634 We have the additional caveat that a SELECT construct could have
7635 been a computed GOTO in the source code. Fortunately we can fairly
7636 easily work around that here: The case_expr for a "real" SELECT CASE
7637 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7638 we have to do is make sure that the case_expr is a scalar integer
7642 resolve_select (gfc_code
*code
, bool select_type
)
7645 gfc_expr
*case_expr
;
7646 gfc_case
*cp
, *default_case
, *tail
, *head
;
7647 int seen_unreachable
;
7653 if (code
->expr1
== NULL
)
7655 /* This was actually a computed GOTO statement. */
7656 case_expr
= code
->expr2
;
7657 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7658 gfc_error ("Selection expression in computed GOTO statement "
7659 "at %L must be a scalar integer expression",
7662 /* Further checking is not necessary because this SELECT was built
7663 by the compiler, so it should always be OK. Just move the
7664 case_expr from expr2 to expr so that we can handle computed
7665 GOTOs as normal SELECTs from here on. */
7666 code
->expr1
= code
->expr2
;
7671 case_expr
= code
->expr1
;
7672 type
= case_expr
->ts
.type
;
7675 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7677 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7678 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7680 /* Punt. Going on here just produce more garbage error messages. */
7685 if (!select_type
&& case_expr
->rank
!= 0)
7687 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7688 "expression", &case_expr
->where
);
7694 /* Raise a warning if an INTEGER case value exceeds the range of
7695 the case-expr. Later, all expressions will be promoted to the
7696 largest kind of all case-labels. */
7698 if (type
== BT_INTEGER
)
7699 for (body
= code
->block
; body
; body
= body
->block
)
7700 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7703 && gfc_check_integer_range (cp
->low
->value
.integer
,
7704 case_expr
->ts
.kind
) != ARITH_OK
)
7705 gfc_warning (0, "Expression in CASE statement at %L is "
7706 "not in the range of %s", &cp
->low
->where
,
7707 gfc_typename (&case_expr
->ts
));
7710 && cp
->low
!= cp
->high
7711 && gfc_check_integer_range (cp
->high
->value
.integer
,
7712 case_expr
->ts
.kind
) != ARITH_OK
)
7713 gfc_warning (0, "Expression in CASE statement at %L is "
7714 "not in the range of %s", &cp
->high
->where
,
7715 gfc_typename (&case_expr
->ts
));
7718 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7719 of the SELECT CASE expression and its CASE values. Walk the lists
7720 of case values, and if we find a mismatch, promote case_expr to
7721 the appropriate kind. */
7723 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7725 for (body
= code
->block
; body
; body
= body
->block
)
7727 /* Walk the case label list. */
7728 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7730 /* Intercept the DEFAULT case. It does not have a kind. */
7731 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7734 /* Unreachable case ranges are discarded, so ignore. */
7735 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7736 && cp
->low
!= cp
->high
7737 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7741 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7742 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7744 if (cp
->high
!= NULL
7745 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7746 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7751 /* Assume there is no DEFAULT case. */
7752 default_case
= NULL
;
7757 for (body
= code
->block
; body
; body
= body
->block
)
7759 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7761 seen_unreachable
= 0;
7763 /* Walk the case label list, making sure that all case labels
7765 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7767 /* Count the number of cases in the whole construct. */
7770 /* Intercept the DEFAULT case. */
7771 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7773 if (default_case
!= NULL
)
7775 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
7776 "by a second DEFAULT CASE at %L",
7777 &default_case
->where
, &cp
->where
);
7788 /* Deal with single value cases and case ranges. Errors are
7789 issued from the validation function. */
7790 if (!validate_case_label_expr (cp
->low
, case_expr
)
7791 || !validate_case_label_expr (cp
->high
, case_expr
))
7797 if (type
== BT_LOGICAL
7798 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7799 || cp
->low
!= cp
->high
))
7801 gfc_error ("Logical range in CASE statement at %L is not "
7802 "allowed", &cp
->low
->where
);
7807 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7810 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7811 if (value
& seen_logical
)
7813 gfc_error ("Constant logical value in CASE statement "
7814 "is repeated at %L",
7819 seen_logical
|= value
;
7822 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7823 && cp
->low
!= cp
->high
7824 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7826 if (warn_surprising
)
7827 gfc_warning (OPT_Wsurprising
,
7828 "Range specification at %L can never be matched",
7831 cp
->unreachable
= 1;
7832 seen_unreachable
= 1;
7836 /* If the case range can be matched, it can also overlap with
7837 other cases. To make sure it does not, we put it in a
7838 double linked list here. We sort that with a merge sort
7839 later on to detect any overlapping cases. */
7843 head
->right
= head
->left
= NULL
;
7848 tail
->right
->left
= tail
;
7855 /* It there was a failure in the previous case label, give up
7856 for this case label list. Continue with the next block. */
7860 /* See if any case labels that are unreachable have been seen.
7861 If so, we eliminate them. This is a bit of a kludge because
7862 the case lists for a single case statement (label) is a
7863 single forward linked lists. */
7864 if (seen_unreachable
)
7866 /* Advance until the first case in the list is reachable. */
7867 while (body
->ext
.block
.case_list
!= NULL
7868 && body
->ext
.block
.case_list
->unreachable
)
7870 gfc_case
*n
= body
->ext
.block
.case_list
;
7871 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7873 gfc_free_case_list (n
);
7876 /* Strip all other unreachable cases. */
7877 if (body
->ext
.block
.case_list
)
7879 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7881 if (cp
->next
->unreachable
)
7883 gfc_case
*n
= cp
->next
;
7884 cp
->next
= cp
->next
->next
;
7886 gfc_free_case_list (n
);
7893 /* See if there were overlapping cases. If the check returns NULL,
7894 there was overlap. In that case we don't do anything. If head
7895 is non-NULL, we prepend the DEFAULT case. The sorted list can
7896 then used during code generation for SELECT CASE constructs with
7897 a case expression of a CHARACTER type. */
7900 head
= check_case_overlap (head
);
7902 /* Prepend the default_case if it is there. */
7903 if (head
!= NULL
&& default_case
)
7905 default_case
->left
= NULL
;
7906 default_case
->right
= head
;
7907 head
->left
= default_case
;
7911 /* Eliminate dead blocks that may be the result if we've seen
7912 unreachable case labels for a block. */
7913 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7915 if (body
->block
->ext
.block
.case_list
== NULL
)
7917 /* Cut the unreachable block from the code chain. */
7918 gfc_code
*c
= body
->block
;
7919 body
->block
= c
->block
;
7921 /* Kill the dead block, but not the blocks below it. */
7923 gfc_free_statements (c
);
7927 /* More than two cases is legal but insane for logical selects.
7928 Issue a warning for it. */
7929 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
7930 gfc_warning (OPT_Wsurprising
,
7931 "Logical SELECT CASE block at %L has more that two cases",
7936 /* Check if a derived type is extensible. */
7939 gfc_type_is_extensible (gfc_symbol
*sym
)
7941 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7942 || (sym
->attr
.is_class
7943 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7947 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7948 correct as well as possibly the array-spec. */
7951 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7955 gcc_assert (sym
->assoc
);
7956 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7958 /* If this is for SELECT TYPE, the target may not yet be set. In that
7959 case, return. Resolution will be called later manually again when
7961 target
= sym
->assoc
->target
;
7964 gcc_assert (!sym
->assoc
->dangling
);
7966 if (resolve_target
&& !gfc_resolve_expr (target
))
7969 /* For variable targets, we get some attributes from the target. */
7970 if (target
->expr_type
== EXPR_VARIABLE
)
7974 gcc_assert (target
->symtree
);
7975 tsym
= target
->symtree
->n
.sym
;
7977 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7978 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7980 sym
->attr
.target
= tsym
->attr
.target
7981 || gfc_expr_attr (target
).pointer
;
7982 if (is_subref_array (target
))
7983 sym
->attr
.subref_array_pointer
= 1;
7986 /* Get type if this was not already set. Note that it can be
7987 some other type than the target in case this is a SELECT TYPE
7988 selector! So we must not update when the type is already there. */
7989 if (sym
->ts
.type
== BT_UNKNOWN
)
7990 sym
->ts
= target
->ts
;
7991 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7993 /* See if this is a valid association-to-variable. */
7994 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7995 && !gfc_has_vector_subscript (target
));
7997 /* Finally resolve if this is an array or not. */
7998 if (sym
->attr
.dimension
&& target
->rank
== 0)
8000 /* primary.c makes the assumption that a reference to an associate
8001 name followed by a left parenthesis is an array reference. */
8002 if (sym
->ts
.type
!= BT_CHARACTER
)
8003 gfc_error ("Associate-name %qs at %L is used as array",
8004 sym
->name
, &sym
->declared_at
);
8005 sym
->attr
.dimension
= 0;
8009 /* We cannot deal with class selectors that need temporaries. */
8010 if (target
->ts
.type
== BT_CLASS
8011 && gfc_ref_needs_temporary_p (target
->ref
))
8013 gfc_error ("CLASS selector at %L needs a temporary which is not "
8014 "yet implemented", &target
->where
);
8018 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8019 sym
->attr
.dimension
= 1;
8020 else if (target
->ts
.type
== BT_CLASS
)
8021 gfc_fix_class_refs (target
);
8023 /* The associate-name will have a correct type by now. Make absolutely
8024 sure that it has not picked up a dimension attribute. */
8025 if (sym
->ts
.type
== BT_CLASS
)
8026 sym
->attr
.dimension
= 0;
8028 if (sym
->attr
.dimension
)
8030 sym
->as
= gfc_get_array_spec ();
8031 sym
->as
->rank
= target
->rank
;
8032 sym
->as
->type
= AS_DEFERRED
;
8033 sym
->as
->corank
= gfc_get_corank (target
);
8036 /* Mark this as an associate variable. */
8037 sym
->attr
.associate_var
= 1;
8039 /* If the target is a good class object, so is the associate variable. */
8040 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8041 sym
->attr
.class_ok
= 1;
8045 /* Resolve a SELECT TYPE statement. */
8048 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8050 gfc_symbol
*selector_type
;
8051 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8052 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8055 char name
[GFC_MAX_SYMBOL_LEN
];
8060 ns
= code
->ext
.block
.ns
;
8063 /* Check for F03:C813. */
8064 if (code
->expr1
->ts
.type
!= BT_CLASS
8065 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8067 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8068 "at %L", &code
->loc
);
8072 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8077 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8078 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8079 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8081 /* F2008: C803 The selector expression must not be coindexed. */
8082 if (gfc_is_coindexed (code
->expr2
))
8084 gfc_error ("Selector at %L must not be coindexed",
8085 &code
->expr2
->where
);
8092 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8094 if (gfc_is_coindexed (code
->expr1
))
8096 gfc_error ("Selector at %L must not be coindexed",
8097 &code
->expr1
->where
);
8102 /* Loop over TYPE IS / CLASS IS cases. */
8103 for (body
= code
->block
; body
; body
= body
->block
)
8105 c
= body
->ext
.block
.case_list
;
8107 /* Check F03:C815. */
8108 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8109 && !selector_type
->attr
.unlimited_polymorphic
8110 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8112 gfc_error ("Derived type %qs at %L must be extensible",
8113 c
->ts
.u
.derived
->name
, &c
->where
);
8118 /* Check F03:C816. */
8119 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8120 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8121 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8123 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8124 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8125 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8127 gfc_error ("Unexpected intrinsic type %qs at %L",
8128 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8133 /* Check F03:C814. */
8134 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8136 gfc_error ("The type-spec at %L shall specify that each length "
8137 "type parameter is assumed", &c
->where
);
8142 /* Intercept the DEFAULT case. */
8143 if (c
->ts
.type
== BT_UNKNOWN
)
8145 /* Check F03:C818. */
8148 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
8149 "by a second DEFAULT CASE at %L",
8150 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8155 default_case
= body
;
8162 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8163 target if present. If there are any EXIT statements referring to the
8164 SELECT TYPE construct, this is no problem because the gfc_code
8165 reference stays the same and EXIT is equally possible from the BLOCK
8166 it is changed to. */
8167 code
->op
= EXEC_BLOCK
;
8170 gfc_association_list
* assoc
;
8172 assoc
= gfc_get_association_list ();
8173 assoc
->st
= code
->expr1
->symtree
;
8174 assoc
->target
= gfc_copy_expr (code
->expr2
);
8175 assoc
->target
->where
= code
->expr2
->where
;
8176 /* assoc->variable will be set by resolve_assoc_var. */
8178 code
->ext
.block
.assoc
= assoc
;
8179 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8181 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8184 code
->ext
.block
.assoc
= NULL
;
8186 /* Add EXEC_SELECT to switch on type. */
8187 new_st
= gfc_get_code (code
->op
);
8188 new_st
->expr1
= code
->expr1
;
8189 new_st
->expr2
= code
->expr2
;
8190 new_st
->block
= code
->block
;
8191 code
->expr1
= code
->expr2
= NULL
;
8196 ns
->code
->next
= new_st
;
8198 code
->op
= EXEC_SELECT
;
8200 gfc_add_vptr_component (code
->expr1
);
8201 gfc_add_hash_component (code
->expr1
);
8203 /* Loop over TYPE IS / CLASS IS cases. */
8204 for (body
= code
->block
; body
; body
= body
->block
)
8206 c
= body
->ext
.block
.case_list
;
8208 if (c
->ts
.type
== BT_DERIVED
)
8209 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8210 c
->ts
.u
.derived
->hash_value
);
8211 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8216 ivtab
= gfc_find_vtab (&c
->ts
);
8217 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8218 e
= CLASS_DATA (ivtab
)->initializer
;
8219 c
->low
= c
->high
= gfc_copy_expr (e
);
8222 else if (c
->ts
.type
== BT_UNKNOWN
)
8225 /* Associate temporary to selector. This should only be done
8226 when this case is actually true, so build a new ASSOCIATE
8227 that does precisely this here (instead of using the
8230 if (c
->ts
.type
== BT_CLASS
)
8231 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8232 else if (c
->ts
.type
== BT_DERIVED
)
8233 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8234 else if (c
->ts
.type
== BT_CHARACTER
)
8236 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8237 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8238 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8239 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8240 charlen
, c
->ts
.kind
);
8243 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8246 st
= gfc_find_symtree (ns
->sym_root
, name
);
8247 gcc_assert (st
->n
.sym
->assoc
);
8248 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8249 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8250 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8251 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8253 new_st
= gfc_get_code (EXEC_BLOCK
);
8254 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8255 new_st
->ext
.block
.ns
->code
= body
->next
;
8256 body
->next
= new_st
;
8258 /* Chain in the new list only if it is marked as dangling. Otherwise
8259 there is a CASE label overlap and this is already used. Just ignore,
8260 the error is diagnosed elsewhere. */
8261 if (st
->n
.sym
->assoc
->dangling
)
8263 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8264 st
->n
.sym
->assoc
->dangling
= 0;
8267 resolve_assoc_var (st
->n
.sym
, false);
8270 /* Take out CLASS IS cases for separate treatment. */
8272 while (body
&& body
->block
)
8274 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8276 /* Add to class_is list. */
8277 if (class_is
== NULL
)
8279 class_is
= body
->block
;
8284 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8285 tail
->block
= body
->block
;
8288 /* Remove from EXEC_SELECT list. */
8289 body
->block
= body
->block
->block
;
8302 /* Add a default case to hold the CLASS IS cases. */
8303 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8304 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8306 tail
->ext
.block
.case_list
= gfc_get_case ();
8307 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8309 default_case
= tail
;
8312 /* More than one CLASS IS block? */
8313 if (class_is
->block
)
8317 /* Sort CLASS IS blocks by extension level. */
8321 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8324 /* F03:C817 (check for doubles). */
8325 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8326 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8328 gfc_error ("Double CLASS IS block in SELECT TYPE "
8330 &c2
->ext
.block
.case_list
->where
);
8333 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8334 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8337 (*c1
)->block
= c2
->block
;
8347 /* Generate IF chain. */
8348 if_st
= gfc_get_code (EXEC_IF
);
8350 for (body
= class_is
; body
; body
= body
->block
)
8352 new_st
->block
= gfc_get_code (EXEC_IF
);
8353 new_st
= new_st
->block
;
8354 /* Set up IF condition: Call _gfortran_is_extension_of. */
8355 new_st
->expr1
= gfc_get_expr ();
8356 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8357 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8358 new_st
->expr1
->ts
.kind
= 4;
8359 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8360 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8361 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8362 /* Set up arguments. */
8363 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8364 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8365 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8366 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8367 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8368 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8369 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8370 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8371 new_st
->next
= body
->next
;
8373 if (default_case
->next
)
8375 new_st
->block
= gfc_get_code (EXEC_IF
);
8376 new_st
= new_st
->block
;
8377 new_st
->next
= default_case
->next
;
8380 /* Replace CLASS DEFAULT code by the IF chain. */
8381 default_case
->next
= if_st
;
8384 /* Resolve the internal code. This can not be done earlier because
8385 it requires that the sym->assoc of selectors is set already. */
8386 gfc_current_ns
= ns
;
8387 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8388 gfc_current_ns
= old_ns
;
8390 resolve_select (code
, true);
8394 /* Resolve a transfer statement. This is making sure that:
8395 -- a derived type being transferred has only non-pointer components
8396 -- a derived type being transferred doesn't have private components, unless
8397 it's being transferred from the module where the type was defined
8398 -- we're not trying to transfer a whole assumed size array. */
8401 resolve_transfer (gfc_code
*code
)
8410 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8411 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8412 exp
= exp
->value
.op
.op1
;
8414 if (exp
&& exp
->expr_type
== EXPR_NULL
8417 gfc_error ("Invalid context for NULL () intrinsic at %L",
8422 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8423 && exp
->expr_type
!= EXPR_FUNCTION
8424 && exp
->expr_type
!= EXPR_STRUCTURE
))
8427 /* If we are reading, the variable will be changed. Note that
8428 code->ext.dt may be NULL if the TRANSFER is related to
8429 an INQUIRE statement -- but in this case, we are not reading, either. */
8430 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8431 && !gfc_check_vardef_context (exp
, false, false, false,
8435 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8437 /* Go to actual component transferred. */
8438 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8439 if (ref
->type
== REF_COMPONENT
)
8440 ts
= &ref
->u
.c
.component
->ts
;
8442 if (ts
->type
== BT_CLASS
)
8444 /* FIXME: Test for defined input/output. */
8445 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8446 "it is processed by a defined input/output procedure",
8451 if (ts
->type
== BT_DERIVED
)
8453 /* Check that transferred derived type doesn't contain POINTER
8455 if (ts
->u
.derived
->attr
.pointer_comp
)
8457 gfc_error ("Data transfer element at %L cannot have POINTER "
8458 "components unless it is processed by a defined "
8459 "input/output procedure", &code
->loc
);
8464 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8466 gfc_error ("Data transfer element at %L cannot have "
8467 "procedure pointer components", &code
->loc
);
8471 if (ts
->u
.derived
->attr
.alloc_comp
)
8473 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8474 "components unless it is processed by a defined "
8475 "input/output procedure", &code
->loc
);
8479 /* C_PTR and C_FUNPTR have private components which means they can not
8480 be printed. However, if -std=gnu and not -pedantic, allow
8481 the component to be printed to help debugging. */
8482 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8484 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8485 "cannot have PRIVATE components", &code
->loc
))
8488 else if (derived_inaccessible (ts
->u
.derived
))
8490 gfc_error ("Data transfer element at %L cannot have "
8491 "PRIVATE components",&code
->loc
);
8496 if (exp
->expr_type
== EXPR_STRUCTURE
)
8499 sym
= exp
->symtree
->n
.sym
;
8501 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8502 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8504 gfc_error ("Data transfer element at %L cannot be a full reference to "
8505 "an assumed-size array", &code
->loc
);
8511 /*********** Toplevel code resolution subroutines ***********/
8513 /* Find the set of labels that are reachable from this block. We also
8514 record the last statement in each block. */
8517 find_reachable_labels (gfc_code
*block
)
8524 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8526 /* Collect labels in this block. We don't keep those corresponding
8527 to END {IF|SELECT}, these are checked in resolve_branch by going
8528 up through the code_stack. */
8529 for (c
= block
; c
; c
= c
->next
)
8531 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8532 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8535 /* Merge with labels from parent block. */
8538 gcc_assert (cs_base
->prev
->reachable_labels
);
8539 bitmap_ior_into (cs_base
->reachable_labels
,
8540 cs_base
->prev
->reachable_labels
);
8546 resolve_lock_unlock (gfc_code
*code
)
8548 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8549 && code
->expr1
->value
.function
.isym
8550 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8551 remove_caf_get_intrinsic (code
->expr1
);
8553 if (code
->expr1
->ts
.type
!= BT_DERIVED
8554 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8555 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8556 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8557 || code
->expr1
->rank
!= 0
8558 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8559 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8560 &code
->expr1
->where
);
8564 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8565 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8566 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8567 &code
->expr2
->where
);
8570 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8571 _("STAT variable")))
8576 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8577 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8578 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8579 &code
->expr3
->where
);
8582 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8583 _("ERRMSG variable")))
8586 /* Check ACQUIRED_LOCK. */
8588 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8589 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8590 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8591 "variable", &code
->expr4
->where
);
8594 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8595 _("ACQUIRED_LOCK variable")))
8601 resolve_critical (gfc_code
*code
)
8603 gfc_symtree
*symtree
;
8604 gfc_symbol
*lock_type
;
8605 char name
[GFC_MAX_SYMBOL_LEN
];
8606 static int serial
= 0;
8608 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8611 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8612 GFC_PREFIX ("lock_type"));
8614 lock_type
= symtree
->n
.sym
;
8617 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8620 lock_type
= symtree
->n
.sym
;
8621 lock_type
->attr
.flavor
= FL_DERIVED
;
8622 lock_type
->attr
.zero_comp
= 1;
8623 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8624 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8627 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8628 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8631 code
->resolved_sym
= symtree
->n
.sym
;
8632 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8633 symtree
->n
.sym
->attr
.referenced
= 1;
8634 symtree
->n
.sym
->attr
.artificial
= 1;
8635 symtree
->n
.sym
->attr
.codimension
= 1;
8636 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8637 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8638 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8639 symtree
->n
.sym
->as
->corank
= 1;
8640 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8641 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8642 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8648 resolve_sync (gfc_code
*code
)
8650 /* Check imageset. The * case matches expr1 == NULL. */
8653 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8654 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8655 "INTEGER expression", &code
->expr1
->where
);
8656 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8657 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8658 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8659 &code
->expr1
->where
);
8660 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8661 && gfc_simplify_expr (code
->expr1
, 0))
8663 gfc_constructor
*cons
;
8664 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8665 for (; cons
; cons
= gfc_constructor_next (cons
))
8666 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8667 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8668 gfc_error ("Imageset argument at %L must between 1 and "
8669 "num_images()", &cons
->expr
->where
);
8675 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8676 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8677 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8678 &code
->expr2
->where
);
8682 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8683 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8684 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8685 &code
->expr3
->where
);
8689 /* Given a branch to a label, see if the branch is conforming.
8690 The code node describes where the branch is located. */
8693 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8700 /* Step one: is this a valid branching target? */
8702 if (label
->defined
== ST_LABEL_UNKNOWN
)
8704 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8709 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8711 gfc_error_1 ("Statement at %L is not a valid branch target statement "
8712 "for the branch statement at %L", &label
->where
, &code
->loc
);
8716 /* Step two: make sure this branch is not a branch to itself ;-) */
8718 if (code
->here
== label
)
8721 "Branch at %L may result in an infinite loop", &code
->loc
);
8725 /* Step three: See if the label is in the same block as the
8726 branching statement. The hard work has been done by setting up
8727 the bitmap reachable_labels. */
8729 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8731 /* Check now whether there is a CRITICAL construct; if so, check
8732 whether the label is still visible outside of the CRITICAL block,
8733 which is invalid. */
8734 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8736 if (stack
->current
->op
== EXEC_CRITICAL
8737 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8738 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
8739 "label at %L", &code
->loc
, &label
->where
);
8740 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8741 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8742 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
8743 "for label at %L", &code
->loc
, &label
->where
);
8749 /* Step four: If we haven't found the label in the bitmap, it may
8750 still be the label of the END of the enclosing block, in which
8751 case we find it by going up the code_stack. */
8753 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8755 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8757 if (stack
->current
->op
== EXEC_CRITICAL
)
8759 /* Note: A label at END CRITICAL does not leave the CRITICAL
8760 construct as END CRITICAL is still part of it. */
8761 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
8762 " at %L", &code
->loc
, &label
->where
);
8765 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8767 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
8768 "label at %L", &code
->loc
, &label
->where
);
8775 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8779 /* The label is not in an enclosing block, so illegal. This was
8780 allowed in Fortran 66, so we allow it as extension. No
8781 further checks are necessary in this case. */
8782 gfc_notify_std_1 (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8783 "as the GOTO statement at %L", &label
->where
,
8789 /* Check whether EXPR1 has the same shape as EXPR2. */
8792 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8794 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8795 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8796 bool result
= false;
8799 /* Compare the rank. */
8800 if (expr1
->rank
!= expr2
->rank
)
8803 /* Compare the size of each dimension. */
8804 for (i
=0; i
<expr1
->rank
; i
++)
8806 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8809 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8812 if (mpz_cmp (shape
[i
], shape2
[i
]))
8816 /* When either of the two expression is an assumed size array, we
8817 ignore the comparison of dimension sizes. */
8822 gfc_clear_shape (shape
, i
);
8823 gfc_clear_shape (shape2
, i
);
8828 /* Check whether a WHERE assignment target or a WHERE mask expression
8829 has the same shape as the outmost WHERE mask expression. */
8832 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8838 cblock
= code
->block
;
8840 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8841 In case of nested WHERE, only the outmost one is stored. */
8842 if (mask
== NULL
) /* outmost WHERE */
8844 else /* inner WHERE */
8851 /* Check if the mask-expr has a consistent shape with the
8852 outmost WHERE mask-expr. */
8853 if (!resolve_where_shape (cblock
->expr1
, e
))
8854 gfc_error ("WHERE mask at %L has inconsistent shape",
8855 &cblock
->expr1
->where
);
8858 /* the assignment statement of a WHERE statement, or the first
8859 statement in where-body-construct of a WHERE construct */
8860 cnext
= cblock
->next
;
8865 /* WHERE assignment statement */
8868 /* Check shape consistent for WHERE assignment target. */
8869 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8870 gfc_error ("WHERE assignment target at %L has "
8871 "inconsistent shape", &cnext
->expr1
->where
);
8875 case EXEC_ASSIGN_CALL
:
8876 resolve_call (cnext
);
8877 if (!cnext
->resolved_sym
->attr
.elemental
)
8878 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8879 &cnext
->ext
.actual
->expr
->where
);
8882 /* WHERE or WHERE construct is part of a where-body-construct */
8884 resolve_where (cnext
, e
);
8888 gfc_error ("Unsupported statement inside WHERE at %L",
8891 /* the next statement within the same where-body-construct */
8892 cnext
= cnext
->next
;
8894 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8895 cblock
= cblock
->block
;
8900 /* Resolve assignment in FORALL construct.
8901 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8902 FORALL index variables. */
8905 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8909 for (n
= 0; n
< nvar
; n
++)
8911 gfc_symbol
*forall_index
;
8913 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8915 /* Check whether the assignment target is one of the FORALL index
8917 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8918 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8919 gfc_error ("Assignment to a FORALL index variable at %L",
8920 &code
->expr1
->where
);
8923 /* If one of the FORALL index variables doesn't appear in the
8924 assignment variable, then there could be a many-to-one
8925 assignment. Emit a warning rather than an error because the
8926 mask could be resolving this problem. */
8927 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8928 gfc_warning (0, "The FORALL with index %qs is not used on the "
8929 "left side of the assignment at %L and so might "
8930 "cause multiple assignment to this object",
8931 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8937 /* Resolve WHERE statement in FORALL construct. */
8940 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8941 gfc_expr
**var_expr
)
8946 cblock
= code
->block
;
8949 /* the assignment statement of a WHERE statement, or the first
8950 statement in where-body-construct of a WHERE construct */
8951 cnext
= cblock
->next
;
8956 /* WHERE assignment statement */
8958 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8961 /* WHERE operator assignment statement */
8962 case EXEC_ASSIGN_CALL
:
8963 resolve_call (cnext
);
8964 if (!cnext
->resolved_sym
->attr
.elemental
)
8965 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8966 &cnext
->ext
.actual
->expr
->where
);
8969 /* WHERE or WHERE construct is part of a where-body-construct */
8971 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8975 gfc_error ("Unsupported statement inside WHERE at %L",
8978 /* the next statement within the same where-body-construct */
8979 cnext
= cnext
->next
;
8981 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8982 cblock
= cblock
->block
;
8987 /* Traverse the FORALL body to check whether the following errors exist:
8988 1. For assignment, check if a many-to-one assignment happens.
8989 2. For WHERE statement, check the WHERE body to see if there is any
8990 many-to-one assignment. */
8993 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8997 c
= code
->block
->next
;
9003 case EXEC_POINTER_ASSIGN
:
9004 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9007 case EXEC_ASSIGN_CALL
:
9011 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9012 there is no need to handle it here. */
9016 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9021 /* The next statement in the FORALL body. */
9027 /* Counts the number of iterators needed inside a forall construct, including
9028 nested forall constructs. This is used to allocate the needed memory
9029 in gfc_resolve_forall. */
9032 gfc_count_forall_iterators (gfc_code
*code
)
9034 int max_iters
, sub_iters
, current_iters
;
9035 gfc_forall_iterator
*fa
;
9037 gcc_assert(code
->op
== EXEC_FORALL
);
9041 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9044 code
= code
->block
->next
;
9048 if (code
->op
== EXEC_FORALL
)
9050 sub_iters
= gfc_count_forall_iterators (code
);
9051 if (sub_iters
> max_iters
)
9052 max_iters
= sub_iters
;
9057 return current_iters
+ max_iters
;
9061 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9062 gfc_resolve_forall_body to resolve the FORALL body. */
9065 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9067 static gfc_expr
**var_expr
;
9068 static int total_var
= 0;
9069 static int nvar
= 0;
9071 gfc_forall_iterator
*fa
;
9076 /* Start to resolve a FORALL construct */
9077 if (forall_save
== 0)
9079 /* Count the total number of FORALL index in the nested FORALL
9080 construct in order to allocate the VAR_EXPR with proper size. */
9081 total_var
= gfc_count_forall_iterators (code
);
9083 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9084 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9087 /* The information about FORALL iterator, including FORALL index start, end
9088 and stride. The FORALL index can not appear in start, end or stride. */
9089 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9091 /* Check if any outer FORALL index name is the same as the current
9093 for (i
= 0; i
< nvar
; i
++)
9095 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9097 gfc_error ("An outer FORALL construct already has an index "
9098 "with this name %L", &fa
->var
->where
);
9102 /* Record the current FORALL index. */
9103 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9107 /* No memory leak. */
9108 gcc_assert (nvar
<= total_var
);
9111 /* Resolve the FORALL body. */
9112 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9114 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9115 gfc_resolve_blocks (code
->block
, ns
);
9119 /* Free only the VAR_EXPRs allocated in this frame. */
9120 for (i
= nvar
; i
< tmp
; i
++)
9121 gfc_free_expr (var_expr
[i
]);
9125 /* We are in the outermost FORALL construct. */
9126 gcc_assert (forall_save
== 0);
9128 /* VAR_EXPR is not needed any more. */
9135 /* Resolve a BLOCK construct statement. */
9138 resolve_block_construct (gfc_code
* code
)
9140 /* Resolve the BLOCK's namespace. */
9141 gfc_resolve (code
->ext
.block
.ns
);
9143 /* For an ASSOCIATE block, the associations (and their targets) are already
9144 resolved during resolve_symbol. */
9148 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9152 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9156 for (; b
; b
= b
->block
)
9158 t
= gfc_resolve_expr (b
->expr1
);
9159 if (!gfc_resolve_expr (b
->expr2
))
9165 if (t
&& b
->expr1
!= NULL
9166 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9167 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9174 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9175 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9180 resolve_branch (b
->label1
, b
);
9184 resolve_block_construct (b
);
9188 case EXEC_SELECT_TYPE
:
9192 case EXEC_DO_CONCURRENT
:
9200 case EXEC_OACC_PARALLEL_LOOP
:
9201 case EXEC_OACC_PARALLEL
:
9202 case EXEC_OACC_KERNELS_LOOP
:
9203 case EXEC_OACC_KERNELS
:
9204 case EXEC_OACC_DATA
:
9205 case EXEC_OACC_HOST_DATA
:
9206 case EXEC_OACC_LOOP
:
9207 case EXEC_OACC_UPDATE
:
9208 case EXEC_OACC_WAIT
:
9209 case EXEC_OACC_CACHE
:
9210 case EXEC_OACC_ENTER_DATA
:
9211 case EXEC_OACC_EXIT_DATA
:
9212 case EXEC_OMP_ATOMIC
:
9213 case EXEC_OMP_CRITICAL
:
9214 case EXEC_OMP_DISTRIBUTE
:
9215 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9216 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9217 case EXEC_OMP_DISTRIBUTE_SIMD
:
9219 case EXEC_OMP_DO_SIMD
:
9220 case EXEC_OMP_MASTER
:
9221 case EXEC_OMP_ORDERED
:
9222 case EXEC_OMP_PARALLEL
:
9223 case EXEC_OMP_PARALLEL_DO
:
9224 case EXEC_OMP_PARALLEL_DO_SIMD
:
9225 case EXEC_OMP_PARALLEL_SECTIONS
:
9226 case EXEC_OMP_PARALLEL_WORKSHARE
:
9227 case EXEC_OMP_SECTIONS
:
9229 case EXEC_OMP_SINGLE
:
9230 case EXEC_OMP_TARGET
:
9231 case EXEC_OMP_TARGET_DATA
:
9232 case EXEC_OMP_TARGET_TEAMS
:
9233 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9234 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9235 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9236 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9237 case EXEC_OMP_TARGET_UPDATE
:
9239 case EXEC_OMP_TASKGROUP
:
9240 case EXEC_OMP_TASKWAIT
:
9241 case EXEC_OMP_TASKYIELD
:
9242 case EXEC_OMP_TEAMS
:
9243 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9244 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9245 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9246 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9247 case EXEC_OMP_WORKSHARE
:
9251 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9254 gfc_resolve_code (b
->next
, ns
);
9259 /* Does everything to resolve an ordinary assignment. Returns true
9260 if this is an interface assignment. */
9262 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9271 symbol_attribute attr
;
9273 if (gfc_extend_assign (code
, ns
))
9277 if (code
->op
== EXEC_ASSIGN_CALL
)
9279 lhs
= code
->ext
.actual
->expr
;
9280 rhsptr
= &code
->ext
.actual
->next
->expr
;
9284 gfc_actual_arglist
* args
;
9285 gfc_typebound_proc
* tbp
;
9287 gcc_assert (code
->op
== EXEC_COMPCALL
);
9289 args
= code
->expr1
->value
.compcall
.actual
;
9291 rhsptr
= &args
->next
->expr
;
9293 tbp
= code
->expr1
->value
.compcall
.tbp
;
9294 gcc_assert (!tbp
->is_generic
);
9297 /* Make a temporary rhs when there is a default initializer
9298 and rhs is the same symbol as the lhs. */
9299 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9300 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9301 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9302 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9303 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9312 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9313 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9317 /* Handle the case of a BOZ literal on the RHS. */
9318 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9321 if (warn_surprising
)
9322 gfc_warning (OPT_Wsurprising
,
9323 "BOZ literal at %L is bitwise transferred "
9324 "non-integer symbol %qs", &code
->loc
,
9325 lhs
->symtree
->n
.sym
->name
);
9327 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9329 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9331 if (rc
== ARITH_UNDERFLOW
)
9332 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9333 ". This check can be disabled with the option "
9334 "%<-fno-range-check%>", &rhs
->where
);
9335 else if (rc
== ARITH_OVERFLOW
)
9336 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9337 ". This check can be disabled with the option "
9338 "%<-fno-range-check%>", &rhs
->where
);
9339 else if (rc
== ARITH_NAN
)
9340 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9341 ". This check can be disabled with the option "
9342 "%<-fno-range-check%>", &rhs
->where
);
9347 if (lhs
->ts
.type
== BT_CHARACTER
9348 && warn_character_truncation
)
9350 if (lhs
->ts
.u
.cl
!= NULL
9351 && lhs
->ts
.u
.cl
->length
!= NULL
9352 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9353 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9355 if (rhs
->expr_type
== EXPR_CONSTANT
)
9356 rlen
= rhs
->value
.character
.length
;
9358 else if (rhs
->ts
.u
.cl
!= NULL
9359 && rhs
->ts
.u
.cl
->length
!= NULL
9360 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9361 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9363 if (rlen
&& llen
&& rlen
> llen
)
9364 gfc_warning_now (OPT_Wcharacter_truncation
,
9365 "CHARACTER expression will be truncated "
9366 "in assignment (%d/%d) at %L",
9367 llen
, rlen
, &code
->loc
);
9370 /* Ensure that a vector index expression for the lvalue is evaluated
9371 to a temporary if the lvalue symbol is referenced in it. */
9374 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9375 if (ref
->type
== REF_ARRAY
)
9377 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9378 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9379 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9380 ref
->u
.ar
.start
[n
]))
9382 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9386 if (gfc_pure (NULL
))
9388 if (lhs
->ts
.type
== BT_DERIVED
9389 && lhs
->expr_type
== EXPR_VARIABLE
9390 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9391 && rhs
->expr_type
== EXPR_VARIABLE
9392 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9393 || gfc_is_coindexed (rhs
)))
9396 if (gfc_is_coindexed (rhs
))
9397 gfc_error ("Coindexed expression at %L is assigned to "
9398 "a derived type variable with a POINTER "
9399 "component in a PURE procedure",
9402 gfc_error ("The impure variable at %L is assigned to "
9403 "a derived type variable with a POINTER "
9404 "component in a PURE procedure (12.6)",
9409 /* Fortran 2008, C1283. */
9410 if (gfc_is_coindexed (lhs
))
9412 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9413 "procedure", &rhs
->where
);
9418 if (gfc_implicit_pure (NULL
))
9420 if (lhs
->expr_type
== EXPR_VARIABLE
9421 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9422 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9423 gfc_unset_implicit_pure (NULL
);
9425 if (lhs
->ts
.type
== BT_DERIVED
9426 && lhs
->expr_type
== EXPR_VARIABLE
9427 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9428 && rhs
->expr_type
== EXPR_VARIABLE
9429 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9430 || gfc_is_coindexed (rhs
)))
9431 gfc_unset_implicit_pure (NULL
);
9433 /* Fortran 2008, C1283. */
9434 if (gfc_is_coindexed (lhs
))
9435 gfc_unset_implicit_pure (NULL
);
9438 /* F2008, 7.2.1.2. */
9439 attr
= gfc_expr_attr (lhs
);
9440 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9442 if (attr
.codimension
)
9444 gfc_error ("Assignment to polymorphic coarray at %L is not "
9445 "permitted", &lhs
->where
);
9448 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9449 "polymorphic variable at %L", &lhs
->where
))
9451 if (!flag_realloc_lhs
)
9453 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9454 "requires %<-frealloc-lhs%>", &lhs
->where
);
9458 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9459 "is not yet supported", &lhs
->where
);
9462 else if (lhs
->ts
.type
== BT_CLASS
)
9464 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9465 "assignment at %L - check that there is a matching specific "
9466 "subroutine for '=' operator", &lhs
->where
);
9470 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9472 /* F2008, Section 7.2.1.2. */
9473 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9475 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9476 "component in assignment at %L", &lhs
->where
);
9480 gfc_check_assign (lhs
, rhs
, 1);
9482 /* Assign the 'data' of a class object to a derived type. */
9483 if (lhs
->ts
.type
== BT_DERIVED
9484 && rhs
->ts
.type
== BT_CLASS
)
9485 gfc_add_data_component (rhs
);
9487 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9488 Additionally, insert this code when the RHS is a CAF as we then use the
9489 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9490 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9491 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9493 if (flag_coarray
== GFC_FCOARRAY_LIB
9495 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9496 && code
->expr2
->value
.function
.isym
9497 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9498 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9499 && !gfc_expr_attr (rhs
).allocatable
9500 && !gfc_has_vector_subscript (rhs
))))
9502 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9503 && code
->expr2
->value
.function
.isym
9504 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9505 remove_caf_get_intrinsic (code
->expr2
);
9506 code
->op
= EXEC_CALL
;
9507 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9508 code
->resolved_sym
= code
->symtree
->n
.sym
;
9509 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9510 code
->resolved_sym
->attr
.intrinsic
= 1;
9511 code
->resolved_sym
->attr
.subroutine
= 1;
9512 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9513 gfc_commit_symbol (code
->resolved_sym
);
9514 code
->ext
.actual
= gfc_get_actual_arglist ();
9515 code
->ext
.actual
->expr
= lhs
;
9516 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9517 code
->ext
.actual
->next
->expr
= rhs
;
9526 /* Add a component reference onto an expression. */
9529 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9534 ref
= &((*ref
)->next
);
9535 *ref
= gfc_get_ref ();
9536 (*ref
)->type
= REF_COMPONENT
;
9537 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9538 (*ref
)->u
.c
.component
= c
;
9541 /* Add a full array ref, as necessary. */
9544 gfc_add_full_array_ref (e
, c
->as
);
9545 e
->rank
= c
->as
->rank
;
9550 /* Build an assignment. Keep the argument 'op' for future use, so that
9551 pointer assignments can be made. */
9554 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9555 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9557 gfc_code
*this_code
;
9559 this_code
= gfc_get_code (op
);
9560 this_code
->next
= NULL
;
9561 this_code
->expr1
= gfc_copy_expr (expr1
);
9562 this_code
->expr2
= gfc_copy_expr (expr2
);
9563 this_code
->loc
= loc
;
9566 add_comp_ref (this_code
->expr1
, comp1
);
9567 add_comp_ref (this_code
->expr2
, comp2
);
9574 /* Makes a temporary variable expression based on the characteristics of
9575 a given variable expression. */
9578 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9580 static int serial
= 0;
9581 char name
[GFC_MAX_SYMBOL_LEN
];
9584 gfc_array_ref
*aref
;
9587 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9588 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9589 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9595 /* This function could be expanded to support other expression type
9596 but this is not needed here. */
9597 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9599 /* Obtain the arrayspec for the temporary. */
9602 aref
= gfc_find_array_ref (e
);
9603 if (e
->expr_type
== EXPR_VARIABLE
9604 && e
->symtree
->n
.sym
->as
== aref
->as
)
9608 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9609 if (ref
->type
== REF_COMPONENT
9610 && ref
->u
.c
.component
->as
== aref
->as
)
9618 /* Add the attributes and the arrayspec to the temporary. */
9619 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9620 tmp
->n
.sym
->attr
.function
= 0;
9621 tmp
->n
.sym
->attr
.result
= 0;
9622 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9626 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9629 if (as
->type
== AS_DEFERRED
)
9630 tmp
->n
.sym
->attr
.allocatable
= 1;
9633 tmp
->n
.sym
->attr
.dimension
= 0;
9635 gfc_set_sym_referenced (tmp
->n
.sym
);
9636 gfc_commit_symbol (tmp
->n
.sym
);
9637 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9639 /* Should the lhs be a section, use its array ref for the
9640 temporary expression. */
9641 if (aref
&& aref
->type
!= AR_FULL
)
9643 gfc_free_ref_list (e
->ref
);
9644 e
->ref
= gfc_copy_ref (ref
);
9650 /* Add one line of code to the code chain, making sure that 'head' and
9651 'tail' are appropriately updated. */
9654 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9656 gcc_assert (this_code
);
9658 *head
= *tail
= *this_code
;
9660 *tail
= gfc_append_code (*tail
, *this_code
);
9665 /* Counts the potential number of part array references that would
9666 result from resolution of typebound defined assignments. */
9669 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9672 int c_depth
= 0, t_depth
;
9674 for (c
= derived
->components
; c
; c
= c
->next
)
9676 if ((c
->ts
.type
!= BT_DERIVED
9678 || c
->attr
.allocatable
9679 || c
->attr
.proc_pointer_comp
9680 || c
->attr
.class_pointer
9681 || c
->attr
.proc_pointer
)
9682 && !c
->attr
.defined_assign_comp
)
9685 if (c
->as
&& c_depth
== 0)
9688 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9689 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9694 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9696 return depth
+ c_depth
;
9700 /* Implement 7.2.1.3 of the F08 standard:
9701 "An intrinsic assignment where the variable is of derived type is
9702 performed as if each component of the variable were assigned from the
9703 corresponding component of expr using pointer assignment (7.2.2) for
9704 each pointer component, defined assignment for each nonpointer
9705 nonallocatable component of a type that has a type-bound defined
9706 assignment consistent with the component, intrinsic assignment for
9707 each other nonpointer nonallocatable component, ..."
9709 The pointer assignments are taken care of by the intrinsic
9710 assignment of the structure itself. This function recursively adds
9711 defined assignments where required. The recursion is accomplished
9712 by calling gfc_resolve_code.
9714 When the lhs in a defined assignment has intent INOUT, we need a
9715 temporary for the lhs. In pseudo-code:
9717 ! Only call function lhs once.
9718 if (lhs is not a constant or an variable)
9721 ! Do the intrinsic assignment
9723 ! Now do the defined assignments
9724 do over components with typebound defined assignment [%cmp]
9725 #if one component's assignment procedure is INOUT
9727 #if expr2 non-variable
9733 t1%cmp {defined=} expr2%cmp
9739 expr1%cmp {defined=} expr2%cmp
9743 /* The temporary assignments have to be put on top of the additional
9744 code to avoid the result being changed by the intrinsic assignment.
9746 static int component_assignment_level
= 0;
9747 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9750 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9752 gfc_component
*comp1
, *comp2
;
9753 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9755 int error_count
, depth
;
9757 gfc_get_errors (NULL
, &error_count
);
9759 /* Filter out continuing processing after an error. */
9761 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9762 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9765 /* TODO: Handle more than one part array reference in assignments. */
9766 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9767 (*code
)->expr1
->rank
? 1 : 0);
9770 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
9771 "done because multiple part array references would "
9772 "occur in intermediate expressions.", &(*code
)->loc
);
9776 component_assignment_level
++;
9778 /* Create a temporary so that functions get called only once. */
9779 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9780 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9784 /* Assign the rhs to the temporary. */
9785 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9786 this_code
= build_assignment (EXEC_ASSIGN
,
9787 tmp_expr
, (*code
)->expr2
,
9788 NULL
, NULL
, (*code
)->loc
);
9789 /* Add the code and substitute the rhs expression. */
9790 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9791 gfc_free_expr ((*code
)->expr2
);
9792 (*code
)->expr2
= tmp_expr
;
9795 /* Do the intrinsic assignment. This is not needed if the lhs is one
9796 of the temporaries generated here, since the intrinsic assignment
9797 to the final result already does this. */
9798 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9800 this_code
= build_assignment (EXEC_ASSIGN
,
9801 (*code
)->expr1
, (*code
)->expr2
,
9802 NULL
, NULL
, (*code
)->loc
);
9803 add_code_to_chain (&this_code
, &head
, &tail
);
9806 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9807 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9810 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9814 /* The intrinsic assignment does the right thing for pointers
9815 of all kinds and allocatable components. */
9816 if (comp1
->ts
.type
!= BT_DERIVED
9817 || comp1
->attr
.pointer
9818 || comp1
->attr
.allocatable
9819 || comp1
->attr
.proc_pointer_comp
9820 || comp1
->attr
.class_pointer
9821 || comp1
->attr
.proc_pointer
)
9824 /* Make an assigment for this component. */
9825 this_code
= build_assignment (EXEC_ASSIGN
,
9826 (*code
)->expr1
, (*code
)->expr2
,
9827 comp1
, comp2
, (*code
)->loc
);
9829 /* Convert the assignment if there is a defined assignment for
9830 this type. Otherwise, using the call from gfc_resolve_code,
9831 recurse into its components. */
9832 gfc_resolve_code (this_code
, ns
);
9834 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9836 gfc_formal_arglist
*dummy_args
;
9838 /* Check that there is a typebound defined assignment. If not,
9839 then this must be a module defined assignment. We cannot
9840 use the defined_assign_comp attribute here because it must
9841 be this derived type that has the defined assignment and not
9843 if (!(comp1
->ts
.u
.derived
->f2k_derived
9844 && comp1
->ts
.u
.derived
->f2k_derived
9845 ->tb_op
[INTRINSIC_ASSIGN
]))
9847 gfc_free_statements (this_code
);
9852 /* If the first argument of the subroutine has intent INOUT
9853 a temporary must be generated and used instead. */
9854 rsym
= this_code
->resolved_sym
;
9855 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9857 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9859 gfc_code
*temp_code
;
9862 /* Build the temporary required for the assignment and put
9863 it at the head of the generated code. */
9866 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9867 temp_code
= build_assignment (EXEC_ASSIGN
,
9869 NULL
, NULL
, (*code
)->loc
);
9871 /* For allocatable LHS, check whether it is allocated. Note
9872 that allocatable components with defined assignment are
9873 not yet support. See PR 57696. */
9874 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9878 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9879 block
= gfc_get_code (EXEC_IF
);
9880 block
->block
= gfc_get_code (EXEC_IF
);
9882 = gfc_build_intrinsic_call (ns
,
9883 GFC_ISYM_ALLOCATED
, "allocated",
9884 (*code
)->loc
, 1, e
);
9885 block
->block
->next
= temp_code
;
9888 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9891 /* Replace the first actual arg with the component of the
9893 gfc_free_expr (this_code
->ext
.actual
->expr
);
9894 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9895 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9897 /* If the LHS variable is allocatable and wasn't allocated and
9898 the temporary is allocatable, pointer assign the address of
9899 the freshly allocated LHS to the temporary. */
9900 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9901 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9906 cond
= gfc_get_expr ();
9907 cond
->ts
.type
= BT_LOGICAL
;
9908 cond
->ts
.kind
= gfc_default_logical_kind
;
9909 cond
->expr_type
= EXPR_OP
;
9910 cond
->where
= (*code
)->loc
;
9911 cond
->value
.op
.op
= INTRINSIC_NOT
;
9912 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9913 GFC_ISYM_ALLOCATED
, "allocated",
9914 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9915 block
= gfc_get_code (EXEC_IF
);
9916 block
->block
= gfc_get_code (EXEC_IF
);
9917 block
->block
->expr1
= cond
;
9918 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9920 NULL
, NULL
, (*code
)->loc
);
9921 add_code_to_chain (&block
, &head
, &tail
);
9925 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9927 /* Don't add intrinsic assignments since they are already
9928 effected by the intrinsic assignment of the structure. */
9929 gfc_free_statements (this_code
);
9934 add_code_to_chain (&this_code
, &head
, &tail
);
9938 /* Transfer the value to the final result. */
9939 this_code
= build_assignment (EXEC_ASSIGN
,
9941 comp1
, comp2
, (*code
)->loc
);
9942 add_code_to_chain (&this_code
, &head
, &tail
);
9946 /* Put the temporary assignments at the top of the generated code. */
9947 if (tmp_head
&& component_assignment_level
== 1)
9949 gfc_append_code (tmp_head
, head
);
9951 tmp_head
= tmp_tail
= NULL
;
9954 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9955 // not accidentally deallocated. Hence, nullify t1.
9956 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9957 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9963 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9964 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9965 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9966 block
= gfc_get_code (EXEC_IF
);
9967 block
->block
= gfc_get_code (EXEC_IF
);
9968 block
->block
->expr1
= cond
;
9969 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9970 t1
, gfc_get_null_expr (&(*code
)->loc
),
9971 NULL
, NULL
, (*code
)->loc
);
9972 gfc_append_code (tail
, block
);
9976 /* Now attach the remaining code chain to the input code. Step on
9977 to the end of the new code since resolution is complete. */
9978 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9979 tail
->next
= (*code
)->next
;
9980 /* Overwrite 'code' because this would place the intrinsic assignment
9981 before the temporary for the lhs is created. */
9982 gfc_free_expr ((*code
)->expr1
);
9983 gfc_free_expr ((*code
)->expr2
);
9989 component_assignment_level
--;
9993 /* Given a block of code, recursively resolve everything pointed to by this
9997 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9999 int omp_workshare_save
;
10000 int forall_save
, do_concurrent_save
;
10004 frame
.prev
= cs_base
;
10008 find_reachable_labels (code
);
10010 for (; code
; code
= code
->next
)
10012 frame
.current
= code
;
10013 forall_save
= forall_flag
;
10014 do_concurrent_save
= gfc_do_concurrent_flag
;
10016 if (code
->op
== EXEC_FORALL
)
10019 gfc_resolve_forall (code
, ns
, forall_save
);
10022 else if (code
->block
)
10024 omp_workshare_save
= -1;
10027 case EXEC_OACC_PARALLEL_LOOP
:
10028 case EXEC_OACC_PARALLEL
:
10029 case EXEC_OACC_KERNELS_LOOP
:
10030 case EXEC_OACC_KERNELS
:
10031 case EXEC_OACC_DATA
:
10032 case EXEC_OACC_HOST_DATA
:
10033 case EXEC_OACC_LOOP
:
10034 gfc_resolve_oacc_blocks (code
, ns
);
10036 case EXEC_OMP_PARALLEL_WORKSHARE
:
10037 omp_workshare_save
= omp_workshare_flag
;
10038 omp_workshare_flag
= 1;
10039 gfc_resolve_omp_parallel_blocks (code
, ns
);
10041 case EXEC_OMP_PARALLEL
:
10042 case EXEC_OMP_PARALLEL_DO
:
10043 case EXEC_OMP_PARALLEL_DO_SIMD
:
10044 case EXEC_OMP_PARALLEL_SECTIONS
:
10045 case EXEC_OMP_TARGET_TEAMS
:
10046 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10047 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10048 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10049 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10050 case EXEC_OMP_TASK
:
10051 case EXEC_OMP_TEAMS
:
10052 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10053 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10054 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10055 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10056 omp_workshare_save
= omp_workshare_flag
;
10057 omp_workshare_flag
= 0;
10058 gfc_resolve_omp_parallel_blocks (code
, ns
);
10060 case EXEC_OMP_DISTRIBUTE
:
10061 case EXEC_OMP_DISTRIBUTE_SIMD
:
10063 case EXEC_OMP_DO_SIMD
:
10064 case EXEC_OMP_SIMD
:
10065 gfc_resolve_omp_do_blocks (code
, ns
);
10067 case EXEC_SELECT_TYPE
:
10068 /* Blocks are handled in resolve_select_type because we have
10069 to transform the SELECT TYPE into ASSOCIATE first. */
10071 case EXEC_DO_CONCURRENT
:
10072 gfc_do_concurrent_flag
= 1;
10073 gfc_resolve_blocks (code
->block
, ns
);
10074 gfc_do_concurrent_flag
= 2;
10076 case EXEC_OMP_WORKSHARE
:
10077 omp_workshare_save
= omp_workshare_flag
;
10078 omp_workshare_flag
= 1;
10081 gfc_resolve_blocks (code
->block
, ns
);
10085 if (omp_workshare_save
!= -1)
10086 omp_workshare_flag
= omp_workshare_save
;
10090 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10091 t
= gfc_resolve_expr (code
->expr1
);
10092 forall_flag
= forall_save
;
10093 gfc_do_concurrent_flag
= do_concurrent_save
;
10095 if (!gfc_resolve_expr (code
->expr2
))
10098 if (code
->op
== EXEC_ALLOCATE
10099 && !gfc_resolve_expr (code
->expr3
))
10105 case EXEC_END_BLOCK
:
10106 case EXEC_END_NESTED_BLOCK
:
10110 case EXEC_ERROR_STOP
:
10112 case EXEC_CONTINUE
:
10114 case EXEC_ASSIGN_CALL
:
10117 case EXEC_CRITICAL
:
10118 resolve_critical (code
);
10121 case EXEC_SYNC_ALL
:
10122 case EXEC_SYNC_IMAGES
:
10123 case EXEC_SYNC_MEMORY
:
10124 resolve_sync (code
);
10129 resolve_lock_unlock (code
);
10133 /* Keep track of which entry we are up to. */
10134 current_entry_id
= code
->ext
.entry
->id
;
10138 resolve_where (code
, NULL
);
10142 if (code
->expr1
!= NULL
)
10144 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10145 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10146 "INTEGER variable", &code
->expr1
->where
);
10147 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10148 gfc_error ("Variable %qs has not been assigned a target "
10149 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10150 &code
->expr1
->where
);
10153 resolve_branch (code
->label1
, code
);
10157 if (code
->expr1
!= NULL
10158 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10159 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10160 "INTEGER return specifier", &code
->expr1
->where
);
10163 case EXEC_INIT_ASSIGN
:
10164 case EXEC_END_PROCEDURE
:
10171 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10173 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10174 && code
->expr1
->value
.function
.isym
10175 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10176 remove_caf_get_intrinsic (code
->expr1
);
10178 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10182 if (resolve_ordinary_assign (code
, ns
))
10184 if (code
->op
== EXEC_COMPCALL
)
10190 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10191 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10192 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10193 generate_component_assignments (&code
, ns
);
10197 case EXEC_LABEL_ASSIGN
:
10198 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10199 gfc_error ("Label %d referenced at %L is never defined",
10200 code
->label1
->value
, &code
->label1
->where
);
10202 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10203 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10204 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10205 != gfc_default_integer_kind
10206 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10207 gfc_error ("ASSIGN statement at %L requires a scalar "
10208 "default INTEGER variable", &code
->expr1
->where
);
10211 case EXEC_POINTER_ASSIGN
:
10218 /* This is both a variable definition and pointer assignment
10219 context, so check both of them. For rank remapping, a final
10220 array ref may be present on the LHS and fool gfc_expr_attr
10221 used in gfc_check_vardef_context. Remove it. */
10222 e
= remove_last_array_ref (code
->expr1
);
10223 t
= gfc_check_vardef_context (e
, true, false, false,
10224 _("pointer assignment"));
10226 t
= gfc_check_vardef_context (e
, false, false, false,
10227 _("pointer assignment"));
10232 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10236 case EXEC_ARITHMETIC_IF
:
10238 && code
->expr1
->ts
.type
!= BT_INTEGER
10239 && code
->expr1
->ts
.type
!= BT_REAL
)
10240 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10241 "expression", &code
->expr1
->where
);
10243 resolve_branch (code
->label1
, code
);
10244 resolve_branch (code
->label2
, code
);
10245 resolve_branch (code
->label3
, code
);
10249 if (t
&& code
->expr1
!= NULL
10250 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10251 || code
->expr1
->rank
!= 0))
10252 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10253 &code
->expr1
->where
);
10258 resolve_call (code
);
10261 case EXEC_COMPCALL
:
10263 resolve_typebound_subroutine (code
);
10266 case EXEC_CALL_PPC
:
10267 resolve_ppc_call (code
);
10271 /* Select is complicated. Also, a SELECT construct could be
10272 a transformed computed GOTO. */
10273 resolve_select (code
, false);
10276 case EXEC_SELECT_TYPE
:
10277 resolve_select_type (code
, ns
);
10281 resolve_block_construct (code
);
10285 if (code
->ext
.iterator
!= NULL
)
10287 gfc_iterator
*iter
= code
->ext
.iterator
;
10288 if (gfc_resolve_iterator (iter
, true, false))
10289 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10293 case EXEC_DO_WHILE
:
10294 if (code
->expr1
== NULL
)
10295 gfc_internal_error ("gfc_resolve_code(): No expression on "
10298 && (code
->expr1
->rank
!= 0
10299 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10300 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10301 "a scalar LOGICAL expression", &code
->expr1
->where
);
10304 case EXEC_ALLOCATE
:
10306 resolve_allocate_deallocate (code
, "ALLOCATE");
10310 case EXEC_DEALLOCATE
:
10312 resolve_allocate_deallocate (code
, "DEALLOCATE");
10317 if (!gfc_resolve_open (code
->ext
.open
))
10320 resolve_branch (code
->ext
.open
->err
, code
);
10324 if (!gfc_resolve_close (code
->ext
.close
))
10327 resolve_branch (code
->ext
.close
->err
, code
);
10330 case EXEC_BACKSPACE
:
10334 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10337 resolve_branch (code
->ext
.filepos
->err
, code
);
10341 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10344 resolve_branch (code
->ext
.inquire
->err
, code
);
10347 case EXEC_IOLENGTH
:
10348 gcc_assert (code
->ext
.inquire
!= NULL
);
10349 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10352 resolve_branch (code
->ext
.inquire
->err
, code
);
10356 if (!gfc_resolve_wait (code
->ext
.wait
))
10359 resolve_branch (code
->ext
.wait
->err
, code
);
10360 resolve_branch (code
->ext
.wait
->end
, code
);
10361 resolve_branch (code
->ext
.wait
->eor
, code
);
10366 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10369 resolve_branch (code
->ext
.dt
->err
, code
);
10370 resolve_branch (code
->ext
.dt
->end
, code
);
10371 resolve_branch (code
->ext
.dt
->eor
, code
);
10374 case EXEC_TRANSFER
:
10375 resolve_transfer (code
);
10378 case EXEC_DO_CONCURRENT
:
10380 resolve_forall_iterators (code
->ext
.forall_iterator
);
10382 if (code
->expr1
!= NULL
10383 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10384 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10385 "expression", &code
->expr1
->where
);
10388 case EXEC_OACC_PARALLEL_LOOP
:
10389 case EXEC_OACC_PARALLEL
:
10390 case EXEC_OACC_KERNELS_LOOP
:
10391 case EXEC_OACC_KERNELS
:
10392 case EXEC_OACC_DATA
:
10393 case EXEC_OACC_HOST_DATA
:
10394 case EXEC_OACC_LOOP
:
10395 case EXEC_OACC_UPDATE
:
10396 case EXEC_OACC_WAIT
:
10397 case EXEC_OACC_CACHE
:
10398 case EXEC_OACC_ENTER_DATA
:
10399 case EXEC_OACC_EXIT_DATA
:
10400 gfc_resolve_oacc_directive (code
, ns
);
10403 case EXEC_OMP_ATOMIC
:
10404 case EXEC_OMP_BARRIER
:
10405 case EXEC_OMP_CANCEL
:
10406 case EXEC_OMP_CANCELLATION_POINT
:
10407 case EXEC_OMP_CRITICAL
:
10408 case EXEC_OMP_FLUSH
:
10409 case EXEC_OMP_DISTRIBUTE
:
10410 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10411 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10412 case EXEC_OMP_DISTRIBUTE_SIMD
:
10414 case EXEC_OMP_DO_SIMD
:
10415 case EXEC_OMP_MASTER
:
10416 case EXEC_OMP_ORDERED
:
10417 case EXEC_OMP_SECTIONS
:
10418 case EXEC_OMP_SIMD
:
10419 case EXEC_OMP_SINGLE
:
10420 case EXEC_OMP_TARGET
:
10421 case EXEC_OMP_TARGET_DATA
:
10422 case EXEC_OMP_TARGET_TEAMS
:
10423 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10424 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10425 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10426 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10427 case EXEC_OMP_TARGET_UPDATE
:
10428 case EXEC_OMP_TASK
:
10429 case EXEC_OMP_TASKGROUP
:
10430 case EXEC_OMP_TASKWAIT
:
10431 case EXEC_OMP_TASKYIELD
:
10432 case EXEC_OMP_TEAMS
:
10433 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10434 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10435 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10436 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10437 case EXEC_OMP_WORKSHARE
:
10438 gfc_resolve_omp_directive (code
, ns
);
10441 case EXEC_OMP_PARALLEL
:
10442 case EXEC_OMP_PARALLEL_DO
:
10443 case EXEC_OMP_PARALLEL_DO_SIMD
:
10444 case EXEC_OMP_PARALLEL_SECTIONS
:
10445 case EXEC_OMP_PARALLEL_WORKSHARE
:
10446 omp_workshare_save
= omp_workshare_flag
;
10447 omp_workshare_flag
= 0;
10448 gfc_resolve_omp_directive (code
, ns
);
10449 omp_workshare_flag
= omp_workshare_save
;
10453 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10457 cs_base
= frame
.prev
;
10461 /* Resolve initial values and make sure they are compatible with
10465 resolve_values (gfc_symbol
*sym
)
10469 if (sym
->value
== NULL
)
10472 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10473 t
= resolve_structure_cons (sym
->value
, 1);
10475 t
= gfc_resolve_expr (sym
->value
);
10480 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10484 /* Verify any BIND(C) derived types in the namespace so we can report errors
10485 for them once, rather than for each variable declared of that type. */
10488 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10490 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10491 && derived_sym
->attr
.is_bind_c
== 1)
10492 verify_bind_c_derived_type (derived_sym
);
10498 /* Verify that any binding labels used in a given namespace do not collide
10499 with the names or binding labels of any global symbols. Multiple INTERFACE
10500 for the same procedure are permitted. */
10503 gfc_verify_binding_labels (gfc_symbol
*sym
)
10506 const char *module
;
10508 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10509 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10512 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10515 module
= sym
->module
;
10516 else if (sym
->ns
&& sym
->ns
->proc_name
10517 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10518 module
= sym
->ns
->proc_name
->name
;
10519 else if (sym
->ns
&& sym
->ns
->parent
10520 && sym
->ns
&& sym
->ns
->parent
->proc_name
10521 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10522 module
= sym
->ns
->parent
->proc_name
->name
;
10528 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10531 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10532 gsym
->where
= sym
->declared_at
;
10533 gsym
->sym_name
= sym
->name
;
10534 gsym
->binding_label
= sym
->binding_label
;
10535 gsym
->ns
= sym
->ns
;
10536 gsym
->mod_name
= module
;
10537 if (sym
->attr
.function
)
10538 gsym
->type
= GSYM_FUNCTION
;
10539 else if (sym
->attr
.subroutine
)
10540 gsym
->type
= GSYM_SUBROUTINE
;
10541 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10542 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10546 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10548 gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
10549 "identifier as entity at %L", sym
->name
,
10550 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10551 /* Clear the binding label to prevent checking multiple times. */
10552 sym
->binding_label
= NULL
;
10555 else if (sym
->attr
.flavor
== FL_VARIABLE
10556 && (strcmp (module
, gsym
->mod_name
) != 0
10557 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10559 /* This can only happen if the variable is defined in a module - if it
10560 isn't the same module, reject it. */
10561 gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
10562 "the same global identifier as entity at %L from module %s",
10563 sym
->name
, module
, sym
->binding_label
,
10564 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10565 sym
->binding_label
= NULL
;
10567 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10568 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10569 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10570 && sym
!= gsym
->ns
->proc_name
10571 && (module
!= gsym
->mod_name
10572 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10573 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10575 /* Print an error if the procedure is defined multiple times; we have to
10576 exclude references to the same procedure via module association or
10577 multiple checks for the same procedure. */
10578 gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
10579 "global identifier as entity at %L", sym
->name
,
10580 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10581 sym
->binding_label
= NULL
;
10586 /* Resolve an index expression. */
10589 resolve_index_expr (gfc_expr
*e
)
10591 if (!gfc_resolve_expr (e
))
10594 if (!gfc_simplify_expr (e
, 0))
10597 if (!gfc_specification_expr (e
))
10604 /* Resolve a charlen structure. */
10607 resolve_charlen (gfc_charlen
*cl
)
10610 bool saved_specification_expr
;
10616 saved_specification_expr
= specification_expr
;
10617 specification_expr
= true;
10619 if (cl
->length_from_typespec
)
10621 if (!gfc_resolve_expr (cl
->length
))
10623 specification_expr
= saved_specification_expr
;
10627 if (!gfc_simplify_expr (cl
->length
, 0))
10629 specification_expr
= saved_specification_expr
;
10636 if (!resolve_index_expr (cl
->length
))
10638 specification_expr
= saved_specification_expr
;
10643 /* "If the character length parameter value evaluates to a negative
10644 value, the length of character entities declared is zero." */
10645 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10647 if (warn_surprising
)
10648 gfc_warning_now (OPT_Wsurprising
,
10649 "CHARACTER variable at %L has negative length %d,"
10650 " the length has been set to zero",
10651 &cl
->length
->where
, i
);
10652 gfc_replace_expr (cl
->length
,
10653 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10656 /* Check that the character length is not too large. */
10657 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10658 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10659 && cl
->length
->ts
.type
== BT_INTEGER
10660 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10662 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10663 specification_expr
= saved_specification_expr
;
10667 specification_expr
= saved_specification_expr
;
10672 /* Test for non-constant shape arrays. */
10675 is_non_constant_shape_array (gfc_symbol
*sym
)
10681 not_constant
= false;
10682 if (sym
->as
!= NULL
)
10684 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10685 has not been simplified; parameter array references. Do the
10686 simplification now. */
10687 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10689 e
= sym
->as
->lower
[i
];
10690 if (e
&& (!resolve_index_expr(e
)
10691 || !gfc_is_constant_expr (e
)))
10692 not_constant
= true;
10693 e
= sym
->as
->upper
[i
];
10694 if (e
&& (!resolve_index_expr(e
)
10695 || !gfc_is_constant_expr (e
)))
10696 not_constant
= true;
10699 return not_constant
;
10702 /* Given a symbol and an initialization expression, add code to initialize
10703 the symbol to the function entry. */
10705 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10709 gfc_namespace
*ns
= sym
->ns
;
10711 /* Search for the function namespace if this is a contained
10712 function without an explicit result. */
10713 if (sym
->attr
.function
&& sym
== sym
->result
10714 && sym
->name
!= sym
->ns
->proc_name
->name
)
10716 ns
= ns
->contained
;
10717 for (;ns
; ns
= ns
->sibling
)
10718 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10724 gfc_free_expr (init
);
10728 /* Build an l-value expression for the result. */
10729 lval
= gfc_lval_expr_from_sym (sym
);
10731 /* Add the code at scope entry. */
10732 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10733 init_st
->next
= ns
->code
;
10734 ns
->code
= init_st
;
10736 /* Assign the default initializer to the l-value. */
10737 init_st
->loc
= sym
->declared_at
;
10738 init_st
->expr1
= lval
;
10739 init_st
->expr2
= init
;
10742 /* Assign the default initializer to a derived type variable or result. */
10745 apply_default_init (gfc_symbol
*sym
)
10747 gfc_expr
*init
= NULL
;
10749 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10752 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10753 init
= gfc_default_initializer (&sym
->ts
);
10755 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10758 build_init_assign (sym
, init
);
10759 sym
->attr
.referenced
= 1;
10762 /* Build an initializer for a local integer, real, complex, logical, or
10763 character variable, based on the command line flags finit-local-zero,
10764 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10765 null if the symbol should not have a default initialization. */
10767 build_default_init_expr (gfc_symbol
*sym
)
10770 gfc_expr
*init_expr
;
10773 /* These symbols should never have a default initialization. */
10774 if (sym
->attr
.allocatable
10775 || sym
->attr
.external
10777 || sym
->attr
.pointer
10778 || sym
->attr
.in_equivalence
10779 || sym
->attr
.in_common
10782 || sym
->attr
.cray_pointee
10783 || sym
->attr
.cray_pointer
10787 /* Now we'll try to build an initializer expression. */
10788 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10789 &sym
->declared_at
);
10791 /* We will only initialize integers, reals, complex, logicals, and
10792 characters, and only if the corresponding command-line flags
10793 were set. Otherwise, we free init_expr and return null. */
10794 switch (sym
->ts
.type
)
10797 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10798 mpz_set_si (init_expr
->value
.integer
,
10799 gfc_option
.flag_init_integer_value
);
10802 gfc_free_expr (init_expr
);
10808 switch (flag_init_real
)
10810 case GFC_INIT_REAL_SNAN
:
10811 init_expr
->is_snan
= 1;
10812 /* Fall through. */
10813 case GFC_INIT_REAL_NAN
:
10814 mpfr_set_nan (init_expr
->value
.real
);
10817 case GFC_INIT_REAL_INF
:
10818 mpfr_set_inf (init_expr
->value
.real
, 1);
10821 case GFC_INIT_REAL_NEG_INF
:
10822 mpfr_set_inf (init_expr
->value
.real
, -1);
10825 case GFC_INIT_REAL_ZERO
:
10826 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10830 gfc_free_expr (init_expr
);
10837 switch (flag_init_real
)
10839 case GFC_INIT_REAL_SNAN
:
10840 init_expr
->is_snan
= 1;
10841 /* Fall through. */
10842 case GFC_INIT_REAL_NAN
:
10843 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10844 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10847 case GFC_INIT_REAL_INF
:
10848 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10849 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10852 case GFC_INIT_REAL_NEG_INF
:
10853 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10854 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10857 case GFC_INIT_REAL_ZERO
:
10858 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10862 gfc_free_expr (init_expr
);
10869 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10870 init_expr
->value
.logical
= 0;
10871 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10872 init_expr
->value
.logical
= 1;
10875 gfc_free_expr (init_expr
);
10881 /* For characters, the length must be constant in order to
10882 create a default initializer. */
10883 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10884 && sym
->ts
.u
.cl
->length
10885 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10887 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10888 init_expr
->value
.character
.length
= char_len
;
10889 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10890 for (i
= 0; i
< char_len
; i
++)
10891 init_expr
->value
.character
.string
[i
]
10892 = (unsigned char) gfc_option
.flag_init_character_value
;
10896 gfc_free_expr (init_expr
);
10899 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10900 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
10902 gfc_actual_arglist
*arg
;
10903 init_expr
= gfc_get_expr ();
10904 init_expr
->where
= sym
->declared_at
;
10905 init_expr
->ts
= sym
->ts
;
10906 init_expr
->expr_type
= EXPR_FUNCTION
;
10907 init_expr
->value
.function
.isym
=
10908 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10909 init_expr
->value
.function
.name
= "repeat";
10910 arg
= gfc_get_actual_arglist ();
10911 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10913 arg
->expr
->value
.character
.string
[0]
10914 = gfc_option
.flag_init_character_value
;
10915 arg
->next
= gfc_get_actual_arglist ();
10916 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10917 init_expr
->value
.function
.actual
= arg
;
10922 gfc_free_expr (init_expr
);
10928 /* Add an initialization expression to a local variable. */
10930 apply_default_init_local (gfc_symbol
*sym
)
10932 gfc_expr
*init
= NULL
;
10934 /* The symbol should be a variable or a function return value. */
10935 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10936 || (sym
->attr
.function
&& sym
->result
!= sym
))
10939 /* Try to build the initializer expression. If we can't initialize
10940 this symbol, then init will be NULL. */
10941 init
= build_default_init_expr (sym
);
10945 /* For saved variables, we don't want to add an initializer at function
10946 entry, so we just add a static initializer. Note that automatic variables
10947 are stack allocated even with -fno-automatic; we have also to exclude
10948 result variable, which are also nonstatic. */
10949 if (sym
->attr
.save
|| sym
->ns
->save_all
10950 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
10951 && !sym
->ns
->proc_name
->attr
.recursive
10952 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10954 /* Don't clobber an existing initializer! */
10955 gcc_assert (sym
->value
== NULL
);
10960 build_init_assign (sym
, init
);
10964 /* Resolution of common features of flavors variable and procedure. */
10967 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10969 gfc_array_spec
*as
;
10971 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10972 as
= CLASS_DATA (sym
)->as
;
10976 /* Constraints on deferred shape variable. */
10977 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10979 bool pointer
, allocatable
, dimension
;
10981 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10983 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10984 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10985 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10989 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10990 allocatable
= sym
->attr
.allocatable
;
10991 dimension
= sym
->attr
.dimension
;
10996 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10998 gfc_error ("Allocatable array %qs at %L must have a deferred "
10999 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11002 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11003 "%qs at %L may not be ALLOCATABLE",
11004 sym
->name
, &sym
->declared_at
))
11008 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11010 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11011 "assumed rank", sym
->name
, &sym
->declared_at
);
11017 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11018 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11020 gfc_error ("Array %qs at %L cannot have a deferred shape",
11021 sym
->name
, &sym
->declared_at
);
11026 /* Constraints on polymorphic variables. */
11027 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11030 if (sym
->attr
.class_ok
11031 && !sym
->attr
.select_type_temporary
11032 && !UNLIMITED_POLY (sym
)
11033 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11035 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11036 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11037 &sym
->declared_at
);
11042 /* Assume that use associated symbols were checked in the module ns.
11043 Class-variables that are associate-names are also something special
11044 and excepted from the test. */
11045 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11047 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11048 "or pointer", sym
->name
, &sym
->declared_at
);
11057 /* Additional checks for symbols with flavor variable and derived
11058 type. To be called from resolve_fl_variable. */
11061 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11063 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11065 /* Check to see if a derived type is blocked from being host
11066 associated by the presence of another class I symbol in the same
11067 namespace. 14.6.1.3 of the standard and the discussion on
11068 comp.lang.fortran. */
11069 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11070 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11073 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11074 if (s
&& s
->attr
.generic
)
11075 s
= gfc_find_dt_in_generic (s
);
11076 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11078 gfc_error_1 ("The type '%s' cannot be host associated at %L "
11079 "because it is blocked by an incompatible object "
11080 "of the same name declared at %L",
11081 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11087 /* 4th constraint in section 11.3: "If an object of a type for which
11088 component-initialization is specified (R429) appears in the
11089 specification-part of a module and does not have the ALLOCATABLE
11090 or POINTER attribute, the object shall have the SAVE attribute."
11092 The check for initializers is performed with
11093 gfc_has_default_initializer because gfc_default_initializer generates
11094 a hidden default for allocatable components. */
11095 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11096 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11097 && !sym
->ns
->save_all
&& !sym
->attr
.save
11098 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11099 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11100 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11101 "%qs at %L, needed due to the default "
11102 "initialization", sym
->name
, &sym
->declared_at
))
11105 /* Assign default initializer. */
11106 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11107 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11109 sym
->value
= gfc_default_initializer (&sym
->ts
);
11116 /* Resolve symbols with flavor variable. */
11119 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11121 int no_init_flag
, automatic_flag
;
11123 const char *auto_save_msg
;
11124 bool saved_specification_expr
;
11126 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11129 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11132 /* Set this flag to check that variables are parameters of all entries.
11133 This check is effected by the call to gfc_resolve_expr through
11134 is_non_constant_shape_array. */
11135 saved_specification_expr
= specification_expr
;
11136 specification_expr
= true;
11138 if (sym
->ns
->proc_name
11139 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11140 || sym
->ns
->proc_name
->attr
.is_main_program
)
11141 && !sym
->attr
.use_assoc
11142 && !sym
->attr
.allocatable
11143 && !sym
->attr
.pointer
11144 && is_non_constant_shape_array (sym
))
11146 /* The shape of a main program or module array needs to be
11148 gfc_error ("The module or main program array '%s' at %L must "
11149 "have constant shape", sym
->name
, &sym
->declared_at
);
11150 specification_expr
= saved_specification_expr
;
11154 /* Constraints on deferred type parameter. */
11155 if (sym
->ts
.deferred
11156 && !(sym
->attr
.pointer
11157 || sym
->attr
.allocatable
11158 || sym
->attr
.omp_udr_artificial_var
))
11160 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11161 "requires either the pointer or allocatable attribute",
11162 sym
->name
, &sym
->declared_at
);
11163 specification_expr
= saved_specification_expr
;
11167 if (sym
->ts
.type
== BT_CHARACTER
)
11169 /* Make sure that character string variables with assumed length are
11170 dummy arguments. */
11171 e
= sym
->ts
.u
.cl
->length
;
11172 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11173 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11174 && !sym
->attr
.omp_udr_artificial_var
)
11176 gfc_error ("Entity with assumed character length at %L must be a "
11177 "dummy argument or a PARAMETER", &sym
->declared_at
);
11178 specification_expr
= saved_specification_expr
;
11182 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11184 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11185 specification_expr
= saved_specification_expr
;
11189 if (!gfc_is_constant_expr (e
)
11190 && !(e
->expr_type
== EXPR_VARIABLE
11191 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11193 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11194 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11195 || sym
->ns
->proc_name
->attr
.is_main_program
))
11197 gfc_error ("'%s' at %L must have constant character length "
11198 "in this context", sym
->name
, &sym
->declared_at
);
11199 specification_expr
= saved_specification_expr
;
11202 if (sym
->attr
.in_common
)
11204 gfc_error ("COMMON variable %qs at %L must have constant "
11205 "character length", sym
->name
, &sym
->declared_at
);
11206 specification_expr
= saved_specification_expr
;
11212 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11213 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11215 /* Determine if the symbol may not have an initializer. */
11216 no_init_flag
= automatic_flag
= 0;
11217 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11218 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11220 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11221 && is_non_constant_shape_array (sym
))
11223 no_init_flag
= automatic_flag
= 1;
11225 /* Also, they must not have the SAVE attribute.
11226 SAVE_IMPLICIT is checked below. */
11227 if (sym
->as
&& sym
->attr
.codimension
)
11229 int corank
= sym
->as
->corank
;
11230 sym
->as
->corank
= 0;
11231 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11232 sym
->as
->corank
= corank
;
11234 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11236 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11237 specification_expr
= saved_specification_expr
;
11242 /* Ensure that any initializer is simplified. */
11244 gfc_simplify_expr (sym
->value
, 1);
11246 /* Reject illegal initializers. */
11247 if (!sym
->mark
&& sym
->value
)
11249 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11250 && CLASS_DATA (sym
)->attr
.allocatable
))
11251 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11252 sym
->name
, &sym
->declared_at
);
11253 else if (sym
->attr
.external
)
11254 gfc_error ("External %qs at %L cannot have an initializer",
11255 sym
->name
, &sym
->declared_at
);
11256 else if (sym
->attr
.dummy
11257 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11258 gfc_error ("Dummy %qs at %L cannot have an initializer",
11259 sym
->name
, &sym
->declared_at
);
11260 else if (sym
->attr
.intrinsic
)
11261 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11262 sym
->name
, &sym
->declared_at
);
11263 else if (sym
->attr
.result
)
11264 gfc_error ("Function result %qs at %L cannot have an initializer",
11265 sym
->name
, &sym
->declared_at
);
11266 else if (automatic_flag
)
11267 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11268 sym
->name
, &sym
->declared_at
);
11270 goto no_init_error
;
11271 specification_expr
= saved_specification_expr
;
11276 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11278 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11279 specification_expr
= saved_specification_expr
;
11283 specification_expr
= saved_specification_expr
;
11288 /* Resolve a procedure. */
11291 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11293 gfc_formal_arglist
*arg
;
11295 if (sym
->attr
.function
11296 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11299 if (sym
->ts
.type
== BT_CHARACTER
)
11301 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11303 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11304 && !resolve_charlen (cl
))
11307 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11308 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11310 gfc_error ("Character-valued statement function %qs at %L must "
11311 "have constant length", sym
->name
, &sym
->declared_at
);
11316 /* Ensure that derived type for are not of a private type. Internal
11317 module procedures are excluded by 2.2.3.3 - i.e., they are not
11318 externally accessible and can access all the objects accessible in
11320 if (!(sym
->ns
->parent
11321 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11322 && gfc_check_symbol_access (sym
))
11324 gfc_interface
*iface
;
11326 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11329 && arg
->sym
->ts
.type
== BT_DERIVED
11330 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11331 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11332 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11333 "and cannot be a dummy argument"
11334 " of %qs, which is PUBLIC at %L",
11335 arg
->sym
->name
, sym
->name
,
11336 &sym
->declared_at
))
11338 /* Stop this message from recurring. */
11339 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11344 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11345 PRIVATE to the containing module. */
11346 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11348 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11351 && arg
->sym
->ts
.type
== BT_DERIVED
11352 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11353 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11354 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11355 "PUBLIC interface %qs at %L "
11356 "takes dummy arguments of %qs which "
11357 "is PRIVATE", iface
->sym
->name
,
11358 sym
->name
, &iface
->sym
->declared_at
,
11359 gfc_typename(&arg
->sym
->ts
)))
11361 /* Stop this message from recurring. */
11362 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11369 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11370 && !sym
->attr
.proc_pointer
)
11372 gfc_error ("Function %qs at %L cannot have an initializer",
11373 sym
->name
, &sym
->declared_at
);
11377 /* An external symbol may not have an initializer because it is taken to be
11378 a procedure. Exception: Procedure Pointers. */
11379 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11381 gfc_error ("External object %qs at %L may not have an initializer",
11382 sym
->name
, &sym
->declared_at
);
11386 /* An elemental function is required to return a scalar 12.7.1 */
11387 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11389 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11390 "result", sym
->name
, &sym
->declared_at
);
11391 /* Reset so that the error only occurs once. */
11392 sym
->attr
.elemental
= 0;
11396 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11397 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11399 gfc_error ("Statement function %qs at %L may not have pointer or "
11400 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11404 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11405 char-len-param shall not be array-valued, pointer-valued, recursive
11406 or pure. ....snip... A character value of * may only be used in the
11407 following ways: (i) Dummy arg of procedure - dummy associates with
11408 actual length; (ii) To declare a named constant; or (iii) External
11409 function - but length must be declared in calling scoping unit. */
11410 if (sym
->attr
.function
11411 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11412 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11414 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11415 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11417 if (sym
->as
&& sym
->as
->rank
)
11418 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11419 "array-valued", sym
->name
, &sym
->declared_at
);
11421 if (sym
->attr
.pointer
)
11422 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11423 "pointer-valued", sym
->name
, &sym
->declared_at
);
11425 if (sym
->attr
.pure
)
11426 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11427 "pure", sym
->name
, &sym
->declared_at
);
11429 if (sym
->attr
.recursive
)
11430 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11431 "recursive", sym
->name
, &sym
->declared_at
);
11436 /* Appendix B.2 of the standard. Contained functions give an
11437 error anyway. Deferred character length is an F2003 feature.
11438 Don't warn on intrinsic conversion functions, which start
11439 with two underscores. */
11440 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11441 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11442 gfc_notify_std (GFC_STD_F95_OBS
,
11443 "CHARACTER(*) function %qs at %L",
11444 sym
->name
, &sym
->declared_at
);
11447 /* F2008, C1218. */
11448 if (sym
->attr
.elemental
)
11450 if (sym
->attr
.proc_pointer
)
11452 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11453 sym
->name
, &sym
->declared_at
);
11456 if (sym
->attr
.dummy
)
11458 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11459 sym
->name
, &sym
->declared_at
);
11464 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11466 gfc_formal_arglist
*curr_arg
;
11467 int has_non_interop_arg
= 0;
11469 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11470 sym
->common_block
))
11472 /* Clear these to prevent looking at them again if there was an
11474 sym
->attr
.is_bind_c
= 0;
11475 sym
->attr
.is_c_interop
= 0;
11476 sym
->ts
.is_c_interop
= 0;
11480 /* So far, no errors have been found. */
11481 sym
->attr
.is_c_interop
= 1;
11482 sym
->ts
.is_c_interop
= 1;
11485 curr_arg
= gfc_sym_get_dummy_args (sym
);
11486 while (curr_arg
!= NULL
)
11488 /* Skip implicitly typed dummy args here. */
11489 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11490 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11491 /* If something is found to fail, record the fact so we
11492 can mark the symbol for the procedure as not being
11493 BIND(C) to try and prevent multiple errors being
11495 has_non_interop_arg
= 1;
11497 curr_arg
= curr_arg
->next
;
11500 /* See if any of the arguments were not interoperable and if so, clear
11501 the procedure symbol to prevent duplicate error messages. */
11502 if (has_non_interop_arg
!= 0)
11504 sym
->attr
.is_c_interop
= 0;
11505 sym
->ts
.is_c_interop
= 0;
11506 sym
->attr
.is_bind_c
= 0;
11510 if (!sym
->attr
.proc_pointer
)
11512 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11514 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11515 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11518 if (sym
->attr
.intent
)
11520 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11521 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11524 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11526 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11527 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11530 if (sym
->attr
.external
&& sym
->attr
.function
11531 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11532 || sym
->attr
.contained
))
11534 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11535 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11538 if (strcmp ("ppr@", sym
->name
) == 0)
11540 gfc_error ("Procedure pointer result %qs at %L "
11541 "is missing the pointer attribute",
11542 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11547 /* Assume that a procedure whose body is not known has references
11548 to external arrays. */
11549 if (sym
->attr
.if_source
!= IFSRC_DECL
)
11550 sym
->attr
.array_outer_dependency
= 1;
11556 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11557 been defined and we now know their defined arguments, check that they fulfill
11558 the requirements of the standard for procedures used as finalizers. */
11561 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11563 gfc_finalizer
* list
;
11564 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11565 bool result
= true;
11566 bool seen_scalar
= false;
11569 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11572 gfc_resolve_finalizers (parent
, finalizable
);
11574 /* Return early when not finalizable. Additionally, ensure that derived-type
11575 components have a their finalizables resolved. */
11576 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11578 bool has_final
= false;
11579 for (c
= derived
->components
; c
; c
= c
->next
)
11580 if (c
->ts
.type
== BT_DERIVED
11581 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11583 bool has_final2
= false;
11584 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11585 return false; /* Error. */
11586 has_final
= has_final
|| has_final2
;
11591 *finalizable
= false;
11596 /* Walk over the list of finalizer-procedures, check them, and if any one
11597 does not fit in with the standard's definition, print an error and remove
11598 it from the list. */
11599 prev_link
= &derived
->f2k_derived
->finalizers
;
11600 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11602 gfc_formal_arglist
*dummy_args
;
11607 /* Skip this finalizer if we already resolved it. */
11608 if (list
->proc_tree
)
11610 prev_link
= &(list
->next
);
11614 /* Check this exists and is a SUBROUTINE. */
11615 if (!list
->proc_sym
->attr
.subroutine
)
11617 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
11618 list
->proc_sym
->name
, &list
->where
);
11622 /* We should have exactly one argument. */
11623 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11624 if (!dummy_args
|| dummy_args
->next
)
11626 gfc_error ("FINAL procedure at %L must have exactly one argument",
11630 arg
= dummy_args
->sym
;
11632 /* This argument must be of our type. */
11633 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11635 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
11636 &arg
->declared_at
, derived
->name
);
11640 /* It must neither be a pointer nor allocatable nor optional. */
11641 if (arg
->attr
.pointer
)
11643 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11644 &arg
->declared_at
);
11647 if (arg
->attr
.allocatable
)
11649 gfc_error ("Argument of FINAL procedure at %L must not be"
11650 " ALLOCATABLE", &arg
->declared_at
);
11653 if (arg
->attr
.optional
)
11655 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11656 &arg
->declared_at
);
11660 /* It must not be INTENT(OUT). */
11661 if (arg
->attr
.intent
== INTENT_OUT
)
11663 gfc_error ("Argument of FINAL procedure at %L must not be"
11664 " INTENT(OUT)", &arg
->declared_at
);
11668 /* Warn if the procedure is non-scalar and not assumed shape. */
11669 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11670 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11671 gfc_warning (OPT_Wsurprising
,
11672 "Non-scalar FINAL procedure at %L should have assumed"
11673 " shape argument", &arg
->declared_at
);
11675 /* Check that it does not match in kind and rank with a FINAL procedure
11676 defined earlier. To really loop over the *earlier* declarations,
11677 we need to walk the tail of the list as new ones were pushed at the
11679 /* TODO: Handle kind parameters once they are implemented. */
11680 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11681 for (i
= list
->next
; i
; i
= i
->next
)
11683 gfc_formal_arglist
*dummy_args
;
11685 /* Argument list might be empty; that is an error signalled earlier,
11686 but we nevertheless continued resolving. */
11687 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11690 gfc_symbol
* i_arg
= dummy_args
->sym
;
11691 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11692 if (i_rank
== my_rank
)
11694 gfc_error ("FINAL procedure %qs declared at %L has the same"
11695 " rank (%d) as %qs",
11696 list
->proc_sym
->name
, &list
->where
, my_rank
,
11697 i
->proc_sym
->name
);
11703 /* Is this the/a scalar finalizer procedure? */
11704 if (!arg
->as
|| arg
->as
->rank
== 0)
11705 seen_scalar
= true;
11707 /* Find the symtree for this procedure. */
11708 gcc_assert (!list
->proc_tree
);
11709 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11711 prev_link
= &list
->next
;
11714 /* Remove wrong nodes immediately from the list so we don't risk any
11715 troubles in the future when they might fail later expectations. */
11718 *prev_link
= list
->next
;
11719 gfc_free_finalizer (i
);
11723 if (result
== false)
11726 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11727 were nodes in the list, must have been for arrays. It is surely a good
11728 idea to have a scalar version there if there's something to finalize. */
11729 if (warn_surprising
&& result
&& !seen_scalar
)
11730 gfc_warning (OPT_Wsurprising
,
11731 "Only array FINAL procedures declared for derived type %qs"
11732 " defined at %L, suggest also scalar one",
11733 derived
->name
, &derived
->declared_at
);
11735 vtab
= gfc_find_derived_vtab (derived
);
11736 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11737 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11740 *finalizable
= true;
11746 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11749 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11750 const char* generic_name
, locus where
)
11752 gfc_symbol
*sym1
, *sym2
;
11753 const char *pass1
, *pass2
;
11754 gfc_formal_arglist
*dummy_args
;
11756 gcc_assert (t1
->specific
&& t2
->specific
);
11757 gcc_assert (!t1
->specific
->is_generic
);
11758 gcc_assert (!t2
->specific
->is_generic
);
11759 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11761 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11762 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11767 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11768 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11769 || sym1
->attr
.function
!= sym2
->attr
.function
)
11771 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
11772 " GENERIC %qs at %L",
11773 sym1
->name
, sym2
->name
, generic_name
, &where
);
11777 /* Determine PASS arguments. */
11778 if (t1
->specific
->nopass
)
11780 else if (t1
->specific
->pass_arg
)
11781 pass1
= t1
->specific
->pass_arg
;
11784 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11786 pass1
= dummy_args
->sym
->name
;
11790 if (t2
->specific
->nopass
)
11792 else if (t2
->specific
->pass_arg
)
11793 pass2
= t2
->specific
->pass_arg
;
11796 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11798 pass2
= dummy_args
->sym
->name
;
11803 /* Compare the interfaces. */
11804 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11805 NULL
, 0, pass1
, pass2
))
11807 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
11808 sym1
->name
, sym2
->name
, generic_name
, &where
);
11816 /* Worker function for resolving a generic procedure binding; this is used to
11817 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11819 The difference between those cases is finding possible inherited bindings
11820 that are overridden, as one has to look for them in tb_sym_root,
11821 tb_uop_root or tb_op, respectively. Thus the caller must already find
11822 the super-type and set p->overridden correctly. */
11825 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11826 gfc_typebound_proc
* p
, const char* name
)
11828 gfc_tbp_generic
* target
;
11829 gfc_symtree
* first_target
;
11830 gfc_symtree
* inherited
;
11832 gcc_assert (p
&& p
->is_generic
);
11834 /* Try to find the specific bindings for the symtrees in our target-list. */
11835 gcc_assert (p
->u
.generic
);
11836 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11837 if (!target
->specific
)
11839 gfc_typebound_proc
* overridden_tbp
;
11840 gfc_tbp_generic
* g
;
11841 const char* target_name
;
11843 target_name
= target
->specific_st
->name
;
11845 /* Defined for this type directly. */
11846 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11848 target
->specific
= target
->specific_st
->n
.tb
;
11849 goto specific_found
;
11852 /* Look for an inherited specific binding. */
11855 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11860 gcc_assert (inherited
->n
.tb
);
11861 target
->specific
= inherited
->n
.tb
;
11862 goto specific_found
;
11866 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
11867 " at %L", target_name
, name
, &p
->where
);
11870 /* Once we've found the specific binding, check it is not ambiguous with
11871 other specifics already found or inherited for the same GENERIC. */
11873 gcc_assert (target
->specific
);
11875 /* This must really be a specific binding! */
11876 if (target
->specific
->is_generic
)
11878 gfc_error ("GENERIC %qs at %L must target a specific binding,"
11879 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
11883 /* Check those already resolved on this type directly. */
11884 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11885 if (g
!= target
&& g
->specific
11886 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11889 /* Check for ambiguity with inherited specific targets. */
11890 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11891 overridden_tbp
= overridden_tbp
->overridden
)
11892 if (overridden_tbp
->is_generic
)
11894 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11896 gcc_assert (g
->specific
);
11897 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11903 /* If we attempt to "overwrite" a specific binding, this is an error. */
11904 if (p
->overridden
&& !p
->overridden
->is_generic
)
11906 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
11907 " the same name", name
, &p
->where
);
11911 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11912 all must have the same attributes here. */
11913 first_target
= p
->u
.generic
->specific
->u
.specific
;
11914 gcc_assert (first_target
);
11915 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11916 p
->function
= first_target
->n
.sym
->attr
.function
;
11922 /* Resolve a GENERIC procedure binding for a derived type. */
11925 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11927 gfc_symbol
* super_type
;
11929 /* Find the overridden binding if any. */
11930 st
->n
.tb
->overridden
= NULL
;
11931 super_type
= gfc_get_derived_super_type (derived
);
11934 gfc_symtree
* overridden
;
11935 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11938 if (overridden
&& overridden
->n
.tb
)
11939 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11942 /* Resolve using worker function. */
11943 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11947 /* Retrieve the target-procedure of an operator binding and do some checks in
11948 common for intrinsic and user-defined type-bound operators. */
11951 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11953 gfc_symbol
* target_proc
;
11955 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11956 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11957 gcc_assert (target_proc
);
11959 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11960 if (target
->specific
->nopass
)
11962 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11966 return target_proc
;
11970 /* Resolve a type-bound intrinsic operator. */
11973 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11974 gfc_typebound_proc
* p
)
11976 gfc_symbol
* super_type
;
11977 gfc_tbp_generic
* target
;
11979 /* If there's already an error here, do nothing (but don't fail again). */
11983 /* Operators should always be GENERIC bindings. */
11984 gcc_assert (p
->is_generic
);
11986 /* Look for an overridden binding. */
11987 super_type
= gfc_get_derived_super_type (derived
);
11988 if (super_type
&& super_type
->f2k_derived
)
11989 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11992 p
->overridden
= NULL
;
11994 /* Resolve general GENERIC properties using worker function. */
11995 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11998 /* Check the targets to be procedures of correct interface. */
11999 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12001 gfc_symbol
* target_proc
;
12003 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12007 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12010 /* Add target to non-typebound operator list. */
12011 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12012 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12014 gfc_interface
*head
, *intr
;
12015 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
12017 head
= derived
->ns
->op
[op
];
12018 intr
= gfc_get_interface ();
12019 intr
->sym
= target_proc
;
12020 intr
->where
= p
->where
;
12022 derived
->ns
->op
[op
] = intr
;
12034 /* Resolve a type-bound user operator (tree-walker callback). */
12036 static gfc_symbol
* resolve_bindings_derived
;
12037 static bool resolve_bindings_result
;
12039 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12042 resolve_typebound_user_op (gfc_symtree
* stree
)
12044 gfc_symbol
* super_type
;
12045 gfc_tbp_generic
* target
;
12047 gcc_assert (stree
&& stree
->n
.tb
);
12049 if (stree
->n
.tb
->error
)
12052 /* Operators should always be GENERIC bindings. */
12053 gcc_assert (stree
->n
.tb
->is_generic
);
12055 /* Find overridden procedure, if any. */
12056 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12057 if (super_type
&& super_type
->f2k_derived
)
12059 gfc_symtree
* overridden
;
12060 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12061 stree
->name
, true, NULL
);
12063 if (overridden
&& overridden
->n
.tb
)
12064 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12067 stree
->n
.tb
->overridden
= NULL
;
12069 /* Resolve basically using worker function. */
12070 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12073 /* Check the targets to be functions of correct interface. */
12074 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12076 gfc_symbol
* target_proc
;
12078 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12082 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12089 resolve_bindings_result
= false;
12090 stree
->n
.tb
->error
= 1;
12094 /* Resolve the type-bound procedures for a derived type. */
12097 resolve_typebound_procedure (gfc_symtree
* stree
)
12101 gfc_symbol
* me_arg
;
12102 gfc_symbol
* super_type
;
12103 gfc_component
* comp
;
12105 gcc_assert (stree
);
12107 /* Undefined specific symbol from GENERIC target definition. */
12111 if (stree
->n
.tb
->error
)
12114 /* If this is a GENERIC binding, use that routine. */
12115 if (stree
->n
.tb
->is_generic
)
12117 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12122 /* Get the target-procedure to check it. */
12123 gcc_assert (!stree
->n
.tb
->is_generic
);
12124 gcc_assert (stree
->n
.tb
->u
.specific
);
12125 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12126 where
= stree
->n
.tb
->where
;
12128 /* Default access should already be resolved from the parser. */
12129 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12131 if (stree
->n
.tb
->deferred
)
12133 if (!check_proc_interface (proc
, &where
))
12138 /* Check for F08:C465. */
12139 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12140 || (proc
->attr
.proc
!= PROC_MODULE
12141 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12142 || proc
->attr
.abstract
)
12144 gfc_error ("%qs must be a module procedure or an external procedure with"
12145 " an explicit interface at %L", proc
->name
, &where
);
12150 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12151 stree
->n
.tb
->function
= proc
->attr
.function
;
12153 /* Find the super-type of the current derived type. We could do this once and
12154 store in a global if speed is needed, but as long as not I believe this is
12155 more readable and clearer. */
12156 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12158 /* If PASS, resolve and check arguments if not already resolved / loaded
12159 from a .mod file. */
12160 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12162 gfc_formal_arglist
*dummy_args
;
12164 dummy_args
= gfc_sym_get_dummy_args (proc
);
12165 if (stree
->n
.tb
->pass_arg
)
12167 gfc_formal_arglist
*i
;
12169 /* If an explicit passing argument name is given, walk the arg-list
12170 and look for it. */
12173 stree
->n
.tb
->pass_arg_num
= 1;
12174 for (i
= dummy_args
; i
; i
= i
->next
)
12176 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12181 ++stree
->n
.tb
->pass_arg_num
;
12186 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12188 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12189 stree
->n
.tb
->pass_arg
);
12195 /* Otherwise, take the first one; there should in fact be at least
12197 stree
->n
.tb
->pass_arg_num
= 1;
12200 gfc_error ("Procedure %qs with PASS at %L must have at"
12201 " least one argument", proc
->name
, &where
);
12204 me_arg
= dummy_args
->sym
;
12207 /* Now check that the argument-type matches and the passed-object
12208 dummy argument is generally fine. */
12210 gcc_assert (me_arg
);
12212 if (me_arg
->ts
.type
!= BT_CLASS
)
12214 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12215 " at %L", proc
->name
, &where
);
12219 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12220 != resolve_bindings_derived
)
12222 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12223 " the derived-type %qs", me_arg
->name
, proc
->name
,
12224 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12228 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12229 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12231 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12232 " scalar", proc
->name
, &where
);
12235 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12237 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12238 " be ALLOCATABLE", proc
->name
, &where
);
12241 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12243 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12244 " be POINTER", proc
->name
, &where
);
12249 /* If we are extending some type, check that we don't override a procedure
12250 flagged NON_OVERRIDABLE. */
12251 stree
->n
.tb
->overridden
= NULL
;
12254 gfc_symtree
* overridden
;
12255 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12256 stree
->name
, true, NULL
);
12260 if (overridden
->n
.tb
)
12261 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12263 if (!gfc_check_typebound_override (stree
, overridden
))
12268 /* See if there's a name collision with a component directly in this type. */
12269 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12270 if (!strcmp (comp
->name
, stree
->name
))
12272 gfc_error ("Procedure %qs at %L has the same name as a component of"
12274 stree
->name
, &where
, resolve_bindings_derived
->name
);
12278 /* Try to find a name collision with an inherited component. */
12279 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12281 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12282 " component of %qs",
12283 stree
->name
, &where
, resolve_bindings_derived
->name
);
12287 stree
->n
.tb
->error
= 0;
12291 resolve_bindings_result
= false;
12292 stree
->n
.tb
->error
= 1;
12297 resolve_typebound_procedures (gfc_symbol
* derived
)
12300 gfc_symbol
* super_type
;
12302 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12305 super_type
= gfc_get_derived_super_type (derived
);
12307 resolve_symbol (super_type
);
12309 resolve_bindings_derived
= derived
;
12310 resolve_bindings_result
= true;
12312 if (derived
->f2k_derived
->tb_sym_root
)
12313 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12314 &resolve_typebound_procedure
);
12316 if (derived
->f2k_derived
->tb_uop_root
)
12317 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12318 &resolve_typebound_user_op
);
12320 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12322 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12323 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12324 (gfc_intrinsic_op
)op
, p
))
12325 resolve_bindings_result
= false;
12328 return resolve_bindings_result
;
12332 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12333 to give all identical derived types the same backend_decl. */
12335 add_dt_to_dt_list (gfc_symbol
*derived
)
12337 gfc_dt_list
*dt_list
;
12339 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12340 if (derived
== dt_list
->derived
)
12343 dt_list
= gfc_get_dt_list ();
12344 dt_list
->next
= gfc_derived_types
;
12345 dt_list
->derived
= derived
;
12346 gfc_derived_types
= dt_list
;
12350 /* Ensure that a derived-type is really not abstract, meaning that every
12351 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12354 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12359 if (!ensure_not_abstract_walker (sub
, st
->left
))
12361 if (!ensure_not_abstract_walker (sub
, st
->right
))
12364 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12366 gfc_symtree
* overriding
;
12367 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12370 gcc_assert (overriding
->n
.tb
);
12371 if (overriding
->n
.tb
->deferred
)
12373 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12374 " %qs is DEFERRED and not overridden",
12375 sub
->name
, &sub
->declared_at
, st
->name
);
12384 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12386 /* The algorithm used here is to recursively travel up the ancestry of sub
12387 and for each ancestor-type, check all bindings. If any of them is
12388 DEFERRED, look it up starting from sub and see if the found (overriding)
12389 binding is not DEFERRED.
12390 This is not the most efficient way to do this, but it should be ok and is
12391 clearer than something sophisticated. */
12393 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12395 if (!ancestor
->attr
.abstract
)
12398 /* Walk bindings of this ancestor. */
12399 if (ancestor
->f2k_derived
)
12402 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12407 /* Find next ancestor type and recurse on it. */
12408 ancestor
= gfc_get_derived_super_type (ancestor
);
12410 return ensure_not_abstract (sub
, ancestor
);
12416 /* This check for typebound defined assignments is done recursively
12417 since the order in which derived types are resolved is not always in
12418 order of the declarations. */
12421 check_defined_assignments (gfc_symbol
*derived
)
12425 for (c
= derived
->components
; c
; c
= c
->next
)
12427 if (c
->ts
.type
!= BT_DERIVED
12429 || c
->attr
.allocatable
12430 || c
->attr
.proc_pointer_comp
12431 || c
->attr
.class_pointer
12432 || c
->attr
.proc_pointer
)
12435 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12436 || (c
->ts
.u
.derived
->f2k_derived
12437 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12439 derived
->attr
.defined_assign_comp
= 1;
12443 check_defined_assignments (c
->ts
.u
.derived
);
12444 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12446 derived
->attr
.defined_assign_comp
= 1;
12453 /* Resolve the components of a derived type. This does not have to wait until
12454 resolution stage, but can be done as soon as the dt declaration has been
12458 resolve_fl_derived0 (gfc_symbol
*sym
)
12460 gfc_symbol
* super_type
;
12463 if (sym
->attr
.unlimited_polymorphic
)
12466 super_type
= gfc_get_derived_super_type (sym
);
12469 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12471 gfc_error ("As extending type %qs at %L has a coarray component, "
12472 "parent type %qs shall also have one", sym
->name
,
12473 &sym
->declared_at
, super_type
->name
);
12477 /* Ensure the extended type gets resolved before we do. */
12478 if (super_type
&& !resolve_fl_derived0 (super_type
))
12481 /* An ABSTRACT type must be extensible. */
12482 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12484 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12485 sym
->name
, &sym
->declared_at
);
12489 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12492 bool success
= true;
12494 for ( ; c
!= NULL
; c
= c
->next
)
12496 if (c
->attr
.artificial
)
12500 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12501 && c
->attr
.codimension
12502 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12504 gfc_error ("Coarray component %qs at %L must be allocatable with "
12505 "deferred shape", c
->name
, &c
->loc
);
12511 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12512 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12514 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12515 "shall not be a coarray", c
->name
, &c
->loc
);
12521 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12522 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12523 || c
->attr
.allocatable
))
12525 gfc_error ("Component %qs at %L with coarray component "
12526 "shall be a nonpointer, nonallocatable scalar",
12533 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12535 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12536 "is not an array pointer", c
->name
, &c
->loc
);
12541 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12543 gfc_symbol
*ifc
= c
->ts
.interface
;
12545 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
12552 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12554 /* Resolve interface and copy attributes. */
12555 if (ifc
->formal
&& !ifc
->formal_ns
)
12556 resolve_symbol (ifc
);
12557 if (ifc
->attr
.intrinsic
)
12558 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12562 c
->ts
= ifc
->result
->ts
;
12563 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12564 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12565 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12566 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12567 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12572 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12573 c
->attr
.pointer
= ifc
->attr
.pointer
;
12574 c
->attr
.dimension
= ifc
->attr
.dimension
;
12575 c
->as
= gfc_copy_array_spec (ifc
->as
);
12576 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12578 c
->ts
.interface
= ifc
;
12579 c
->attr
.function
= ifc
->attr
.function
;
12580 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12582 c
->attr
.pure
= ifc
->attr
.pure
;
12583 c
->attr
.elemental
= ifc
->attr
.elemental
;
12584 c
->attr
.recursive
= ifc
->attr
.recursive
;
12585 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12586 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12587 /* Copy char length. */
12588 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12590 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12591 if (cl
->length
&& !cl
->resolved
12592 && !gfc_resolve_expr (cl
->length
))
12602 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12604 /* Since PPCs are not implicitly typed, a PPC without an explicit
12605 interface must be a subroutine. */
12606 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12609 /* Procedure pointer components: Check PASS arg. */
12610 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12611 && !sym
->attr
.vtype
)
12613 gfc_symbol
* me_arg
;
12615 if (c
->tb
->pass_arg
)
12617 gfc_formal_arglist
* i
;
12619 /* If an explicit passing argument name is given, walk the arg-list
12620 and look for it. */
12623 c
->tb
->pass_arg_num
= 1;
12624 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12626 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12631 c
->tb
->pass_arg_num
++;
12636 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12637 "at %L has no argument %qs", c
->name
,
12638 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12646 /* Otherwise, take the first one; there should in fact be at least
12648 c
->tb
->pass_arg_num
= 1;
12649 if (!c
->ts
.interface
->formal
)
12651 gfc_error ("Procedure pointer component %qs with PASS at %L "
12652 "must have at least one argument",
12658 me_arg
= c
->ts
.interface
->formal
->sym
;
12661 /* Now check that the argument-type matches. */
12662 gcc_assert (me_arg
);
12663 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12664 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12665 || (me_arg
->ts
.type
== BT_CLASS
12666 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12668 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12669 " the derived type %qs", me_arg
->name
, c
->name
,
12670 me_arg
->name
, &c
->loc
, sym
->name
);
12676 /* Check for C453. */
12677 if (me_arg
->attr
.dimension
)
12679 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12680 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12687 if (me_arg
->attr
.pointer
)
12689 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12690 "may not have the POINTER attribute", me_arg
->name
,
12691 c
->name
, me_arg
->name
, &c
->loc
);
12697 if (me_arg
->attr
.allocatable
)
12699 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12700 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12701 me_arg
->name
, &c
->loc
);
12707 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12709 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12710 " at %L", c
->name
, &c
->loc
);
12717 /* Check type-spec if this is not the parent-type component. */
12718 if (((sym
->attr
.is_class
12719 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12720 || c
!= sym
->components
->ts
.u
.derived
->components
))
12721 || (!sym
->attr
.is_class
12722 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12723 && !sym
->attr
.vtype
12724 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12727 /* If this type is an extension, set the accessibility of the parent
12730 && ((sym
->attr
.is_class
12731 && c
== sym
->components
->ts
.u
.derived
->components
)
12732 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12733 && strcmp (super_type
->name
, c
->name
) == 0)
12734 c
->attr
.access
= super_type
->attr
.access
;
12736 /* If this type is an extension, see if this component has the same name
12737 as an inherited type-bound procedure. */
12738 if (super_type
&& !sym
->attr
.is_class
12739 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12741 gfc_error ("Component %qs of %qs at %L has the same name as an"
12742 " inherited type-bound procedure",
12743 c
->name
, sym
->name
, &c
->loc
);
12747 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12748 && !c
->ts
.deferred
)
12750 if (c
->ts
.u
.cl
->length
== NULL
12751 || (!resolve_charlen(c
->ts
.u
.cl
))
12752 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12754 gfc_error ("Character length of component %qs needs to "
12755 "be a constant specification expression at %L",
12757 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12762 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12763 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12765 gfc_error ("Character component %qs of %qs at %L with deferred "
12766 "length must be a POINTER or ALLOCATABLE",
12767 c
->name
, sym
->name
, &c
->loc
);
12771 /* Add the hidden deferred length field. */
12772 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12773 && !sym
->attr
.is_class
)
12775 char name
[GFC_MAX_SYMBOL_LEN
+9];
12776 gfc_component
*strlen
;
12777 sprintf (name
, "_%s_length", c
->name
);
12778 strlen
= gfc_find_component (sym
, name
, true, true);
12779 if (strlen
== NULL
)
12781 if (!gfc_add_component (sym
, name
, &strlen
))
12783 strlen
->ts
.type
= BT_INTEGER
;
12784 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12785 strlen
->attr
.access
= ACCESS_PRIVATE
;
12786 strlen
->attr
.artificial
= 1;
12790 if (c
->ts
.type
== BT_DERIVED
12791 && sym
->component_access
!= ACCESS_PRIVATE
12792 && gfc_check_symbol_access (sym
)
12793 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12794 && !c
->ts
.u
.derived
->attr
.use_assoc
12795 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12796 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
12797 "PRIVATE type and cannot be a component of "
12798 "%qs, which is PUBLIC at %L", c
->name
,
12799 sym
->name
, &sym
->declared_at
))
12802 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12804 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12805 "type %s", c
->name
, &c
->loc
, sym
->name
);
12809 if (sym
->attr
.sequence
)
12811 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12813 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12814 "not have the SEQUENCE attribute",
12815 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12820 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12821 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12822 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12823 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12824 CLASS_DATA (c
)->ts
.u
.derived
12825 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12827 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12828 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12829 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12831 gfc_error ("The pointer component %qs of %qs at %L is a type "
12832 "that has not been declared", c
->name
, sym
->name
,
12837 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12838 && CLASS_DATA (c
)->attr
.class_pointer
12839 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12840 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12841 && !UNLIMITED_POLY (c
))
12843 gfc_error ("The pointer component %qs of %qs at %L is a type "
12844 "that has not been declared", c
->name
, sym
->name
,
12850 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12851 && (!c
->attr
.class_ok
12852 || !(CLASS_DATA (c
)->attr
.class_pointer
12853 || CLASS_DATA (c
)->attr
.allocatable
)))
12855 gfc_error ("Component %qs with CLASS at %L must be allocatable "
12856 "or pointer", c
->name
, &c
->loc
);
12857 /* Prevent a recurrence of the error. */
12858 c
->ts
.type
= BT_UNKNOWN
;
12862 /* Ensure that all the derived type components are put on the
12863 derived type list; even in formal namespaces, where derived type
12864 pointer components might not have been declared. */
12865 if (c
->ts
.type
== BT_DERIVED
12867 && c
->ts
.u
.derived
->components
12869 && sym
!= c
->ts
.u
.derived
)
12870 add_dt_to_dt_list (c
->ts
.u
.derived
);
12872 if (!gfc_resolve_array_spec (c
->as
,
12873 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12874 || c
->attr
.allocatable
)))
12877 if (c
->initializer
&& !sym
->attr
.vtype
12878 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12885 check_defined_assignments (sym
);
12887 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12888 sym
->attr
.defined_assign_comp
12889 = super_type
->attr
.defined_assign_comp
;
12891 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12892 all DEFERRED bindings are overridden. */
12893 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12894 && !sym
->attr
.is_class
12895 && !ensure_not_abstract (sym
, super_type
))
12898 /* Add derived type to the derived type list. */
12899 add_dt_to_dt_list (sym
);
12905 /* The following procedure does the full resolution of a derived type,
12906 including resolution of all type-bound procedures (if present). In contrast
12907 to 'resolve_fl_derived0' this can only be done after the module has been
12908 parsed completely. */
12911 resolve_fl_derived (gfc_symbol
*sym
)
12913 gfc_symbol
*gen_dt
= NULL
;
12915 if (sym
->attr
.unlimited_polymorphic
)
12918 if (!sym
->attr
.is_class
)
12919 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12920 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12921 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12922 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12923 && !gfc_notify_std_1 (GFC_STD_F2003
, "Generic name '%s' of function "
12924 "'%s' at %L being the same name as derived "
12925 "type at %L", sym
->name
,
12926 gen_dt
->generic
->sym
== sym
12927 ? gen_dt
->generic
->next
->sym
->name
12928 : gen_dt
->generic
->sym
->name
,
12929 gen_dt
->generic
->sym
== sym
12930 ? &gen_dt
->generic
->next
->sym
->declared_at
12931 : &gen_dt
->generic
->sym
->declared_at
,
12932 &sym
->declared_at
))
12935 /* Resolve the finalizer procedures. */
12936 if (!gfc_resolve_finalizers (sym
, NULL
))
12939 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12941 /* Fix up incomplete CLASS symbols. */
12942 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12943 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12945 /* Nothing more to do for unlimited polymorphic entities. */
12946 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12948 else if (vptr
->ts
.u
.derived
== NULL
)
12950 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12952 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12956 if (!resolve_fl_derived0 (sym
))
12959 /* Resolve the type-bound procedures. */
12960 if (!resolve_typebound_procedures (sym
))
12968 resolve_fl_namelist (gfc_symbol
*sym
)
12973 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12975 /* Check again, the check in match only works if NAMELIST comes
12977 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12979 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
12980 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12984 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12985 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12986 "with assumed shape in namelist %qs at %L",
12987 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12990 if (is_non_constant_shape_array (nl
->sym
)
12991 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12992 "with nonconstant shape in namelist %qs at %L",
12993 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12996 if (nl
->sym
->ts
.type
== BT_CHARACTER
12997 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12998 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12999 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13000 "nonconstant character length in "
13001 "namelist %qs at %L", nl
->sym
->name
,
13002 sym
->name
, &sym
->declared_at
))
13005 /* FIXME: Once UDDTIO is implemented, the following can be
13007 if (nl
->sym
->ts
.type
== BT_CLASS
)
13009 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13010 "polymorphic and requires a defined input/output "
13011 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13015 if (nl
->sym
->ts
.type
== BT_DERIVED
13016 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13017 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13019 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13020 "namelist %qs at %L with ALLOCATABLE "
13021 "or POINTER components", nl
->sym
->name
,
13022 sym
->name
, &sym
->declared_at
))
13025 /* FIXME: Once UDDTIO is implemented, the following can be
13027 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13028 "ALLOCATABLE or POINTER components and thus requires "
13029 "a defined input/output procedure", nl
->sym
->name
,
13030 sym
->name
, &sym
->declared_at
);
13035 /* Reject PRIVATE objects in a PUBLIC namelist. */
13036 if (gfc_check_symbol_access (sym
))
13038 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13040 if (!nl
->sym
->attr
.use_assoc
13041 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13042 && !gfc_check_symbol_access (nl
->sym
))
13044 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13045 "cannot be member of PUBLIC namelist %qs at %L",
13046 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13050 /* Types with private components that came here by USE-association. */
13051 if (nl
->sym
->ts
.type
== BT_DERIVED
13052 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13054 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13055 "components and cannot be member of namelist %qs at %L",
13056 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13060 /* Types with private components that are defined in the same module. */
13061 if (nl
->sym
->ts
.type
== BT_DERIVED
13062 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13063 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13065 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13066 "cannot be a member of PUBLIC namelist %qs at %L",
13067 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13074 /* 14.1.2 A module or internal procedure represent local entities
13075 of the same type as a namelist member and so are not allowed. */
13076 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13078 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13081 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13082 if ((nl
->sym
== sym
->ns
->proc_name
)
13084 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13089 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13090 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13092 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13093 "attribute in %qs at %L", nlsym
->name
,
13094 &sym
->declared_at
);
13104 resolve_fl_parameter (gfc_symbol
*sym
)
13106 /* A parameter array's shape needs to be constant. */
13107 if (sym
->as
!= NULL
13108 && (sym
->as
->type
== AS_DEFERRED
13109 || is_non_constant_shape_array (sym
)))
13111 gfc_error ("Parameter array %qs at %L cannot be automatic "
13112 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13116 /* Make sure a parameter that has been implicitly typed still
13117 matches the implicit type, since PARAMETER statements can precede
13118 IMPLICIT statements. */
13119 if (sym
->attr
.implicit_type
13120 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13123 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13124 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13128 /* Make sure the types of derived parameters are consistent. This
13129 type checking is deferred until resolution because the type may
13130 refer to a derived type from the host. */
13131 if (sym
->ts
.type
== BT_DERIVED
13132 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13134 gfc_error ("Incompatible derived type in PARAMETER at %L",
13135 &sym
->value
->where
);
13142 /* Do anything necessary to resolve a symbol. Right now, we just
13143 assume that an otherwise unknown symbol is a variable. This sort
13144 of thing commonly happens for symbols in module. */
13147 resolve_symbol (gfc_symbol
*sym
)
13149 int check_constant
, mp_flag
;
13150 gfc_symtree
*symtree
;
13151 gfc_symtree
*this_symtree
;
13154 symbol_attribute class_attr
;
13155 gfc_array_spec
*as
;
13156 bool saved_specification_expr
;
13162 if (sym
->attr
.artificial
)
13165 if (sym
->attr
.unlimited_polymorphic
)
13168 if (sym
->attr
.flavor
== FL_UNKNOWN
13169 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13170 && !sym
->attr
.generic
&& !sym
->attr
.external
13171 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13172 && sym
->ts
.type
== BT_UNKNOWN
))
13175 /* If we find that a flavorless symbol is an interface in one of the
13176 parent namespaces, find its symtree in this namespace, free the
13177 symbol and set the symtree to point to the interface symbol. */
13178 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13180 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13181 if (symtree
&& (symtree
->n
.sym
->generic
||
13182 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13183 && sym
->ns
->construct_entities
)))
13185 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13187 if (this_symtree
->n
.sym
== sym
)
13189 symtree
->n
.sym
->refs
++;
13190 gfc_release_symbol (sym
);
13191 this_symtree
->n
.sym
= symtree
->n
.sym
;
13197 /* Otherwise give it a flavor according to such attributes as
13199 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13200 && sym
->attr
.intrinsic
== 0)
13201 sym
->attr
.flavor
= FL_VARIABLE
;
13202 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13204 sym
->attr
.flavor
= FL_PROCEDURE
;
13205 if (sym
->attr
.dimension
)
13206 sym
->attr
.function
= 1;
13210 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13211 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13213 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13214 && !resolve_procedure_interface (sym
))
13217 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13218 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13220 if (sym
->attr
.external
)
13221 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13222 "at %L", &sym
->declared_at
);
13224 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13225 "at %L", &sym
->declared_at
);
13230 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13233 /* Symbols that are module procedures with results (functions) have
13234 the types and array specification copied for type checking in
13235 procedures that call them, as well as for saving to a module
13236 file. These symbols can't stand the scrutiny that their results
13238 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13240 /* Make sure that the intrinsic is consistent with its internal
13241 representation. This needs to be done before assigning a default
13242 type to avoid spurious warnings. */
13243 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13244 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13247 /* Resolve associate names. */
13249 resolve_assoc_var (sym
, true);
13251 /* Assign default type to symbols that need one and don't have one. */
13252 if (sym
->ts
.type
== BT_UNKNOWN
)
13254 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13256 gfc_set_default_type (sym
, 1, NULL
);
13259 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13260 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13261 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13262 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13264 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13266 /* The specific case of an external procedure should emit an error
13267 in the case that there is no implicit type. */
13269 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13272 /* Result may be in another namespace. */
13273 resolve_symbol (sym
->result
);
13275 if (!sym
->result
->attr
.proc_pointer
)
13277 sym
->ts
= sym
->result
->ts
;
13278 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13279 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13280 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13281 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13282 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13287 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13289 bool saved_specification_expr
= specification_expr
;
13290 specification_expr
= true;
13291 gfc_resolve_array_spec (sym
->result
->as
, false);
13292 specification_expr
= saved_specification_expr
;
13295 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13297 as
= CLASS_DATA (sym
)->as
;
13298 class_attr
= CLASS_DATA (sym
)->attr
;
13299 class_attr
.pointer
= class_attr
.class_pointer
;
13303 class_attr
= sym
->attr
;
13308 if (sym
->attr
.contiguous
13309 && (!class_attr
.dimension
13310 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13311 && !class_attr
.pointer
)))
13313 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13314 "array pointer or an assumed-shape or assumed-rank array",
13315 sym
->name
, &sym
->declared_at
);
13319 /* Assumed size arrays and assumed shape arrays must be dummy
13320 arguments. Array-spec's of implied-shape should have been resolved to
13321 AS_EXPLICIT already. */
13325 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13326 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13327 || as
->type
== AS_ASSUMED_SHAPE
)
13328 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13330 if (as
->type
== AS_ASSUMED_SIZE
)
13331 gfc_error ("Assumed size array at %L must be a dummy argument",
13332 &sym
->declared_at
);
13334 gfc_error ("Assumed shape array at %L must be a dummy argument",
13335 &sym
->declared_at
);
13338 /* TS 29113, C535a. */
13339 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13340 && !sym
->attr
.select_type_temporary
)
13342 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13343 &sym
->declared_at
);
13346 if (as
->type
== AS_ASSUMED_RANK
13347 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13349 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13350 "CODIMENSION attribute", &sym
->declared_at
);
13355 /* Make sure symbols with known intent or optional are really dummy
13356 variable. Because of ENTRY statement, this has to be deferred
13357 until resolution time. */
13359 if (!sym
->attr
.dummy
13360 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13362 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13366 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13368 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13369 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13373 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13375 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13376 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13378 gfc_error ("Character dummy variable %qs at %L with VALUE "
13379 "attribute must have constant length",
13380 sym
->name
, &sym
->declared_at
);
13384 if (sym
->ts
.is_c_interop
13385 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13387 gfc_error ("C interoperable character dummy variable %qs at %L "
13388 "with VALUE attribute must have length one",
13389 sym
->name
, &sym
->declared_at
);
13394 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13395 && sym
->ts
.u
.derived
->attr
.generic
)
13397 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13398 if (!sym
->ts
.u
.derived
)
13400 gfc_error ("The derived type %qs at %L is of type %qs, "
13401 "which has not been defined", sym
->name
,
13402 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13403 sym
->ts
.type
= BT_UNKNOWN
;
13408 /* Use the same constraints as TYPE(*), except for the type check
13409 and that only scalars and assumed-size arrays are permitted. */
13410 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13412 if (!sym
->attr
.dummy
)
13414 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13415 "a dummy argument", sym
->name
, &sym
->declared_at
);
13419 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13420 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13421 && sym
->ts
.type
!= BT_COMPLEX
)
13423 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13424 "of type TYPE(*) or of an numeric intrinsic type",
13425 sym
->name
, &sym
->declared_at
);
13429 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13430 || sym
->attr
.pointer
|| sym
->attr
.value
)
13432 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13433 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13434 "attribute", sym
->name
, &sym
->declared_at
);
13438 if (sym
->attr
.intent
== INTENT_OUT
)
13440 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13441 "have the INTENT(OUT) attribute",
13442 sym
->name
, &sym
->declared_at
);
13445 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13447 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13448 "either be a scalar or an assumed-size array",
13449 sym
->name
, &sym
->declared_at
);
13453 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13454 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13456 sym
->ts
.type
= BT_ASSUMED
;
13457 sym
->as
= gfc_get_array_spec ();
13458 sym
->as
->type
= AS_ASSUMED_SIZE
;
13460 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13462 else if (sym
->ts
.type
== BT_ASSUMED
)
13464 /* TS 29113, C407a. */
13465 if (!sym
->attr
.dummy
)
13467 gfc_error ("Assumed type of variable %s at %L is only permitted "
13468 "for dummy variables", sym
->name
, &sym
->declared_at
);
13471 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13472 || sym
->attr
.pointer
|| sym
->attr
.value
)
13474 gfc_error ("Assumed-type variable %s at %L may not have the "
13475 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13476 sym
->name
, &sym
->declared_at
);
13479 if (sym
->attr
.intent
== INTENT_OUT
)
13481 gfc_error ("Assumed-type variable %s at %L may not have the "
13482 "INTENT(OUT) attribute",
13483 sym
->name
, &sym
->declared_at
);
13486 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13488 gfc_error ("Assumed-type variable %s at %L shall not be an "
13489 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13494 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13495 do this for something that was implicitly typed because that is handled
13496 in gfc_set_default_type. Handle dummy arguments and procedure
13497 definitions separately. Also, anything that is use associated is not
13498 handled here but instead is handled in the module it is declared in.
13499 Finally, derived type definitions are allowed to be BIND(C) since that
13500 only implies that they're interoperable, and they are checked fully for
13501 interoperability when a variable is declared of that type. */
13502 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13503 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13504 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13508 /* First, make sure the variable is declared at the
13509 module-level scope (J3/04-007, Section 15.3). */
13510 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13511 sym
->attr
.in_common
== 0)
13513 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13514 "is neither a COMMON block nor declared at the "
13515 "module level scope", sym
->name
, &(sym
->declared_at
));
13518 else if (sym
->common_head
!= NULL
)
13520 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13524 /* If type() declaration, we need to verify that the components
13525 of the given type are all C interoperable, etc. */
13526 if (sym
->ts
.type
== BT_DERIVED
&&
13527 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13529 /* Make sure the user marked the derived type as BIND(C). If
13530 not, call the verify routine. This could print an error
13531 for the derived type more than once if multiple variables
13532 of that type are declared. */
13533 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13534 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13538 /* Verify the variable itself as C interoperable if it
13539 is BIND(C). It is not possible for this to succeed if
13540 the verify_bind_c_derived_type failed, so don't have to handle
13541 any error returned by verify_bind_c_derived_type. */
13542 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13543 sym
->common_block
);
13548 /* clear the is_bind_c flag to prevent reporting errors more than
13549 once if something failed. */
13550 sym
->attr
.is_bind_c
= 0;
13555 /* If a derived type symbol has reached this point, without its
13556 type being declared, we have an error. Notice that most
13557 conditions that produce undefined derived types have already
13558 been dealt with. However, the likes of:
13559 implicit type(t) (t) ..... call foo (t) will get us here if
13560 the type is not declared in the scope of the implicit
13561 statement. Change the type to BT_UNKNOWN, both because it is so
13562 and to prevent an ICE. */
13563 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13564 && sym
->ts
.u
.derived
->components
== NULL
13565 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13567 gfc_error ("The derived type %qs at %L is of type %qs, "
13568 "which has not been defined", sym
->name
,
13569 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13570 sym
->ts
.type
= BT_UNKNOWN
;
13574 /* Make sure that the derived type has been resolved and that the
13575 derived type is visible in the symbol's namespace, if it is a
13576 module function and is not PRIVATE. */
13577 if (sym
->ts
.type
== BT_DERIVED
13578 && sym
->ts
.u
.derived
->attr
.use_assoc
13579 && sym
->ns
->proc_name
13580 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13581 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13584 /* Unless the derived-type declaration is use associated, Fortran 95
13585 does not allow public entries of private derived types.
13586 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13587 161 in 95-006r3. */
13588 if (sym
->ts
.type
== BT_DERIVED
13589 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13590 && !sym
->ts
.u
.derived
->attr
.use_assoc
13591 && gfc_check_symbol_access (sym
)
13592 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13593 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
13594 "derived type %qs",
13595 (sym
->attr
.flavor
== FL_PARAMETER
)
13596 ? "parameter" : "variable",
13597 sym
->name
, &sym
->declared_at
,
13598 sym
->ts
.u
.derived
->name
))
13601 /* F2008, C1302. */
13602 if (sym
->ts
.type
== BT_DERIVED
13603 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13604 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13605 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13606 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13608 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13609 "type LOCK_TYPE must be a coarray", sym
->name
,
13610 &sym
->declared_at
);
13614 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13615 default initialization is defined (5.1.2.4.4). */
13616 if (sym
->ts
.type
== BT_DERIVED
13618 && sym
->attr
.intent
== INTENT_OUT
13620 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13622 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13624 if (c
->initializer
)
13626 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
13627 "ASSUMED SIZE and so cannot have a default initializer",
13628 sym
->name
, &sym
->declared_at
);
13635 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13636 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13638 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
13639 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13644 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13645 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13646 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13647 || class_attr
.codimension
)
13648 && (sym
->attr
.result
|| sym
->result
== sym
))
13650 gfc_error ("Function result %qs at %L shall not be a coarray or have "
13651 "a coarray component", sym
->name
, &sym
->declared_at
);
13656 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13657 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13659 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13660 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13665 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13666 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13667 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13668 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13669 || class_attr
.allocatable
))
13671 gfc_error ("Variable %qs at %L with coarray component shall be a "
13672 "nonpointer, nonallocatable scalar, which is not a coarray",
13673 sym
->name
, &sym
->declared_at
);
13677 /* F2008, C526. The function-result case was handled above. */
13678 if (class_attr
.codimension
13679 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13680 || sym
->attr
.select_type_temporary
13681 || sym
->ns
->save_all
13682 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13683 || sym
->ns
->proc_name
->attr
.is_main_program
13684 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13686 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
13687 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13691 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13692 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13694 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
13695 "deferred shape", sym
->name
, &sym
->declared_at
);
13698 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13699 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13701 gfc_error ("Allocatable coarray variable %qs at %L must have "
13702 "deferred shape", sym
->name
, &sym
->declared_at
);
13707 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13708 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13709 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13710 || (class_attr
.codimension
&& class_attr
.allocatable
))
13711 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13713 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
13714 "allocatable coarray or have coarray components",
13715 sym
->name
, &sym
->declared_at
);
13719 if (class_attr
.codimension
&& sym
->attr
.dummy
13720 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13722 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
13723 "procedure %qs", sym
->name
, &sym
->declared_at
,
13724 sym
->ns
->proc_name
->name
);
13728 if (sym
->ts
.type
== BT_LOGICAL
13729 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13730 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13731 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13734 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13735 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13737 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13738 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
13739 "%L with non-C_Bool kind in BIND(C) procedure "
13740 "%qs", sym
->name
, &sym
->declared_at
,
13741 sym
->ns
->proc_name
->name
))
13743 else if (!gfc_logical_kinds
[i
].c_bool
13744 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13745 "%qs at %L with non-C_Bool kind in "
13746 "BIND(C) procedure %qs", sym
->name
,
13748 sym
->attr
.function
? sym
->name
13749 : sym
->ns
->proc_name
->name
))
13753 switch (sym
->attr
.flavor
)
13756 if (!resolve_fl_variable (sym
, mp_flag
))
13761 if (!resolve_fl_procedure (sym
, mp_flag
))
13766 if (!resolve_fl_namelist (sym
))
13771 if (!resolve_fl_parameter (sym
))
13779 /* Resolve array specifier. Check as well some constraints
13780 on COMMON blocks. */
13782 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13784 /* Set the formal_arg_flag so that check_conflict will not throw
13785 an error for host associated variables in the specification
13786 expression for an array_valued function. */
13787 if (sym
->attr
.function
&& sym
->as
)
13788 formal_arg_flag
= 1;
13790 saved_specification_expr
= specification_expr
;
13791 specification_expr
= true;
13792 gfc_resolve_array_spec (sym
->as
, check_constant
);
13793 specification_expr
= saved_specification_expr
;
13795 formal_arg_flag
= 0;
13797 /* Resolve formal namespaces. */
13798 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13799 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13800 gfc_resolve (sym
->formal_ns
);
13802 /* Make sure the formal namespace is present. */
13803 if (sym
->formal
&& !sym
->formal_ns
)
13805 gfc_formal_arglist
*formal
= sym
->formal
;
13806 while (formal
&& !formal
->sym
)
13807 formal
= formal
->next
;
13811 sym
->formal_ns
= formal
->sym
->ns
;
13812 if (sym
->ns
!= formal
->sym
->ns
)
13813 sym
->formal_ns
->refs
++;
13817 /* Check threadprivate restrictions. */
13818 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13819 && (!sym
->attr
.in_common
13820 && sym
->module
== NULL
13821 && (sym
->ns
->proc_name
== NULL
13822 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13823 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13825 /* Check omp declare target restrictions. */
13826 if (sym
->attr
.omp_declare_target
13827 && sym
->attr
.flavor
== FL_VARIABLE
13829 && !sym
->ns
->save_all
13830 && (!sym
->attr
.in_common
13831 && sym
->module
== NULL
13832 && (sym
->ns
->proc_name
== NULL
13833 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13834 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
13835 sym
->name
, &sym
->declared_at
);
13837 /* If we have come this far we can apply default-initializers, as
13838 described in 14.7.5, to those variables that have not already
13839 been assigned one. */
13840 if (sym
->ts
.type
== BT_DERIVED
13842 && !sym
->attr
.allocatable
13843 && !sym
->attr
.alloc_comp
)
13845 symbol_attribute
*a
= &sym
->attr
;
13847 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13848 && !a
->in_common
&& !a
->use_assoc
13849 && (a
->referenced
|| a
->result
)
13850 && !(a
->function
&& sym
!= sym
->result
))
13851 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13852 apply_default_init (sym
);
13855 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13856 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13857 && !CLASS_DATA (sym
)->attr
.class_pointer
13858 && !CLASS_DATA (sym
)->attr
.allocatable
)
13859 apply_default_init (sym
);
13861 /* If this symbol has a type-spec, check it. */
13862 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13863 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13864 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13869 /************* Resolve DATA statements *************/
13873 gfc_data_value
*vnode
;
13879 /* Advance the values structure to point to the next value in the data list. */
13882 next_data_value (void)
13884 while (mpz_cmp_ui (values
.left
, 0) == 0)
13887 if (values
.vnode
->next
== NULL
)
13890 values
.vnode
= values
.vnode
->next
;
13891 mpz_set (values
.left
, values
.vnode
->repeat
);
13899 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13905 ar_type mark
= AR_UNKNOWN
;
13907 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13913 if (!gfc_resolve_expr (var
->expr
))
13917 mpz_init_set_si (offset
, 0);
13920 if (e
->expr_type
!= EXPR_VARIABLE
)
13921 gfc_internal_error ("check_data_variable(): Bad expression");
13923 sym
= e
->symtree
->n
.sym
;
13925 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13927 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
13928 sym
->name
, &sym
->declared_at
);
13931 if (e
->ref
== NULL
&& sym
->as
)
13933 gfc_error ("DATA array %qs at %L must be specified in a previous"
13934 " declaration", sym
->name
, where
);
13938 has_pointer
= sym
->attr
.pointer
;
13940 if (gfc_is_coindexed (e
))
13942 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
13947 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13949 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13953 && ref
->type
== REF_ARRAY
13954 && ref
->u
.ar
.type
!= AR_FULL
)
13956 gfc_error ("DATA element %qs at %L is a pointer and so must "
13957 "be a full array", sym
->name
, where
);
13962 if (e
->rank
== 0 || has_pointer
)
13964 mpz_init_set_ui (size
, 1);
13971 /* Find the array section reference. */
13972 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13974 if (ref
->type
!= REF_ARRAY
)
13976 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13982 /* Set marks according to the reference pattern. */
13983 switch (ref
->u
.ar
.type
)
13991 /* Get the start position of array section. */
13992 gfc_get_section_index (ar
, section_index
, &offset
);
13997 gcc_unreachable ();
14000 if (!gfc_array_size (e
, &size
))
14002 gfc_error ("Nonconstant array section at %L in DATA statement",
14004 mpz_clear (offset
);
14011 while (mpz_cmp_ui (size
, 0) > 0)
14013 if (!next_data_value ())
14015 gfc_error ("DATA statement at %L has more variables than values",
14021 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14025 /* If we have more than one element left in the repeat count,
14026 and we have more than one element left in the target variable,
14027 then create a range assignment. */
14028 /* FIXME: Only done for full arrays for now, since array sections
14030 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14031 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14035 if (mpz_cmp (size
, values
.left
) >= 0)
14037 mpz_init_set (range
, values
.left
);
14038 mpz_sub (size
, size
, values
.left
);
14039 mpz_set_ui (values
.left
, 0);
14043 mpz_init_set (range
, size
);
14044 mpz_sub (values
.left
, values
.left
, size
);
14045 mpz_set_ui (size
, 0);
14048 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14051 mpz_add (offset
, offset
, range
);
14058 /* Assign initial value to symbol. */
14061 mpz_sub_ui (values
.left
, values
.left
, 1);
14062 mpz_sub_ui (size
, size
, 1);
14064 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14069 if (mark
== AR_FULL
)
14070 mpz_add_ui (offset
, offset
, 1);
14072 /* Modify the array section indexes and recalculate the offset
14073 for next element. */
14074 else if (mark
== AR_SECTION
)
14075 gfc_advance_section (section_index
, ar
, &offset
);
14079 if (mark
== AR_SECTION
)
14081 for (i
= 0; i
< ar
->dimen
; i
++)
14082 mpz_clear (section_index
[i
]);
14086 mpz_clear (offset
);
14092 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14094 /* Iterate over a list of elements in a DATA statement. */
14097 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14100 iterator_stack frame
;
14101 gfc_expr
*e
, *start
, *end
, *step
;
14102 bool retval
= true;
14104 mpz_init (frame
.value
);
14107 start
= gfc_copy_expr (var
->iter
.start
);
14108 end
= gfc_copy_expr (var
->iter
.end
);
14109 step
= gfc_copy_expr (var
->iter
.step
);
14111 if (!gfc_simplify_expr (start
, 1)
14112 || start
->expr_type
!= EXPR_CONSTANT
)
14114 gfc_error ("start of implied-do loop at %L could not be "
14115 "simplified to a constant value", &start
->where
);
14119 if (!gfc_simplify_expr (end
, 1)
14120 || end
->expr_type
!= EXPR_CONSTANT
)
14122 gfc_error ("end of implied-do loop at %L could not be "
14123 "simplified to a constant value", &start
->where
);
14127 if (!gfc_simplify_expr (step
, 1)
14128 || step
->expr_type
!= EXPR_CONSTANT
)
14130 gfc_error ("step of implied-do loop at %L could not be "
14131 "simplified to a constant value", &start
->where
);
14136 mpz_set (trip
, end
->value
.integer
);
14137 mpz_sub (trip
, trip
, start
->value
.integer
);
14138 mpz_add (trip
, trip
, step
->value
.integer
);
14140 mpz_div (trip
, trip
, step
->value
.integer
);
14142 mpz_set (frame
.value
, start
->value
.integer
);
14144 frame
.prev
= iter_stack
;
14145 frame
.variable
= var
->iter
.var
->symtree
;
14146 iter_stack
= &frame
;
14148 while (mpz_cmp_ui (trip
, 0) > 0)
14150 if (!traverse_data_var (var
->list
, where
))
14156 e
= gfc_copy_expr (var
->expr
);
14157 if (!gfc_simplify_expr (e
, 1))
14164 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14166 mpz_sub_ui (trip
, trip
, 1);
14170 mpz_clear (frame
.value
);
14173 gfc_free_expr (start
);
14174 gfc_free_expr (end
);
14175 gfc_free_expr (step
);
14177 iter_stack
= frame
.prev
;
14182 /* Type resolve variables in the variable list of a DATA statement. */
14185 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14189 for (; var
; var
= var
->next
)
14191 if (var
->expr
== NULL
)
14192 t
= traverse_data_list (var
, where
);
14194 t
= check_data_variable (var
, where
);
14204 /* Resolve the expressions and iterators associated with a data statement.
14205 This is separate from the assignment checking because data lists should
14206 only be resolved once. */
14209 resolve_data_variables (gfc_data_variable
*d
)
14211 for (; d
; d
= d
->next
)
14213 if (d
->list
== NULL
)
14215 if (!gfc_resolve_expr (d
->expr
))
14220 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14223 if (!resolve_data_variables (d
->list
))
14232 /* Resolve a single DATA statement. We implement this by storing a pointer to
14233 the value list into static variables, and then recursively traversing the
14234 variables list, expanding iterators and such. */
14237 resolve_data (gfc_data
*d
)
14240 if (!resolve_data_variables (d
->var
))
14243 values
.vnode
= d
->value
;
14244 if (d
->value
== NULL
)
14245 mpz_set_ui (values
.left
, 0);
14247 mpz_set (values
.left
, d
->value
->repeat
);
14249 if (!traverse_data_var (d
->var
, &d
->where
))
14252 /* At this point, we better not have any values left. */
14254 if (next_data_value ())
14255 gfc_error ("DATA statement at %L has more values than variables",
14260 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14261 accessed by host or use association, is a dummy argument to a pure function,
14262 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14263 is storage associated with any such variable, shall not be used in the
14264 following contexts: (clients of this function). */
14266 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14267 procedure. Returns zero if assignment is OK, nonzero if there is a
14270 gfc_impure_variable (gfc_symbol
*sym
)
14275 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14278 /* Check if the symbol's ns is inside the pure procedure. */
14279 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14283 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14287 proc
= sym
->ns
->proc_name
;
14288 if (sym
->attr
.dummy
14289 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14290 || proc
->attr
.function
))
14293 /* TODO: Sort out what can be storage associated, if anything, and include
14294 it here. In principle equivalences should be scanned but it does not
14295 seem to be possible to storage associate an impure variable this way. */
14300 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14301 current namespace is inside a pure procedure. */
14304 gfc_pure (gfc_symbol
*sym
)
14306 symbol_attribute attr
;
14311 /* Check if the current namespace or one of its parents
14312 belongs to a pure procedure. */
14313 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14315 sym
= ns
->proc_name
;
14319 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14327 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14331 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14332 checks if the current namespace is implicitly pure. Note that this
14333 function returns false for a PURE procedure. */
14336 gfc_implicit_pure (gfc_symbol
*sym
)
14342 /* Check if the current procedure is implicit_pure. Walk up
14343 the procedure list until we find a procedure. */
14344 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14346 sym
= ns
->proc_name
;
14350 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14355 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14356 && !sym
->attr
.pure
;
14361 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14367 /* Check if the current procedure is implicit_pure. Walk up
14368 the procedure list until we find a procedure. */
14369 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14371 sym
= ns
->proc_name
;
14375 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14380 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14381 sym
->attr
.implicit_pure
= 0;
14383 sym
->attr
.pure
= 0;
14387 /* Test whether the current procedure is elemental or not. */
14390 gfc_elemental (gfc_symbol
*sym
)
14392 symbol_attribute attr
;
14395 sym
= gfc_current_ns
->proc_name
;
14400 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14404 /* Warn about unused labels. */
14407 warn_unused_fortran_label (gfc_st_label
*label
)
14412 warn_unused_fortran_label (label
->left
);
14414 if (label
->defined
== ST_LABEL_UNKNOWN
)
14417 switch (label
->referenced
)
14419 case ST_LABEL_UNKNOWN
:
14420 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
14424 case ST_LABEL_BAD_TARGET
:
14425 gfc_warning (0, "Label %d at %L defined but cannot be used",
14426 label
->value
, &label
->where
);
14433 warn_unused_fortran_label (label
->right
);
14437 /* Returns the sequence type of a symbol or sequence. */
14440 sequence_type (gfc_typespec ts
)
14449 if (ts
.u
.derived
->components
== NULL
)
14450 return SEQ_NONDEFAULT
;
14452 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14453 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14454 if (sequence_type (c
->ts
) != result
)
14460 if (ts
.kind
!= gfc_default_character_kind
)
14461 return SEQ_NONDEFAULT
;
14463 return SEQ_CHARACTER
;
14466 if (ts
.kind
!= gfc_default_integer_kind
)
14467 return SEQ_NONDEFAULT
;
14469 return SEQ_NUMERIC
;
14472 if (!(ts
.kind
== gfc_default_real_kind
14473 || ts
.kind
== gfc_default_double_kind
))
14474 return SEQ_NONDEFAULT
;
14476 return SEQ_NUMERIC
;
14479 if (ts
.kind
!= gfc_default_complex_kind
)
14480 return SEQ_NONDEFAULT
;
14482 return SEQ_NUMERIC
;
14485 if (ts
.kind
!= gfc_default_logical_kind
)
14486 return SEQ_NONDEFAULT
;
14488 return SEQ_NUMERIC
;
14491 return SEQ_NONDEFAULT
;
14496 /* Resolve derived type EQUIVALENCE object. */
14499 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14501 gfc_component
*c
= derived
->components
;
14506 /* Shall not be an object of nonsequence derived type. */
14507 if (!derived
->attr
.sequence
)
14509 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14510 "attribute to be an EQUIVALENCE object", sym
->name
,
14515 /* Shall not have allocatable components. */
14516 if (derived
->attr
.alloc_comp
)
14518 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14519 "components to be an EQUIVALENCE object",sym
->name
,
14524 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14526 gfc_error ("Derived type variable %qs at %L with default "
14527 "initialization cannot be in EQUIVALENCE with a variable "
14528 "in COMMON", sym
->name
, &e
->where
);
14532 for (; c
; c
= c
->next
)
14534 if (c
->ts
.type
== BT_DERIVED
14535 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14538 /* Shall not be an object of sequence derived type containing a pointer
14539 in the structure. */
14540 if (c
->attr
.pointer
)
14542 gfc_error ("Derived type variable %qs at %L with pointer "
14543 "component(s) cannot be an EQUIVALENCE object",
14544 sym
->name
, &e
->where
);
14552 /* Resolve equivalence object.
14553 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14554 an allocatable array, an object of nonsequence derived type, an object of
14555 sequence derived type containing a pointer at any level of component
14556 selection, an automatic object, a function name, an entry name, a result
14557 name, a named constant, a structure component, or a subobject of any of
14558 the preceding objects. A substring shall not have length zero. A
14559 derived type shall not have components with default initialization nor
14560 shall two objects of an equivalence group be initialized.
14561 Either all or none of the objects shall have an protected attribute.
14562 The simple constraints are done in symbol.c(check_conflict) and the rest
14563 are implemented here. */
14566 resolve_equivalence (gfc_equiv
*eq
)
14569 gfc_symbol
*first_sym
;
14572 locus
*last_where
= NULL
;
14573 seq_type eq_type
, last_eq_type
;
14574 gfc_typespec
*last_ts
;
14575 int object
, cnt_protected
;
14578 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14580 first_sym
= eq
->expr
->symtree
->n
.sym
;
14584 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14588 e
->ts
= e
->symtree
->n
.sym
->ts
;
14589 /* match_varspec might not know yet if it is seeing
14590 array reference or substring reference, as it doesn't
14592 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14594 gfc_ref
*ref
= e
->ref
;
14595 sym
= e
->symtree
->n
.sym
;
14597 if (sym
->attr
.dimension
)
14599 ref
->u
.ar
.as
= sym
->as
;
14603 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14604 if (e
->ts
.type
== BT_CHARACTER
14606 && ref
->type
== REF_ARRAY
14607 && ref
->u
.ar
.dimen
== 1
14608 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14609 && ref
->u
.ar
.stride
[0] == NULL
)
14611 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14612 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14615 /* Optimize away the (:) reference. */
14616 if (start
== NULL
&& end
== NULL
)
14619 e
->ref
= ref
->next
;
14621 e
->ref
->next
= ref
->next
;
14626 ref
->type
= REF_SUBSTRING
;
14628 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14630 ref
->u
.ss
.start
= start
;
14631 if (end
== NULL
&& e
->ts
.u
.cl
)
14632 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14633 ref
->u
.ss
.end
= end
;
14634 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14641 /* Any further ref is an error. */
14644 gcc_assert (ref
->type
== REF_ARRAY
);
14645 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14651 if (!gfc_resolve_expr (e
))
14654 sym
= e
->symtree
->n
.sym
;
14656 if (sym
->attr
.is_protected
)
14658 if (cnt_protected
> 0 && cnt_protected
!= object
)
14660 gfc_error ("Either all or none of the objects in the "
14661 "EQUIVALENCE set at %L shall have the "
14662 "PROTECTED attribute",
14667 /* Shall not equivalence common block variables in a PURE procedure. */
14668 if (sym
->ns
->proc_name
14669 && sym
->ns
->proc_name
->attr
.pure
14670 && sym
->attr
.in_common
)
14672 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
14673 "object in the pure procedure %qs",
14674 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14678 /* Shall not be a named constant. */
14679 if (e
->expr_type
== EXPR_CONSTANT
)
14681 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
14682 "object", sym
->name
, &e
->where
);
14686 if (e
->ts
.type
== BT_DERIVED
14687 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14690 /* Check that the types correspond correctly:
14692 A numeric sequence structure may be equivalenced to another sequence
14693 structure, an object of default integer type, default real type, double
14694 precision real type, default logical type such that components of the
14695 structure ultimately only become associated to objects of the same
14696 kind. A character sequence structure may be equivalenced to an object
14697 of default character kind or another character sequence structure.
14698 Other objects may be equivalenced only to objects of the same type and
14699 kind parameters. */
14701 /* Identical types are unconditionally OK. */
14702 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14703 goto identical_types
;
14705 last_eq_type
= sequence_type (*last_ts
);
14706 eq_type
= sequence_type (sym
->ts
);
14708 /* Since the pair of objects is not of the same type, mixed or
14709 non-default sequences can be rejected. */
14711 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14712 "statement at %L with different type objects";
14714 && last_eq_type
== SEQ_MIXED
14715 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14716 || (eq_type
== SEQ_MIXED
14717 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14720 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14721 "statement at %L with objects of different type";
14723 && last_eq_type
== SEQ_NONDEFAULT
14724 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14725 || (eq_type
== SEQ_NONDEFAULT
14726 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14729 msg
="Non-CHARACTER object %qs in default CHARACTER "
14730 "EQUIVALENCE statement at %L";
14731 if (last_eq_type
== SEQ_CHARACTER
14732 && eq_type
!= SEQ_CHARACTER
14733 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14736 msg
="Non-NUMERIC object %qs in default NUMERIC "
14737 "EQUIVALENCE statement at %L";
14738 if (last_eq_type
== SEQ_NUMERIC
14739 && eq_type
!= SEQ_NUMERIC
14740 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14745 last_where
= &e
->where
;
14750 /* Shall not be an automatic array. */
14751 if (e
->ref
->type
== REF_ARRAY
14752 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14754 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
14755 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14762 /* Shall not be a structure component. */
14763 if (r
->type
== REF_COMPONENT
)
14765 gfc_error ("Structure component %qs at %L cannot be an "
14766 "EQUIVALENCE object",
14767 r
->u
.c
.component
->name
, &e
->where
);
14771 /* A substring shall not have length zero. */
14772 if (r
->type
== REF_SUBSTRING
)
14774 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14776 gfc_error ("Substring at %L has length zero",
14777 &r
->u
.ss
.start
->where
);
14787 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14790 resolve_fntype (gfc_namespace
*ns
)
14792 gfc_entry_list
*el
;
14795 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14798 /* If there are any entries, ns->proc_name is the entry master
14799 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14801 sym
= ns
->entries
->sym
;
14803 sym
= ns
->proc_name
;
14804 if (sym
->result
== sym
14805 && sym
->ts
.type
== BT_UNKNOWN
14806 && !gfc_set_default_type (sym
, 0, NULL
)
14807 && !sym
->attr
.untyped
)
14809 gfc_error ("Function %qs at %L has no IMPLICIT type",
14810 sym
->name
, &sym
->declared_at
);
14811 sym
->attr
.untyped
= 1;
14814 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14815 && !sym
->attr
.contained
14816 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14817 && gfc_check_symbol_access (sym
))
14819 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
14820 "%L of PRIVATE type %qs", sym
->name
,
14821 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14825 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14827 if (el
->sym
->result
== el
->sym
14828 && el
->sym
->ts
.type
== BT_UNKNOWN
14829 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14830 && !el
->sym
->attr
.untyped
)
14832 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
14833 el
->sym
->name
, &el
->sym
->declared_at
);
14834 el
->sym
->attr
.untyped
= 1;
14840 /* 12.3.2.1.1 Defined operators. */
14843 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14845 gfc_formal_arglist
*formal
;
14847 if (!sym
->attr
.function
)
14849 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
14850 sym
->name
, &where
);
14854 if (sym
->ts
.type
== BT_CHARACTER
14855 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14856 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14857 && sym
->result
->ts
.u
.cl
->length
))
14859 gfc_error ("User operator procedure %qs at %L cannot be assumed "
14860 "character length", sym
->name
, &where
);
14864 formal
= gfc_sym_get_dummy_args (sym
);
14865 if (!formal
|| !formal
->sym
)
14867 gfc_error ("User operator procedure %qs at %L must have at least "
14868 "one argument", sym
->name
, &where
);
14872 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14874 gfc_error ("First argument of operator interface at %L must be "
14875 "INTENT(IN)", &where
);
14879 if (formal
->sym
->attr
.optional
)
14881 gfc_error ("First argument of operator interface at %L cannot be "
14882 "optional", &where
);
14886 formal
= formal
->next
;
14887 if (!formal
|| !formal
->sym
)
14890 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14892 gfc_error ("Second argument of operator interface at %L must be "
14893 "INTENT(IN)", &where
);
14897 if (formal
->sym
->attr
.optional
)
14899 gfc_error ("Second argument of operator interface at %L cannot be "
14900 "optional", &where
);
14906 gfc_error ("Operator interface at %L must have, at most, two "
14907 "arguments", &where
);
14915 gfc_resolve_uops (gfc_symtree
*symtree
)
14917 gfc_interface
*itr
;
14919 if (symtree
== NULL
)
14922 gfc_resolve_uops (symtree
->left
);
14923 gfc_resolve_uops (symtree
->right
);
14925 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14926 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14930 /* Examine all of the expressions associated with a program unit,
14931 assign types to all intermediate expressions, make sure that all
14932 assignments are to compatible types and figure out which names
14933 refer to which functions or subroutines. It doesn't check code
14934 block, which is handled by gfc_resolve_code. */
14937 resolve_types (gfc_namespace
*ns
)
14943 gfc_namespace
* old_ns
= gfc_current_ns
;
14945 if (ns
->types_resolved
)
14948 /* Check that all IMPLICIT types are ok. */
14949 if (!ns
->seen_implicit_none
)
14952 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14953 if (ns
->set_flag
[letter
]
14954 && !resolve_typespec_used (&ns
->default_type
[letter
],
14955 &ns
->implicit_loc
[letter
], NULL
))
14959 gfc_current_ns
= ns
;
14961 resolve_entries (ns
);
14963 resolve_common_vars (ns
->blank_common
.head
, false);
14964 resolve_common_blocks (ns
->common_root
);
14966 resolve_contained_functions (ns
);
14968 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14969 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14970 resolve_formal_arglist (ns
->proc_name
);
14972 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14974 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14975 resolve_charlen (cl
);
14977 gfc_traverse_ns (ns
, resolve_symbol
);
14979 resolve_fntype (ns
);
14981 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14983 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14984 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
14985 "also be PURE", n
->proc_name
->name
,
14986 &n
->proc_name
->declared_at
);
14992 gfc_do_concurrent_flag
= 0;
14993 gfc_check_interfaces (ns
);
14995 gfc_traverse_ns (ns
, resolve_values
);
15001 for (d
= ns
->data
; d
; d
= d
->next
)
15005 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
15007 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
15009 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
15010 resolve_equivalence (eq
);
15012 /* Warn about unused labels. */
15013 if (warn_unused_label
)
15014 warn_unused_fortran_label (ns
->st_labels
);
15016 gfc_resolve_uops (ns
->uop_root
);
15018 gfc_resolve_omp_declare_simd (ns
);
15020 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
15022 ns
->types_resolved
= 1;
15024 gfc_current_ns
= old_ns
;
15028 /* Call gfc_resolve_code recursively. */
15031 resolve_codes (gfc_namespace
*ns
)
15034 bitmap_obstack old_obstack
;
15036 if (ns
->resolved
== 1)
15039 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15042 gfc_current_ns
= ns
;
15044 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15045 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
15048 /* Set to an out of range value. */
15049 current_entry_id
= -1;
15051 old_obstack
= labels_obstack
;
15052 bitmap_obstack_initialize (&labels_obstack
);
15054 gfc_resolve_oacc_declare (ns
);
15055 gfc_resolve_code (ns
->code
, ns
);
15057 bitmap_obstack_release (&labels_obstack
);
15058 labels_obstack
= old_obstack
;
15062 /* This function is called after a complete program unit has been compiled.
15063 Its purpose is to examine all of the expressions associated with a program
15064 unit, assign types to all intermediate expressions, make sure that all
15065 assignments are to compatible types and figure out which names refer to
15066 which functions or subroutines. */
15069 gfc_resolve (gfc_namespace
*ns
)
15071 gfc_namespace
*old_ns
;
15072 code_stack
*old_cs_base
;
15078 old_ns
= gfc_current_ns
;
15079 old_cs_base
= cs_base
;
15081 resolve_types (ns
);
15082 component_assignment_level
= 0;
15083 resolve_codes (ns
);
15085 gfc_current_ns
= old_ns
;
15086 cs_base
= old_cs_base
;
15089 gfc_run_passes (ns
);