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 %qs 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 ("In Fortran 2003 COMMON %qs 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 ("COMMON block %qs 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 ("Fortran 2008: COMMON block %qs 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 ("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 ("COMMON block %qs 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 (e
->expr_type
== EXPR_VARIABLE
1985 && comp
&& comp
->attr
.elemental
)
1987 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1988 "allowed as an actual argument at %L", comp
->name
,
1992 /* Fortran 2008, C1237. */
1993 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1994 && gfc_has_ultimate_pointer (e
))
1996 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1997 "component", &e
->where
);
2001 first_actual_arg
= false;
2004 return_value
= true;
2007 actual_arg
= actual_arg_sav
;
2008 first_actual_arg
= first_actual_arg_sav
;
2010 return return_value
;
2014 /* Do the checks of the actual argument list that are specific to elemental
2015 procedures. If called with c == NULL, we have a function, otherwise if
2016 expr == NULL, we have a subroutine. */
2019 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2021 gfc_actual_arglist
*arg0
;
2022 gfc_actual_arglist
*arg
;
2023 gfc_symbol
*esym
= NULL
;
2024 gfc_intrinsic_sym
*isym
= NULL
;
2026 gfc_intrinsic_arg
*iformal
= NULL
;
2027 gfc_formal_arglist
*eformal
= NULL
;
2028 bool formal_optional
= false;
2029 bool set_by_optional
= false;
2033 /* Is this an elemental procedure? */
2034 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2036 if (expr
->value
.function
.esym
!= NULL
2037 && expr
->value
.function
.esym
->attr
.elemental
)
2039 arg0
= expr
->value
.function
.actual
;
2040 esym
= expr
->value
.function
.esym
;
2042 else if (expr
->value
.function
.isym
!= NULL
2043 && expr
->value
.function
.isym
->elemental
)
2045 arg0
= expr
->value
.function
.actual
;
2046 isym
= expr
->value
.function
.isym
;
2051 else if (c
&& c
->ext
.actual
!= NULL
)
2053 arg0
= c
->ext
.actual
;
2055 if (c
->resolved_sym
)
2056 esym
= c
->resolved_sym
;
2058 esym
= c
->symtree
->n
.sym
;
2061 if (!esym
->attr
.elemental
)
2067 /* The rank of an elemental is the rank of its array argument(s). */
2068 for (arg
= arg0
; arg
; arg
= arg
->next
)
2070 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2072 rank
= arg
->expr
->rank
;
2073 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2074 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2075 set_by_optional
= true;
2077 /* Function specific; set the result rank and shape. */
2081 if (!expr
->shape
&& arg
->expr
->shape
)
2083 expr
->shape
= gfc_get_shape (rank
);
2084 for (i
= 0; i
< rank
; i
++)
2085 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2092 /* If it is an array, it shall not be supplied as an actual argument
2093 to an elemental procedure unless an array of the same rank is supplied
2094 as an actual argument corresponding to a nonoptional dummy argument of
2095 that elemental procedure(12.4.1.5). */
2096 formal_optional
= false;
2098 iformal
= isym
->formal
;
2100 eformal
= esym
->formal
;
2102 for (arg
= arg0
; arg
; arg
= arg
->next
)
2106 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2107 formal_optional
= true;
2108 eformal
= eformal
->next
;
2110 else if (isym
&& iformal
)
2112 if (iformal
->optional
)
2113 formal_optional
= true;
2114 iformal
= iformal
->next
;
2117 formal_optional
= true;
2119 if (pedantic
&& arg
->expr
!= NULL
2120 && arg
->expr
->expr_type
== EXPR_VARIABLE
2121 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2124 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2125 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2127 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2128 "MISSING, it cannot be the actual argument of an "
2129 "ELEMENTAL procedure unless there is a non-optional "
2130 "argument with the same rank (12.4.1.5)",
2131 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2135 for (arg
= arg0
; arg
; arg
= arg
->next
)
2137 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2140 /* Being elemental, the last upper bound of an assumed size array
2141 argument must be present. */
2142 if (resolve_assumed_size_actual (arg
->expr
))
2145 /* Elemental procedure's array actual arguments must conform. */
2148 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2155 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2156 is an array, the intent inout/out variable needs to be also an array. */
2157 if (rank
> 0 && esym
&& expr
== NULL
)
2158 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2159 arg
= arg
->next
, eformal
= eformal
->next
)
2160 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2161 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2162 && arg
->expr
&& arg
->expr
->rank
== 0)
2164 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2165 "ELEMENTAL subroutine %qs is a scalar, but another "
2166 "actual argument is an array", &arg
->expr
->where
,
2167 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2168 : "INOUT", eformal
->sym
->name
, esym
->name
);
2175 /* This function does the checking of references to global procedures
2176 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2177 77 and 95 standards. It checks for a gsymbol for the name, making
2178 one if it does not already exist. If it already exists, then the
2179 reference being resolved must correspond to the type of gsymbol.
2180 Otherwise, the new symbol is equipped with the attributes of the
2181 reference. The corresponding code that is called in creating
2182 global entities is parse.c.
2184 In addition, for all but -std=legacy, the gsymbols are used to
2185 check the interfaces of external procedures from the same file.
2186 The namespace of the gsymbol is resolved and then, once this is
2187 done the interface is checked. */
2191 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2193 if (!gsym_ns
->proc_name
->attr
.recursive
)
2196 if (sym
->ns
== gsym_ns
)
2199 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2206 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2208 if (gsym_ns
->entries
)
2210 gfc_entry_list
*entry
= gsym_ns
->entries
;
2212 for (; entry
; entry
= entry
->next
)
2214 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2216 if (strcmp (gsym_ns
->proc_name
->name
,
2217 sym
->ns
->proc_name
->name
) == 0)
2221 && strcmp (gsym_ns
->proc_name
->name
,
2222 sym
->ns
->parent
->proc_name
->name
) == 0)
2231 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2234 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2236 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2238 for ( ; arg
; arg
= arg
->next
)
2243 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2245 strncpy (errmsg
, _("allocatable argument"), err_len
);
2248 else if (arg
->sym
->attr
.asynchronous
)
2250 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2253 else if (arg
->sym
->attr
.optional
)
2255 strncpy (errmsg
, _("optional argument"), err_len
);
2258 else if (arg
->sym
->attr
.pointer
)
2260 strncpy (errmsg
, _("pointer argument"), err_len
);
2263 else if (arg
->sym
->attr
.target
)
2265 strncpy (errmsg
, _("target argument"), err_len
);
2268 else if (arg
->sym
->attr
.value
)
2270 strncpy (errmsg
, _("value argument"), err_len
);
2273 else if (arg
->sym
->attr
.volatile_
)
2275 strncpy (errmsg
, _("volatile argument"), err_len
);
2278 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2280 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2283 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2285 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2288 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2290 strncpy (errmsg
, _("coarray argument"), err_len
);
2293 else if (false) /* (2d) TODO: parametrized derived type */
2295 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2298 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2300 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2303 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2305 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2308 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2310 /* As assumed-type is unlimited polymorphic (cf. above).
2311 See also TS 29113, Note 6.1. */
2312 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2317 if (sym
->attr
.function
)
2319 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2321 if (res
->attr
.dimension
) /* (3a) */
2323 strncpy (errmsg
, _("array result"), err_len
);
2326 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2328 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2331 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2332 && res
->ts
.u
.cl
->length
2333 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2335 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2340 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2342 strncpy (errmsg
, _("elemental procedure"), err_len
);
2345 else if (sym
->attr
.is_bind_c
) /* (5) */
2347 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2356 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2357 gfc_actual_arglist
**actual
, int sub
)
2361 enum gfc_symbol_type type
;
2364 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2366 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2368 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2369 gfc_global_used (gsym
, where
);
2371 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2372 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2373 && gsym
->type
!= GSYM_UNKNOWN
2374 && !gsym
->binding_label
2376 && gsym
->ns
->resolved
!= -1
2377 && gsym
->ns
->proc_name
2378 && not_in_recursive (sym
, gsym
->ns
)
2379 && not_entry_self_reference (sym
, gsym
->ns
))
2381 gfc_symbol
*def_sym
;
2383 /* Resolve the gsymbol namespace if needed. */
2384 if (!gsym
->ns
->resolved
)
2386 gfc_dt_list
*old_dt_list
;
2387 struct gfc_omp_saved_state old_omp_state
;
2389 /* Stash away derived types so that the backend_decls do not
2391 old_dt_list
= gfc_derived_types
;
2392 gfc_derived_types
= NULL
;
2393 /* And stash away openmp state. */
2394 gfc_omp_save_and_clear_state (&old_omp_state
);
2396 gfc_resolve (gsym
->ns
);
2398 /* Store the new derived types with the global namespace. */
2399 if (gfc_derived_types
)
2400 gsym
->ns
->derived_types
= gfc_derived_types
;
2402 /* Restore the derived types of this namespace. */
2403 gfc_derived_types
= old_dt_list
;
2404 /* And openmp state. */
2405 gfc_omp_restore_state (&old_omp_state
);
2408 /* Make sure that translation for the gsymbol occurs before
2409 the procedure currently being resolved. */
2410 ns
= gfc_global_ns_list
;
2411 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2413 if (ns
->sibling
== gsym
->ns
)
2415 ns
->sibling
= gsym
->ns
->sibling
;
2416 gsym
->ns
->sibling
= gfc_global_ns_list
;
2417 gfc_global_ns_list
= gsym
->ns
;
2422 def_sym
= gsym
->ns
->proc_name
;
2424 /* This can happen if a binding name has been specified. */
2425 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2426 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2428 if (def_sym
->attr
.entry_master
)
2430 gfc_entry_list
*entry
;
2431 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2432 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2434 def_sym
= entry
->sym
;
2439 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2441 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2442 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2443 gfc_typename (&def_sym
->ts
));
2447 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2448 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2450 gfc_error ("Explicit interface required for %qs at %L: %s",
2451 sym
->name
, &sym
->declared_at
, reason
);
2455 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2456 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2457 gfc_errors_to_warnings (true);
2459 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2460 reason
, sizeof(reason
), NULL
, NULL
))
2462 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2463 sym
->name
, &sym
->declared_at
, reason
);
2468 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2469 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2470 gfc_errors_to_warnings (true);
2472 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2473 gfc_procedure_use (def_sym
, actual
, where
);
2477 gfc_errors_to_warnings (false);
2479 if (gsym
->type
== GSYM_UNKNOWN
)
2482 gsym
->where
= *where
;
2489 /************* Function resolution *************/
2491 /* Resolve a function call known to be generic.
2492 Section 14.1.2.4.1. */
2495 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2499 if (sym
->attr
.generic
)
2501 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2504 expr
->value
.function
.name
= s
->name
;
2505 expr
->value
.function
.esym
= s
;
2507 if (s
->ts
.type
!= BT_UNKNOWN
)
2509 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2510 expr
->ts
= s
->result
->ts
;
2513 expr
->rank
= s
->as
->rank
;
2514 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2515 expr
->rank
= s
->result
->as
->rank
;
2517 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2522 /* TODO: Need to search for elemental references in generic
2526 if (sym
->attr
.intrinsic
)
2527 return gfc_intrinsic_func_interface (expr
, 0);
2534 resolve_generic_f (gfc_expr
*expr
)
2538 gfc_interface
*intr
= NULL
;
2540 sym
= expr
->symtree
->n
.sym
;
2544 m
= resolve_generic_f0 (expr
, sym
);
2547 else if (m
== MATCH_ERROR
)
2552 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2553 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2556 if (sym
->ns
->parent
== NULL
)
2558 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2562 if (!generic_sym (sym
))
2566 /* Last ditch attempt. See if the reference is to an intrinsic
2567 that possesses a matching interface. 14.1.2.4 */
2568 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2570 gfc_error ("There is no specific function for the generic %qs "
2571 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2577 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2580 return resolve_structure_cons (expr
, 0);
2583 m
= gfc_intrinsic_func_interface (expr
, 0);
2588 gfc_error ("Generic function %qs at %L is not consistent with a "
2589 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2596 /* Resolve a function call known to be specific. */
2599 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2603 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2605 if (sym
->attr
.dummy
)
2607 sym
->attr
.proc
= PROC_DUMMY
;
2611 sym
->attr
.proc
= PROC_EXTERNAL
;
2615 if (sym
->attr
.proc
== PROC_MODULE
2616 || sym
->attr
.proc
== PROC_ST_FUNCTION
2617 || sym
->attr
.proc
== PROC_INTERNAL
)
2620 if (sym
->attr
.intrinsic
)
2622 m
= gfc_intrinsic_func_interface (expr
, 1);
2626 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2627 "with an intrinsic", sym
->name
, &expr
->where
);
2635 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2638 expr
->ts
= sym
->result
->ts
;
2641 expr
->value
.function
.name
= sym
->name
;
2642 expr
->value
.function
.esym
= sym
;
2643 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2645 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2647 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2648 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2649 else if (sym
->as
!= NULL
)
2650 expr
->rank
= sym
->as
->rank
;
2657 resolve_specific_f (gfc_expr
*expr
)
2662 sym
= expr
->symtree
->n
.sym
;
2666 m
= resolve_specific_f0 (sym
, expr
);
2669 if (m
== MATCH_ERROR
)
2672 if (sym
->ns
->parent
== NULL
)
2675 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2681 gfc_error ("Unable to resolve the specific function %qs at %L",
2682 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2688 /* Resolve a procedure call not known to be generic nor specific. */
2691 resolve_unknown_f (gfc_expr
*expr
)
2696 sym
= expr
->symtree
->n
.sym
;
2698 if (sym
->attr
.dummy
)
2700 sym
->attr
.proc
= PROC_DUMMY
;
2701 expr
->value
.function
.name
= sym
->name
;
2705 /* See if we have an intrinsic function reference. */
2707 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2709 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2714 /* The reference is to an external name. */
2716 sym
->attr
.proc
= PROC_EXTERNAL
;
2717 expr
->value
.function
.name
= sym
->name
;
2718 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2720 if (sym
->as
!= NULL
)
2721 expr
->rank
= sym
->as
->rank
;
2723 /* Type of the expression is either the type of the symbol or the
2724 default type of the symbol. */
2727 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2729 if (sym
->ts
.type
!= BT_UNKNOWN
)
2733 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2735 if (ts
->type
== BT_UNKNOWN
)
2737 gfc_error ("Function %qs at %L has no IMPLICIT type",
2738 sym
->name
, &expr
->where
);
2749 /* Return true, if the symbol is an external procedure. */
2751 is_external_proc (gfc_symbol
*sym
)
2753 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2754 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2755 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2756 && !sym
->attr
.proc_pointer
2757 && !sym
->attr
.use_assoc
2765 /* Figure out if a function reference is pure or not. Also set the name
2766 of the function for a potential error message. Return nonzero if the
2767 function is PURE, zero if not. */
2769 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2772 pure_function (gfc_expr
*e
, const char **name
)
2775 gfc_component
*comp
;
2779 if (e
->symtree
!= NULL
2780 && e
->symtree
->n
.sym
!= NULL
2781 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2782 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2784 comp
= gfc_get_proc_ptr_comp (e
);
2787 pure
= gfc_pure (comp
->ts
.interface
);
2790 else if (e
->value
.function
.esym
)
2792 pure
= gfc_pure (e
->value
.function
.esym
);
2793 *name
= e
->value
.function
.esym
->name
;
2795 else if (e
->value
.function
.isym
)
2797 pure
= e
->value
.function
.isym
->pure
2798 || e
->value
.function
.isym
->elemental
;
2799 *name
= e
->value
.function
.isym
->name
;
2803 /* Implicit functions are not pure. */
2805 *name
= e
->value
.function
.name
;
2813 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2814 int *f ATTRIBUTE_UNUSED
)
2818 /* Don't bother recursing into other statement functions
2819 since they will be checked individually for purity. */
2820 if (e
->expr_type
!= EXPR_FUNCTION
2822 || e
->symtree
->n
.sym
== sym
2823 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2826 return pure_function (e
, &name
) ? false : true;
2831 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2833 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2837 /* Check if an impure function is allowed in the current context. */
2839 static bool check_pure_function (gfc_expr
*e
)
2841 const char *name
= NULL
;
2842 if (!pure_function (e
, &name
) && name
)
2846 gfc_error ("Reference to impure function %qs at %L inside a "
2847 "FORALL %s", name
, &e
->where
,
2848 forall_flag
== 2 ? "mask" : "block");
2851 else if (gfc_do_concurrent_flag
)
2853 gfc_error ("Reference to impure function %qs at %L inside a "
2854 "DO CONCURRENT %s", name
, &e
->where
,
2855 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2858 else if (gfc_pure (NULL
))
2860 gfc_error ("Reference to impure function %qs at %L "
2861 "within a PURE procedure", name
, &e
->where
);
2864 gfc_unset_implicit_pure (NULL
);
2870 /* Update current procedure's array_outer_dependency flag, considering
2871 a call to procedure SYM. */
2874 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2876 /* Check to see if this is a sibling function that has not yet
2878 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2879 for (; sibling
; sibling
= sibling
->sibling
)
2881 if (sibling
->proc_name
== sym
)
2883 gfc_resolve (sibling
);
2888 /* If SYM has references to outer arrays, so has the procedure calling
2889 SYM. If SYM is a procedure pointer, we can assume the worst. */
2890 if (sym
->attr
.array_outer_dependency
2891 || sym
->attr
.proc_pointer
)
2892 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2896 /* Resolve a function call, which means resolving the arguments, then figuring
2897 out which entity the name refers to. */
2900 resolve_function (gfc_expr
*expr
)
2902 gfc_actual_arglist
*arg
;
2906 procedure_type p
= PROC_INTRINSIC
;
2907 bool no_formal_args
;
2911 sym
= expr
->symtree
->n
.sym
;
2913 /* If this is a procedure pointer component, it has already been resolved. */
2914 if (gfc_is_proc_ptr_comp (expr
))
2917 if (sym
&& sym
->attr
.intrinsic
2918 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2921 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2923 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2927 /* If this ia a deferred TBP with an abstract interface (which may
2928 of course be referenced), expr->value.function.esym will be set. */
2929 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2931 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2932 sym
->name
, &expr
->where
);
2936 /* Switch off assumed size checking and do this again for certain kinds
2937 of procedure, once the procedure itself is resolved. */
2938 need_full_assumed_size
++;
2940 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2941 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2943 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2944 inquiry_argument
= true;
2945 no_formal_args
= sym
&& is_external_proc (sym
)
2946 && gfc_sym_get_dummy_args (sym
) == NULL
;
2948 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2951 inquiry_argument
= false;
2955 inquiry_argument
= false;
2957 /* Resume assumed_size checking. */
2958 need_full_assumed_size
--;
2960 /* If the procedure is external, check for usage. */
2961 if (sym
&& is_external_proc (sym
))
2962 resolve_global_procedure (sym
, &expr
->where
,
2963 &expr
->value
.function
.actual
, 0);
2965 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2967 && sym
->ts
.u
.cl
->length
== NULL
2969 && !sym
->ts
.deferred
2970 && expr
->value
.function
.esym
== NULL
2971 && !sym
->attr
.contained
)
2973 /* Internal procedures are taken care of in resolve_contained_fntype. */
2974 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2975 "be used at %L since it is not a dummy argument",
2976 sym
->name
, &expr
->where
);
2980 /* See if function is already resolved. */
2982 if (expr
->value
.function
.name
!= NULL
2983 || expr
->value
.function
.isym
!= NULL
)
2985 if (expr
->ts
.type
== BT_UNKNOWN
)
2991 /* Apply the rules of section 14.1.2. */
2993 switch (procedure_kind (sym
))
2996 t
= resolve_generic_f (expr
);
2999 case PTYPE_SPECIFIC
:
3000 t
= resolve_specific_f (expr
);
3004 t
= resolve_unknown_f (expr
);
3008 gfc_internal_error ("resolve_function(): bad function type");
3012 /* If the expression is still a function (it might have simplified),
3013 then we check to see if we are calling an elemental function. */
3015 if (expr
->expr_type
!= EXPR_FUNCTION
)
3018 temp
= need_full_assumed_size
;
3019 need_full_assumed_size
= 0;
3021 if (!resolve_elemental_actual (expr
, NULL
))
3024 if (omp_workshare_flag
3025 && expr
->value
.function
.esym
3026 && ! gfc_elemental (expr
->value
.function
.esym
))
3028 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3029 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3034 #define GENERIC_ID expr->value.function.isym->id
3035 else if (expr
->value
.function
.actual
!= NULL
3036 && expr
->value
.function
.isym
!= NULL
3037 && GENERIC_ID
!= GFC_ISYM_LBOUND
3038 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3039 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3040 && GENERIC_ID
!= GFC_ISYM_LEN
3041 && GENERIC_ID
!= GFC_ISYM_LOC
3042 && GENERIC_ID
!= GFC_ISYM_C_LOC
3043 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3045 /* Array intrinsics must also have the last upper bound of an
3046 assumed size array argument. UBOUND and SIZE have to be
3047 excluded from the check if the second argument is anything
3050 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3052 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3053 && arg
== expr
->value
.function
.actual
3054 && arg
->next
!= NULL
&& arg
->next
->expr
)
3056 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3059 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3062 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3067 if (arg
->expr
!= NULL
3068 && arg
->expr
->rank
> 0
3069 && resolve_assumed_size_actual (arg
->expr
))
3075 need_full_assumed_size
= temp
;
3077 if (!check_pure_function(expr
))
3080 /* Functions without the RECURSIVE attribution are not allowed to
3081 * call themselves. */
3082 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3085 esym
= expr
->value
.function
.esym
;
3087 if (is_illegal_recursion (esym
, gfc_current_ns
))
3089 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3090 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3091 " function %qs is not RECURSIVE",
3092 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3094 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3095 " is not RECURSIVE", esym
->name
, &expr
->where
);
3101 /* Character lengths of use associated functions may contains references to
3102 symbols not referenced from the current program unit otherwise. Make sure
3103 those symbols are marked as referenced. */
3105 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3106 && expr
->value
.function
.esym
->attr
.use_assoc
)
3108 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3111 /* Make sure that the expression has a typespec that works. */
3112 if (expr
->ts
.type
== BT_UNKNOWN
)
3114 if (expr
->symtree
->n
.sym
->result
3115 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3116 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3117 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3120 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3122 if (expr
->value
.function
.esym
)
3123 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3125 update_current_proc_array_outer_dependency (sym
);
3128 /* typebound procedure: Assume the worst. */
3129 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3135 /************* Subroutine resolution *************/
3138 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3145 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3149 else if (gfc_do_concurrent_flag
)
3151 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3155 else if (gfc_pure (NULL
))
3157 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3161 gfc_unset_implicit_pure (NULL
);
3167 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3171 if (sym
->attr
.generic
)
3173 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3176 c
->resolved_sym
= s
;
3177 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3182 /* TODO: Need to search for elemental references in generic interface. */
3185 if (sym
->attr
.intrinsic
)
3186 return gfc_intrinsic_sub_interface (c
, 0);
3193 resolve_generic_s (gfc_code
*c
)
3198 sym
= c
->symtree
->n
.sym
;
3202 m
= resolve_generic_s0 (c
, sym
);
3205 else if (m
== MATCH_ERROR
)
3209 if (sym
->ns
->parent
== NULL
)
3211 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3215 if (!generic_sym (sym
))
3219 /* Last ditch attempt. See if the reference is to an intrinsic
3220 that possesses a matching interface. 14.1.2.4 */
3221 sym
= c
->symtree
->n
.sym
;
3223 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3225 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3226 sym
->name
, &c
->loc
);
3230 m
= gfc_intrinsic_sub_interface (c
, 0);
3234 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3235 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3241 /* Resolve a subroutine call known to be specific. */
3244 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3248 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3250 if (sym
->attr
.dummy
)
3252 sym
->attr
.proc
= PROC_DUMMY
;
3256 sym
->attr
.proc
= PROC_EXTERNAL
;
3260 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3263 if (sym
->attr
.intrinsic
)
3265 m
= gfc_intrinsic_sub_interface (c
, 1);
3269 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3270 "with an intrinsic", sym
->name
, &c
->loc
);
3278 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3280 c
->resolved_sym
= sym
;
3281 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3289 resolve_specific_s (gfc_code
*c
)
3294 sym
= c
->symtree
->n
.sym
;
3298 m
= resolve_specific_s0 (c
, sym
);
3301 if (m
== MATCH_ERROR
)
3304 if (sym
->ns
->parent
== NULL
)
3307 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3313 sym
= c
->symtree
->n
.sym
;
3314 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3315 sym
->name
, &c
->loc
);
3321 /* Resolve a subroutine call not known to be generic nor specific. */
3324 resolve_unknown_s (gfc_code
*c
)
3328 sym
= c
->symtree
->n
.sym
;
3330 if (sym
->attr
.dummy
)
3332 sym
->attr
.proc
= PROC_DUMMY
;
3336 /* See if we have an intrinsic function reference. */
3338 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3340 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3345 /* The reference is to an external name. */
3348 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3350 c
->resolved_sym
= sym
;
3352 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3356 /* Resolve a subroutine call. Although it was tempting to use the same code
3357 for functions, subroutines and functions are stored differently and this
3358 makes things awkward. */
3361 resolve_call (gfc_code
*c
)
3364 procedure_type ptype
= PROC_INTRINSIC
;
3365 gfc_symbol
*csym
, *sym
;
3366 bool no_formal_args
;
3368 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3370 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3372 gfc_error ("%qs at %L has a type, which is not consistent with "
3373 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3377 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3380 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3381 sym
= st
? st
->n
.sym
: NULL
;
3382 if (sym
&& csym
!= sym
3383 && sym
->ns
== gfc_current_ns
3384 && sym
->attr
.flavor
== FL_PROCEDURE
3385 && sym
->attr
.contained
)
3388 if (csym
->attr
.generic
)
3389 c
->symtree
->n
.sym
= sym
;
3392 csym
= c
->symtree
->n
.sym
;
3396 /* If this ia a deferred TBP, c->expr1 will be set. */
3397 if (!c
->expr1
&& csym
)
3399 if (csym
->attr
.abstract
)
3401 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3402 csym
->name
, &c
->loc
);
3406 /* Subroutines without the RECURSIVE attribution are not allowed to
3408 if (is_illegal_recursion (csym
, gfc_current_ns
))
3410 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3411 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3412 "as subroutine %qs is not RECURSIVE",
3413 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3415 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3416 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3422 /* Switch off assumed size checking and do this again for certain kinds
3423 of procedure, once the procedure itself is resolved. */
3424 need_full_assumed_size
++;
3427 ptype
= csym
->attr
.proc
;
3429 no_formal_args
= csym
&& is_external_proc (csym
)
3430 && gfc_sym_get_dummy_args (csym
) == NULL
;
3431 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3434 /* Resume assumed_size checking. */
3435 need_full_assumed_size
--;
3437 /* If external, check for usage. */
3438 if (csym
&& is_external_proc (csym
))
3439 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3442 if (c
->resolved_sym
== NULL
)
3444 c
->resolved_isym
= NULL
;
3445 switch (procedure_kind (csym
))
3448 t
= resolve_generic_s (c
);
3451 case PTYPE_SPECIFIC
:
3452 t
= resolve_specific_s (c
);
3456 t
= resolve_unknown_s (c
);
3460 gfc_internal_error ("resolve_subroutine(): bad function type");
3464 /* Some checks of elemental subroutine actual arguments. */
3465 if (!resolve_elemental_actual (NULL
, c
))
3469 update_current_proc_array_outer_dependency (csym
);
3471 /* Typebound procedure: Assume the worst. */
3472 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3478 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3479 op1->shape and op2->shape are non-NULL return true if their shapes
3480 match. If both op1->shape and op2->shape are non-NULL return false
3481 if their shapes do not match. If either op1->shape or op2->shape is
3482 NULL, return true. */
3485 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3492 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3494 for (i
= 0; i
< op1
->rank
; i
++)
3496 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3498 gfc_error ("Shapes for operands at %L and %L are not conformable",
3499 &op1
->where
, &op2
->where
);
3510 /* Resolve an operator expression node. This can involve replacing the
3511 operation with a user defined function call. */
3514 resolve_operator (gfc_expr
*e
)
3516 gfc_expr
*op1
, *op2
;
3518 bool dual_locus_error
;
3521 /* Resolve all subnodes-- give them types. */
3523 switch (e
->value
.op
.op
)
3526 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3529 /* Fall through... */
3532 case INTRINSIC_UPLUS
:
3533 case INTRINSIC_UMINUS
:
3534 case INTRINSIC_PARENTHESES
:
3535 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3540 /* Typecheck the new node. */
3542 op1
= e
->value
.op
.op1
;
3543 op2
= e
->value
.op
.op2
;
3544 dual_locus_error
= false;
3546 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3547 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3549 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3553 switch (e
->value
.op
.op
)
3555 case INTRINSIC_UPLUS
:
3556 case INTRINSIC_UMINUS
:
3557 if (op1
->ts
.type
== BT_INTEGER
3558 || op1
->ts
.type
== BT_REAL
3559 || op1
->ts
.type
== BT_COMPLEX
)
3565 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3566 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3569 case INTRINSIC_PLUS
:
3570 case INTRINSIC_MINUS
:
3571 case INTRINSIC_TIMES
:
3572 case INTRINSIC_DIVIDE
:
3573 case INTRINSIC_POWER
:
3574 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3576 gfc_type_convert_binary (e
, 1);
3581 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3582 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3583 gfc_typename (&op2
->ts
));
3586 case INTRINSIC_CONCAT
:
3587 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3588 && op1
->ts
.kind
== op2
->ts
.kind
)
3590 e
->ts
.type
= BT_CHARACTER
;
3591 e
->ts
.kind
= op1
->ts
.kind
;
3596 _("Operands of string concatenation operator at %%L are %s/%s"),
3597 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3603 case INTRINSIC_NEQV
:
3604 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3606 e
->ts
.type
= BT_LOGICAL
;
3607 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3608 if (op1
->ts
.kind
< e
->ts
.kind
)
3609 gfc_convert_type (op1
, &e
->ts
, 2);
3610 else if (op2
->ts
.kind
< e
->ts
.kind
)
3611 gfc_convert_type (op2
, &e
->ts
, 2);
3615 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3616 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3617 gfc_typename (&op2
->ts
));
3622 if (op1
->ts
.type
== BT_LOGICAL
)
3624 e
->ts
.type
= BT_LOGICAL
;
3625 e
->ts
.kind
= op1
->ts
.kind
;
3629 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3630 gfc_typename (&op1
->ts
));
3634 case INTRINSIC_GT_OS
:
3636 case INTRINSIC_GE_OS
:
3638 case INTRINSIC_LT_OS
:
3640 case INTRINSIC_LE_OS
:
3641 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3643 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3647 /* Fall through... */
3650 case INTRINSIC_EQ_OS
:
3652 case INTRINSIC_NE_OS
:
3653 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3654 && op1
->ts
.kind
== op2
->ts
.kind
)
3656 e
->ts
.type
= BT_LOGICAL
;
3657 e
->ts
.kind
= gfc_default_logical_kind
;
3661 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3663 gfc_type_convert_binary (e
, 1);
3665 e
->ts
.type
= BT_LOGICAL
;
3666 e
->ts
.kind
= gfc_default_logical_kind
;
3668 if (warn_compare_reals
)
3670 gfc_intrinsic_op op
= e
->value
.op
.op
;
3672 /* Type conversion has made sure that the types of op1 and op2
3673 agree, so it is only necessary to check the first one. */
3674 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3675 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3676 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3680 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3681 msg
= "Equality comparison for %s at %L";
3683 msg
= "Inequality comparison for %s at %L";
3685 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3692 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3694 _("Logicals at %%L must be compared with %s instead of %s"),
3695 (e
->value
.op
.op
== INTRINSIC_EQ
3696 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3697 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3700 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3701 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3702 gfc_typename (&op2
->ts
));
3706 case INTRINSIC_USER
:
3707 if (e
->value
.op
.uop
->op
== NULL
)
3708 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3709 else if (op2
== NULL
)
3710 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3711 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3714 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3715 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3716 gfc_typename (&op2
->ts
));
3717 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3722 case INTRINSIC_PARENTHESES
:
3724 if (e
->ts
.type
== BT_CHARACTER
)
3725 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3729 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3732 /* Deal with arrayness of an operand through an operator. */
3736 switch (e
->value
.op
.op
)
3738 case INTRINSIC_PLUS
:
3739 case INTRINSIC_MINUS
:
3740 case INTRINSIC_TIMES
:
3741 case INTRINSIC_DIVIDE
:
3742 case INTRINSIC_POWER
:
3743 case INTRINSIC_CONCAT
:
3747 case INTRINSIC_NEQV
:
3749 case INTRINSIC_EQ_OS
:
3751 case INTRINSIC_NE_OS
:
3753 case INTRINSIC_GT_OS
:
3755 case INTRINSIC_GE_OS
:
3757 case INTRINSIC_LT_OS
:
3759 case INTRINSIC_LE_OS
:
3761 if (op1
->rank
== 0 && op2
->rank
== 0)
3764 if (op1
->rank
== 0 && op2
->rank
!= 0)
3766 e
->rank
= op2
->rank
;
3768 if (e
->shape
== NULL
)
3769 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3772 if (op1
->rank
!= 0 && op2
->rank
== 0)
3774 e
->rank
= op1
->rank
;
3776 if (e
->shape
== NULL
)
3777 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3780 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3782 if (op1
->rank
== op2
->rank
)
3784 e
->rank
= op1
->rank
;
3785 if (e
->shape
== NULL
)
3787 t
= compare_shapes (op1
, op2
);
3791 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3796 /* Allow higher level expressions to work. */
3799 /* Try user-defined operators, and otherwise throw an error. */
3800 dual_locus_error
= true;
3802 _("Inconsistent ranks for operator at %%L and %%L"));
3809 case INTRINSIC_PARENTHESES
:
3811 case INTRINSIC_UPLUS
:
3812 case INTRINSIC_UMINUS
:
3813 /* Simply copy arrayness attribute */
3814 e
->rank
= op1
->rank
;
3816 if (e
->shape
== NULL
)
3817 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3825 /* Attempt to simplify the expression. */
3828 t
= gfc_simplify_expr (e
, 0);
3829 /* Some calls do not succeed in simplification and return false
3830 even though there is no error; e.g. variable references to
3831 PARAMETER arrays. */
3832 if (!gfc_is_constant_expr (e
))
3840 match m
= gfc_extend_expr (e
);
3843 if (m
== MATCH_ERROR
)
3847 if (dual_locus_error
)
3848 gfc_error (msg
, &op1
->where
, &op2
->where
);
3850 gfc_error (msg
, &e
->where
);
3856 /************** Array resolution subroutines **************/
3859 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3862 /* Compare two integer expressions. */
3864 static compare_result
3865 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3869 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3870 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3873 /* If either of the types isn't INTEGER, we must have
3874 raised an error earlier. */
3876 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3879 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3889 /* Compare an integer expression with an integer. */
3891 static compare_result
3892 compare_bound_int (gfc_expr
*a
, int b
)
3896 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3899 if (a
->ts
.type
!= BT_INTEGER
)
3900 gfc_internal_error ("compare_bound_int(): Bad expression");
3902 i
= mpz_cmp_si (a
->value
.integer
, b
);
3912 /* Compare an integer expression with a mpz_t. */
3914 static compare_result
3915 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3919 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3922 if (a
->ts
.type
!= BT_INTEGER
)
3923 gfc_internal_error ("compare_bound_int(): Bad expression");
3925 i
= mpz_cmp (a
->value
.integer
, b
);
3935 /* Compute the last value of a sequence given by a triplet.
3936 Return 0 if it wasn't able to compute the last value, or if the
3937 sequence if empty, and 1 otherwise. */
3940 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3941 gfc_expr
*stride
, mpz_t last
)
3945 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3946 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3947 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3950 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3951 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3954 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3956 if (compare_bound (start
, end
) == CMP_GT
)
3958 mpz_set (last
, end
->value
.integer
);
3962 if (compare_bound_int (stride
, 0) == CMP_GT
)
3964 /* Stride is positive */
3965 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3970 /* Stride is negative */
3971 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3976 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3977 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3978 mpz_sub (last
, end
->value
.integer
, rem
);
3985 /* Compare a single dimension of an array reference to the array
3989 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3993 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3995 gcc_assert (ar
->stride
[i
] == NULL
);
3996 /* This implies [*] as [*:] and [*:3] are not possible. */
3997 if (ar
->start
[i
] == NULL
)
3999 gcc_assert (ar
->end
[i
] == NULL
);
4004 /* Given start, end and stride values, calculate the minimum and
4005 maximum referenced indexes. */
4007 switch (ar
->dimen_type
[i
])
4010 case DIMEN_THIS_IMAGE
:
4015 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4018 gfc_warning (0, "Array reference at %L is out of bounds "
4019 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4020 mpz_get_si (ar
->start
[i
]->value
.integer
),
4021 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4023 gfc_warning (0, "Array reference at %L is out of bounds "
4024 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4025 mpz_get_si (ar
->start
[i
]->value
.integer
),
4026 mpz_get_si (as
->lower
[i
]->value
.integer
),
4030 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4033 gfc_warning (0, "Array reference at %L is out of bounds "
4034 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4035 mpz_get_si (ar
->start
[i
]->value
.integer
),
4036 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4038 gfc_warning (0, "Array reference at %L is out of bounds "
4039 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4040 mpz_get_si (ar
->start
[i
]->value
.integer
),
4041 mpz_get_si (as
->upper
[i
]->value
.integer
),
4050 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4051 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4053 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4055 /* Check for zero stride, which is not allowed. */
4056 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4058 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4062 /* if start == len || (stride > 0 && start < len)
4063 || (stride < 0 && start > len),
4064 then the array section contains at least one element. In this
4065 case, there is an out-of-bounds access if
4066 (start < lower || start > upper). */
4067 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4068 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4069 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4070 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4071 && comp_start_end
== CMP_GT
))
4073 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4075 gfc_warning (0, "Lower array reference at %L is out of bounds "
4076 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4077 mpz_get_si (AR_START
->value
.integer
),
4078 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4081 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4083 gfc_warning (0, "Lower array reference at %L is out of bounds "
4084 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4085 mpz_get_si (AR_START
->value
.integer
),
4086 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4091 /* If we can compute the highest index of the array section,
4092 then it also has to be between lower and upper. */
4093 mpz_init (last_value
);
4094 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4097 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4099 gfc_warning (0, "Upper array reference at %L is out of bounds "
4100 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4101 mpz_get_si (last_value
),
4102 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4103 mpz_clear (last_value
);
4106 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4108 gfc_warning (0, "Upper array reference at %L is out of bounds "
4109 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4110 mpz_get_si (last_value
),
4111 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4112 mpz_clear (last_value
);
4116 mpz_clear (last_value
);
4124 gfc_internal_error ("check_dimension(): Bad array reference");
4131 /* Compare an array reference with an array specification. */
4134 compare_spec_to_ref (gfc_array_ref
*ar
)
4141 /* TODO: Full array sections are only allowed as actual parameters. */
4142 if (as
->type
== AS_ASSUMED_SIZE
4143 && (/*ar->type == AR_FULL
4144 ||*/ (ar
->type
== AR_SECTION
4145 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4147 gfc_error ("Rightmost upper bound of assumed size array section "
4148 "not specified at %L", &ar
->where
);
4152 if (ar
->type
== AR_FULL
)
4155 if (as
->rank
!= ar
->dimen
)
4157 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4158 &ar
->where
, ar
->dimen
, as
->rank
);
4162 /* ar->codimen == 0 is a local array. */
4163 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4165 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4166 &ar
->where
, ar
->codimen
, as
->corank
);
4170 for (i
= 0; i
< as
->rank
; i
++)
4171 if (!check_dimension (i
, ar
, as
))
4174 /* Local access has no coarray spec. */
4175 if (ar
->codimen
!= 0)
4176 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4178 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4179 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4181 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4182 i
+ 1 - as
->rank
, &ar
->where
);
4185 if (!check_dimension (i
, ar
, as
))
4193 /* Resolve one part of an array index. */
4196 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4197 int force_index_integer_kind
)
4204 if (!gfc_resolve_expr (index
))
4207 if (check_scalar
&& index
->rank
!= 0)
4209 gfc_error ("Array index at %L must be scalar", &index
->where
);
4213 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4215 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4216 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4220 if (index
->ts
.type
== BT_REAL
)
4221 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4225 if ((index
->ts
.kind
!= gfc_index_integer_kind
4226 && force_index_integer_kind
)
4227 || index
->ts
.type
!= BT_INTEGER
)
4230 ts
.type
= BT_INTEGER
;
4231 ts
.kind
= gfc_index_integer_kind
;
4233 gfc_convert_type_warn (index
, &ts
, 2, 0);
4239 /* Resolve one part of an array index. */
4242 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4244 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4247 /* Resolve a dim argument to an intrinsic function. */
4250 gfc_resolve_dim_arg (gfc_expr
*dim
)
4255 if (!gfc_resolve_expr (dim
))
4260 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4265 if (dim
->ts
.type
!= BT_INTEGER
)
4267 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4271 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4276 ts
.type
= BT_INTEGER
;
4277 ts
.kind
= gfc_index_integer_kind
;
4279 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4285 /* Given an expression that contains array references, update those array
4286 references to point to the right array specifications. While this is
4287 filled in during matching, this information is difficult to save and load
4288 in a module, so we take care of it here.
4290 The idea here is that the original array reference comes from the
4291 base symbol. We traverse the list of reference structures, setting
4292 the stored reference to references. Component references can
4293 provide an additional array specification. */
4296 find_array_spec (gfc_expr
*e
)
4302 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4303 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4305 as
= e
->symtree
->n
.sym
->as
;
4307 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4312 gfc_internal_error ("find_array_spec(): Missing spec");
4319 c
= ref
->u
.c
.component
;
4320 if (c
->attr
.dimension
)
4323 gfc_internal_error ("find_array_spec(): unused as(1)");
4334 gfc_internal_error ("find_array_spec(): unused as(2)");
4338 /* Resolve an array reference. */
4341 resolve_array_ref (gfc_array_ref
*ar
)
4343 int i
, check_scalar
;
4346 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4348 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4350 /* Do not force gfc_index_integer_kind for the start. We can
4351 do fine with any integer kind. This avoids temporary arrays
4352 created for indexing with a vector. */
4353 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4355 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4357 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4362 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4366 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4370 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4371 if (e
->expr_type
== EXPR_VARIABLE
4372 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4373 ar
->start
[i
] = gfc_get_parentheses (e
);
4377 gfc_error ("Array index at %L is an array of rank %d",
4378 &ar
->c_where
[i
], e
->rank
);
4382 /* Fill in the upper bound, which may be lower than the
4383 specified one for something like a(2:10:5), which is
4384 identical to a(2:7:5). Only relevant for strides not equal
4385 to one. Don't try a division by zero. */
4386 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4387 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4388 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4389 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4393 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4395 if (ar
->end
[i
] == NULL
)
4398 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4400 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4402 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4403 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4405 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4416 if (ar
->type
== AR_FULL
)
4418 if (ar
->as
->rank
== 0)
4419 ar
->type
= AR_ELEMENT
;
4421 /* Make sure array is the same as array(:,:), this way
4422 we don't need to special case all the time. */
4423 ar
->dimen
= ar
->as
->rank
;
4424 for (i
= 0; i
< ar
->dimen
; i
++)
4426 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4428 gcc_assert (ar
->start
[i
] == NULL
);
4429 gcc_assert (ar
->end
[i
] == NULL
);
4430 gcc_assert (ar
->stride
[i
] == NULL
);
4434 /* If the reference type is unknown, figure out what kind it is. */
4436 if (ar
->type
== AR_UNKNOWN
)
4438 ar
->type
= AR_ELEMENT
;
4439 for (i
= 0; i
< ar
->dimen
; i
++)
4440 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4441 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4443 ar
->type
= AR_SECTION
;
4448 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4451 if (ar
->as
->corank
&& ar
->codimen
== 0)
4454 ar
->codimen
= ar
->as
->corank
;
4455 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4456 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4464 resolve_substring (gfc_ref
*ref
)
4466 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4468 if (ref
->u
.ss
.start
!= NULL
)
4470 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4473 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4475 gfc_error ("Substring start index at %L must be of type INTEGER",
4476 &ref
->u
.ss
.start
->where
);
4480 if (ref
->u
.ss
.start
->rank
!= 0)
4482 gfc_error ("Substring start index at %L must be scalar",
4483 &ref
->u
.ss
.start
->where
);
4487 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4488 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4489 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4491 gfc_error ("Substring start index at %L is less than one",
4492 &ref
->u
.ss
.start
->where
);
4497 if (ref
->u
.ss
.end
!= NULL
)
4499 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4502 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4504 gfc_error ("Substring end index at %L must be of type INTEGER",
4505 &ref
->u
.ss
.end
->where
);
4509 if (ref
->u
.ss
.end
->rank
!= 0)
4511 gfc_error ("Substring end index at %L must be scalar",
4512 &ref
->u
.ss
.end
->where
);
4516 if (ref
->u
.ss
.length
!= NULL
4517 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4518 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4519 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4521 gfc_error ("Substring end index at %L exceeds the string length",
4522 &ref
->u
.ss
.start
->where
);
4526 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4527 gfc_integer_kinds
[k
].huge
) == CMP_GT
4528 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4529 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4531 gfc_error ("Substring end index at %L is too large",
4532 &ref
->u
.ss
.end
->where
);
4541 /* This function supplies missing substring charlens. */
4544 gfc_resolve_substring_charlen (gfc_expr
*e
)
4547 gfc_expr
*start
, *end
;
4549 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4550 if (char_ref
->type
== REF_SUBSTRING
)
4556 gcc_assert (char_ref
->next
== NULL
);
4560 if (e
->ts
.u
.cl
->length
)
4561 gfc_free_expr (e
->ts
.u
.cl
->length
);
4562 else if (e
->expr_type
== EXPR_VARIABLE
4563 && e
->symtree
->n
.sym
->attr
.dummy
)
4567 e
->ts
.type
= BT_CHARACTER
;
4568 e
->ts
.kind
= gfc_default_character_kind
;
4571 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4573 if (char_ref
->u
.ss
.start
)
4574 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4576 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4578 if (char_ref
->u
.ss
.end
)
4579 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4580 else if (e
->expr_type
== EXPR_VARIABLE
)
4581 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4587 gfc_free_expr (start
);
4588 gfc_free_expr (end
);
4592 /* Length = (end - start +1). */
4593 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4594 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4595 gfc_get_int_expr (gfc_default_integer_kind
,
4598 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4599 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4601 /* Make sure that the length is simplified. */
4602 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4603 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4607 /* Resolve subtype references. */
4610 resolve_ref (gfc_expr
*expr
)
4612 int current_part_dimension
, n_components
, seen_part_dimension
;
4615 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4616 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4618 find_array_spec (expr
);
4622 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4626 if (!resolve_array_ref (&ref
->u
.ar
))
4634 if (!resolve_substring (ref
))
4639 /* Check constraints on part references. */
4641 current_part_dimension
= 0;
4642 seen_part_dimension
= 0;
4645 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4650 switch (ref
->u
.ar
.type
)
4653 /* Coarray scalar. */
4654 if (ref
->u
.ar
.as
->rank
== 0)
4656 current_part_dimension
= 0;
4661 current_part_dimension
= 1;
4665 current_part_dimension
= 0;
4669 gfc_internal_error ("resolve_ref(): Bad array reference");
4675 if (current_part_dimension
|| seen_part_dimension
)
4678 if (ref
->u
.c
.component
->attr
.pointer
4679 || ref
->u
.c
.component
->attr
.proc_pointer
4680 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4681 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4683 gfc_error ("Component to the right of a part reference "
4684 "with nonzero rank must not have the POINTER "
4685 "attribute at %L", &expr
->where
);
4688 else if (ref
->u
.c
.component
->attr
.allocatable
4689 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4690 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4693 gfc_error ("Component to the right of a part reference "
4694 "with nonzero rank must not have the ALLOCATABLE "
4695 "attribute at %L", &expr
->where
);
4707 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4708 || ref
->next
== NULL
)
4709 && current_part_dimension
4710 && seen_part_dimension
)
4712 gfc_error ("Two or more part references with nonzero rank must "
4713 "not be specified at %L", &expr
->where
);
4717 if (ref
->type
== REF_COMPONENT
)
4719 if (current_part_dimension
)
4720 seen_part_dimension
= 1;
4722 /* reset to make sure */
4723 current_part_dimension
= 0;
4731 /* Given an expression, determine its shape. This is easier than it sounds.
4732 Leaves the shape array NULL if it is not possible to determine the shape. */
4735 expression_shape (gfc_expr
*e
)
4737 mpz_t array
[GFC_MAX_DIMENSIONS
];
4740 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4743 for (i
= 0; i
< e
->rank
; i
++)
4744 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4747 e
->shape
= gfc_get_shape (e
->rank
);
4749 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4754 for (i
--; i
>= 0; i
--)
4755 mpz_clear (array
[i
]);
4759 /* Given a variable expression node, compute the rank of the expression by
4760 examining the base symbol and any reference structures it may have. */
4763 expression_rank (gfc_expr
*e
)
4768 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4769 could lead to serious confusion... */
4770 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4774 if (e
->expr_type
== EXPR_ARRAY
)
4776 /* Constructors can have a rank different from one via RESHAPE(). */
4778 if (e
->symtree
== NULL
)
4784 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4785 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4791 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4793 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4794 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4795 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4797 if (ref
->type
!= REF_ARRAY
)
4800 if (ref
->u
.ar
.type
== AR_FULL
)
4802 rank
= ref
->u
.ar
.as
->rank
;
4806 if (ref
->u
.ar
.type
== AR_SECTION
)
4808 /* Figure out the rank of the section. */
4810 gfc_internal_error ("expression_rank(): Two array specs");
4812 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4813 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4814 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4824 expression_shape (e
);
4829 add_caf_get_intrinsic (gfc_expr
*e
)
4831 gfc_expr
*wrapper
, *tmp_expr
;
4835 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4836 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4841 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4842 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4845 tmp_expr
= XCNEW (gfc_expr
);
4847 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4848 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4849 wrapper
->ts
= e
->ts
;
4850 wrapper
->rank
= e
->rank
;
4852 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4859 remove_caf_get_intrinsic (gfc_expr
*e
)
4861 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4862 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4863 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4864 e
->value
.function
.actual
->expr
= NULL
;
4865 gfc_free_actual_arglist (e
->value
.function
.actual
);
4866 gfc_free_shape (&e
->shape
, e
->rank
);
4872 /* Resolve a variable expression. */
4875 resolve_variable (gfc_expr
*e
)
4882 if (e
->symtree
== NULL
)
4884 sym
= e
->symtree
->n
.sym
;
4886 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4887 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4888 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4890 if (!actual_arg
|| inquiry_argument
)
4892 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4893 "be used as actual argument", sym
->name
, &e
->where
);
4897 /* TS 29113, 407b. */
4898 else if (e
->ts
.type
== BT_ASSUMED
)
4902 gfc_error ("Assumed-type variable %s at %L may only be used "
4903 "as actual argument", sym
->name
, &e
->where
);
4906 else if (inquiry_argument
&& !first_actual_arg
)
4908 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4909 for all inquiry functions in resolve_function; the reason is
4910 that the function-name resolution happens too late in that
4912 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4913 "an inquiry function shall be the first argument",
4914 sym
->name
, &e
->where
);
4918 /* TS 29113, C535b. */
4919 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4920 && CLASS_DATA (sym
)->as
4921 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4922 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4923 && sym
->as
->type
== AS_ASSUMED_RANK
))
4927 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4928 "actual argument", sym
->name
, &e
->where
);
4931 else if (inquiry_argument
&& !first_actual_arg
)
4933 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4934 for all inquiry functions in resolve_function; the reason is
4935 that the function-name resolution happens too late in that
4937 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4938 "to an inquiry function shall be the first argument",
4939 sym
->name
, &e
->where
);
4944 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4945 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4946 && e
->ref
->next
== NULL
))
4948 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4949 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4952 /* TS 29113, 407b. */
4953 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4954 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4955 && e
->ref
->next
== NULL
))
4957 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4958 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4962 /* TS 29113, C535b. */
4963 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4964 && CLASS_DATA (sym
)->as
4965 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4966 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4967 && sym
->as
->type
== AS_ASSUMED_RANK
))
4969 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4970 && e
->ref
->next
== NULL
))
4972 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4973 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4978 /* If this is an associate-name, it may be parsed with an array reference
4979 in error even though the target is scalar. Fail directly in this case.
4980 TODO Understand why class scalar expressions must be excluded. */
4981 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4983 if (sym
->ts
.type
== BT_CLASS
)
4984 gfc_fix_class_refs (e
);
4985 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4989 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4990 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4992 /* On the other hand, the parser may not have known this is an array;
4993 in this case, we have to add a FULL reference. */
4994 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4996 e
->ref
= gfc_get_ref ();
4997 e
->ref
->type
= REF_ARRAY
;
4998 e
->ref
->u
.ar
.type
= AR_FULL
;
4999 e
->ref
->u
.ar
.dimen
= 0;
5002 if (e
->ref
&& !resolve_ref (e
))
5005 if (sym
->attr
.flavor
== FL_PROCEDURE
5006 && (!sym
->attr
.function
5007 || (sym
->attr
.function
&& sym
->result
5008 && sym
->result
->attr
.proc_pointer
5009 && !sym
->result
->attr
.function
)))
5011 e
->ts
.type
= BT_PROCEDURE
;
5012 goto resolve_procedure
;
5015 if (sym
->ts
.type
!= BT_UNKNOWN
)
5016 gfc_variable_attr (e
, &e
->ts
);
5019 /* Must be a simple variable reference. */
5020 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5025 if (check_assumed_size_reference (sym
, e
))
5028 /* Deal with forward references to entries during gfc_resolve_code, to
5029 satisfy, at least partially, 12.5.2.5. */
5030 if (gfc_current_ns
->entries
5031 && current_entry_id
== sym
->entry_id
5034 && cs_base
->current
->op
!= EXEC_ENTRY
)
5036 gfc_entry_list
*entry
;
5037 gfc_formal_arglist
*formal
;
5039 bool seen
, saved_specification_expr
;
5041 /* If the symbol is a dummy... */
5042 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5044 entry
= gfc_current_ns
->entries
;
5047 /* ...test if the symbol is a parameter of previous entries. */
5048 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5049 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5051 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5058 /* If it has not been seen as a dummy, this is an error. */
5061 if (specification_expr
)
5062 gfc_error ("Variable %qs, used in a specification expression"
5063 ", is referenced at %L before the ENTRY statement "
5064 "in which it is a parameter",
5065 sym
->name
, &cs_base
->current
->loc
);
5067 gfc_error ("Variable %qs is used at %L before the ENTRY "
5068 "statement in which it is a parameter",
5069 sym
->name
, &cs_base
->current
->loc
);
5074 /* Now do the same check on the specification expressions. */
5075 saved_specification_expr
= specification_expr
;
5076 specification_expr
= true;
5077 if (sym
->ts
.type
== BT_CHARACTER
5078 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5082 for (n
= 0; n
< sym
->as
->rank
; n
++)
5084 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5086 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5089 specification_expr
= saved_specification_expr
;
5092 /* Update the symbol's entry level. */
5093 sym
->entry_id
= current_entry_id
+ 1;
5096 /* If a symbol has been host_associated mark it. This is used latter,
5097 to identify if aliasing is possible via host association. */
5098 if (sym
->attr
.flavor
== FL_VARIABLE
5099 && gfc_current_ns
->parent
5100 && (gfc_current_ns
->parent
== sym
->ns
5101 || (gfc_current_ns
->parent
->parent
5102 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5103 sym
->attr
.host_assoc
= 1;
5105 if (gfc_current_ns
->proc_name
5106 && sym
->attr
.dimension
5107 && (sym
->ns
!= gfc_current_ns
5108 || sym
->attr
.use_assoc
5109 || sym
->attr
.in_common
))
5110 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5113 if (t
&& !resolve_procedure_expression (e
))
5116 /* F2008, C617 and C1229. */
5117 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5118 && gfc_is_coindexed (e
))
5120 gfc_ref
*ref
, *ref2
= NULL
;
5122 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5124 if (ref
->type
== REF_COMPONENT
)
5126 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5130 for ( ; ref
; ref
= ref
->next
)
5131 if (ref
->type
== REF_COMPONENT
)
5134 /* Expression itself is not coindexed object. */
5135 if (ref
&& e
->ts
.type
== BT_CLASS
)
5137 gfc_error ("Polymorphic subobject of coindexed object at %L",
5142 /* Expression itself is coindexed object. */
5146 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5147 for ( ; c
; c
= c
->next
)
5148 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5150 gfc_error ("Coindexed object with polymorphic allocatable "
5151 "subcomponent at %L", &e
->where
);
5159 expression_rank (e
);
5161 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5162 add_caf_get_intrinsic (e
);
5168 /* Checks to see that the correct symbol has been host associated.
5169 The only situation where this arises is that in which a twice
5170 contained function is parsed after the host association is made.
5171 Therefore, on detecting this, change the symbol in the expression
5172 and convert the array reference into an actual arglist if the old
5173 symbol is a variable. */
5175 check_host_association (gfc_expr
*e
)
5177 gfc_symbol
*sym
, *old_sym
;
5181 gfc_actual_arglist
*arg
, *tail
= NULL
;
5182 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5184 /* If the expression is the result of substitution in
5185 interface.c(gfc_extend_expr) because there is no way in
5186 which the host association can be wrong. */
5187 if (e
->symtree
== NULL
5188 || e
->symtree
->n
.sym
== NULL
5189 || e
->user_operator
)
5192 old_sym
= e
->symtree
->n
.sym
;
5194 if (gfc_current_ns
->parent
5195 && old_sym
->ns
!= gfc_current_ns
)
5197 /* Use the 'USE' name so that renamed module symbols are
5198 correctly handled. */
5199 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5201 if (sym
&& old_sym
!= sym
5202 && sym
->ts
.type
== old_sym
->ts
.type
5203 && sym
->attr
.flavor
== FL_PROCEDURE
5204 && sym
->attr
.contained
)
5206 /* Clear the shape, since it might not be valid. */
5207 gfc_free_shape (&e
->shape
, e
->rank
);
5209 /* Give the expression the right symtree! */
5210 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5211 gcc_assert (st
!= NULL
);
5213 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5214 || e
->expr_type
== EXPR_FUNCTION
)
5216 /* Original was function so point to the new symbol, since
5217 the actual argument list is already attached to the
5219 e
->value
.function
.esym
= NULL
;
5224 /* Original was variable so convert array references into
5225 an actual arglist. This does not need any checking now
5226 since resolve_function will take care of it. */
5227 e
->value
.function
.actual
= NULL
;
5228 e
->expr_type
= EXPR_FUNCTION
;
5231 /* Ambiguity will not arise if the array reference is not
5232 the last reference. */
5233 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5234 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5237 gcc_assert (ref
->type
== REF_ARRAY
);
5239 /* Grab the start expressions from the array ref and
5240 copy them into actual arguments. */
5241 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5243 arg
= gfc_get_actual_arglist ();
5244 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5245 if (e
->value
.function
.actual
== NULL
)
5246 tail
= e
->value
.function
.actual
= arg
;
5254 /* Dump the reference list and set the rank. */
5255 gfc_free_ref_list (e
->ref
);
5257 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5260 gfc_resolve_expr (e
);
5264 /* This might have changed! */
5265 return e
->expr_type
== EXPR_FUNCTION
;
5270 gfc_resolve_character_operator (gfc_expr
*e
)
5272 gfc_expr
*op1
= e
->value
.op
.op1
;
5273 gfc_expr
*op2
= e
->value
.op
.op2
;
5274 gfc_expr
*e1
= NULL
;
5275 gfc_expr
*e2
= NULL
;
5277 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5279 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5280 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5281 else if (op1
->expr_type
== EXPR_CONSTANT
)
5282 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5283 op1
->value
.character
.length
);
5285 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5286 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5287 else if (op2
->expr_type
== EXPR_CONSTANT
)
5288 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5289 op2
->value
.character
.length
);
5291 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5301 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5302 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5303 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5304 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5305 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5311 /* Ensure that an character expression has a charlen and, if possible, a
5312 length expression. */
5315 fixup_charlen (gfc_expr
*e
)
5317 /* The cases fall through so that changes in expression type and the need
5318 for multiple fixes are picked up. In all circumstances, a charlen should
5319 be available for the middle end to hang a backend_decl on. */
5320 switch (e
->expr_type
)
5323 gfc_resolve_character_operator (e
);
5326 if (e
->expr_type
== EXPR_ARRAY
)
5327 gfc_resolve_character_array_constructor (e
);
5329 case EXPR_SUBSTRING
:
5330 if (!e
->ts
.u
.cl
&& e
->ref
)
5331 gfc_resolve_substring_charlen (e
);
5335 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5342 /* Update an actual argument to include the passed-object for type-bound
5343 procedures at the right position. */
5345 static gfc_actual_arglist
*
5346 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5349 gcc_assert (argpos
> 0);
5353 gfc_actual_arglist
* result
;
5355 result
= gfc_get_actual_arglist ();
5359 result
->name
= name
;
5365 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5367 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5372 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5375 extract_compcall_passed_object (gfc_expr
* e
)
5379 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5381 if (e
->value
.compcall
.base_object
)
5382 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5385 po
= gfc_get_expr ();
5386 po
->expr_type
= EXPR_VARIABLE
;
5387 po
->symtree
= e
->symtree
;
5388 po
->ref
= gfc_copy_ref (e
->ref
);
5389 po
->where
= e
->where
;
5392 if (!gfc_resolve_expr (po
))
5399 /* Update the arglist of an EXPR_COMPCALL expression to include the
5403 update_compcall_arglist (gfc_expr
* e
)
5406 gfc_typebound_proc
* tbp
;
5408 tbp
= e
->value
.compcall
.tbp
;
5413 po
= extract_compcall_passed_object (e
);
5417 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5423 gcc_assert (tbp
->pass_arg_num
> 0);
5424 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5432 /* Extract the passed object from a PPC call (a copy of it). */
5435 extract_ppc_passed_object (gfc_expr
*e
)
5440 po
= gfc_get_expr ();
5441 po
->expr_type
= EXPR_VARIABLE
;
5442 po
->symtree
= e
->symtree
;
5443 po
->ref
= gfc_copy_ref (e
->ref
);
5444 po
->where
= e
->where
;
5446 /* Remove PPC reference. */
5448 while ((*ref
)->next
)
5449 ref
= &(*ref
)->next
;
5450 gfc_free_ref_list (*ref
);
5453 if (!gfc_resolve_expr (po
))
5460 /* Update the actual arglist of a procedure pointer component to include the
5464 update_ppc_arglist (gfc_expr
* e
)
5468 gfc_typebound_proc
* tb
;
5470 ppc
= gfc_get_proc_ptr_comp (e
);
5478 else if (tb
->nopass
)
5481 po
= extract_ppc_passed_object (e
);
5488 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5493 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5495 gfc_error ("Base object for procedure-pointer component call at %L is of"
5496 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5500 gcc_assert (tb
->pass_arg_num
> 0);
5501 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5509 /* Check that the object a TBP is called on is valid, i.e. it must not be
5510 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5513 check_typebound_baseobject (gfc_expr
* e
)
5516 bool return_value
= false;
5518 base
= extract_compcall_passed_object (e
);
5522 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5524 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5528 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5530 gfc_error ("Base object for type-bound procedure call at %L is of"
5531 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5535 /* F08:C1230. If the procedure called is NOPASS,
5536 the base object must be scalar. */
5537 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5539 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5540 " be scalar", &e
->where
);
5544 return_value
= true;
5547 gfc_free_expr (base
);
5548 return return_value
;
5552 /* Resolve a call to a type-bound procedure, either function or subroutine,
5553 statically from the data in an EXPR_COMPCALL expression. The adapted
5554 arglist and the target-procedure symtree are returned. */
5557 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5558 gfc_actual_arglist
** actual
)
5560 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5561 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5563 /* Update the actual arglist for PASS. */
5564 if (!update_compcall_arglist (e
))
5567 *actual
= e
->value
.compcall
.actual
;
5568 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5570 gfc_free_ref_list (e
->ref
);
5572 e
->value
.compcall
.actual
= NULL
;
5574 /* If we find a deferred typebound procedure, check for derived types
5575 that an overriding typebound procedure has not been missed. */
5576 if (e
->value
.compcall
.name
5577 && !e
->value
.compcall
.tbp
->non_overridable
5578 && e
->value
.compcall
.base_object
5579 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5582 gfc_symbol
*derived
;
5584 /* Use the derived type of the base_object. */
5585 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5588 /* If necessary, go through the inheritance chain. */
5589 while (!st
&& derived
)
5591 /* Look for the typebound procedure 'name'. */
5592 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5593 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5594 e
->value
.compcall
.name
);
5596 derived
= gfc_get_derived_super_type (derived
);
5599 /* Now find the specific name in the derived type namespace. */
5600 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5601 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5602 derived
->ns
, 1, &st
);
5610 /* Get the ultimate declared type from an expression. In addition,
5611 return the last class/derived type reference and the copy of the
5612 reference list. If check_types is set true, derived types are
5613 identified as well as class references. */
5615 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5616 gfc_expr
*e
, bool check_types
)
5618 gfc_symbol
*declared
;
5625 *new_ref
= gfc_copy_ref (e
->ref
);
5627 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5629 if (ref
->type
!= REF_COMPONENT
)
5632 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5633 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5634 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5636 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5642 if (declared
== NULL
)
5643 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5649 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5650 which of the specific bindings (if any) matches the arglist and transform
5651 the expression into a call of that binding. */
5654 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5656 gfc_typebound_proc
* genproc
;
5657 const char* genname
;
5659 gfc_symbol
*derived
;
5661 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5662 genname
= e
->value
.compcall
.name
;
5663 genproc
= e
->value
.compcall
.tbp
;
5665 if (!genproc
->is_generic
)
5668 /* Try the bindings on this type and in the inheritance hierarchy. */
5669 for (; genproc
; genproc
= genproc
->overridden
)
5673 gcc_assert (genproc
->is_generic
);
5674 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5677 gfc_actual_arglist
* args
;
5680 gcc_assert (g
->specific
);
5682 if (g
->specific
->error
)
5685 target
= g
->specific
->u
.specific
->n
.sym
;
5687 /* Get the right arglist by handling PASS/NOPASS. */
5688 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5689 if (!g
->specific
->nopass
)
5692 po
= extract_compcall_passed_object (e
);
5695 gfc_free_actual_arglist (args
);
5699 gcc_assert (g
->specific
->pass_arg_num
> 0);
5700 gcc_assert (!g
->specific
->error
);
5701 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5702 g
->specific
->pass_arg
);
5704 resolve_actual_arglist (args
, target
->attr
.proc
,
5705 is_external_proc (target
)
5706 && gfc_sym_get_dummy_args (target
) == NULL
);
5708 /* Check if this arglist matches the formal. */
5709 matches
= gfc_arglist_matches_symbol (&args
, target
);
5711 /* Clean up and break out of the loop if we've found it. */
5712 gfc_free_actual_arglist (args
);
5715 e
->value
.compcall
.tbp
= g
->specific
;
5716 genname
= g
->specific_st
->name
;
5717 /* Pass along the name for CLASS methods, where the vtab
5718 procedure pointer component has to be referenced. */
5726 /* Nothing matching found! */
5727 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5728 " %qs at %L", genname
, &e
->where
);
5732 /* Make sure that we have the right specific instance for the name. */
5733 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5735 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5737 e
->value
.compcall
.tbp
= st
->n
.tb
;
5743 /* Resolve a call to a type-bound subroutine. */
5746 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5748 gfc_actual_arglist
* newactual
;
5749 gfc_symtree
* target
;
5751 /* Check that's really a SUBROUTINE. */
5752 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5754 gfc_error ("%qs at %L should be a SUBROUTINE",
5755 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5759 if (!check_typebound_baseobject (c
->expr1
))
5762 /* Pass along the name for CLASS methods, where the vtab
5763 procedure pointer component has to be referenced. */
5765 *name
= c
->expr1
->value
.compcall
.name
;
5767 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5770 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5772 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5774 /* Transform into an ordinary EXEC_CALL for now. */
5776 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5779 c
->ext
.actual
= newactual
;
5780 c
->symtree
= target
;
5781 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5783 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5785 gfc_free_expr (c
->expr1
);
5786 c
->expr1
= gfc_get_expr ();
5787 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5788 c
->expr1
->symtree
= target
;
5789 c
->expr1
->where
= c
->loc
;
5791 return resolve_call (c
);
5795 /* Resolve a component-call expression. */
5797 resolve_compcall (gfc_expr
* e
, const char **name
)
5799 gfc_actual_arglist
* newactual
;
5800 gfc_symtree
* target
;
5802 /* Check that's really a FUNCTION. */
5803 if (!e
->value
.compcall
.tbp
->function
)
5805 gfc_error ("%qs at %L should be a FUNCTION",
5806 e
->value
.compcall
.name
, &e
->where
);
5810 /* These must not be assign-calls! */
5811 gcc_assert (!e
->value
.compcall
.assign
);
5813 if (!check_typebound_baseobject (e
))
5816 /* Pass along the name for CLASS methods, where the vtab
5817 procedure pointer component has to be referenced. */
5819 *name
= e
->value
.compcall
.name
;
5821 if (!resolve_typebound_generic_call (e
, name
))
5823 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5825 /* Take the rank from the function's symbol. */
5826 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5827 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5829 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5830 arglist to the TBP's binding target. */
5832 if (!resolve_typebound_static (e
, &target
, &newactual
))
5835 e
->value
.function
.actual
= newactual
;
5836 e
->value
.function
.name
= NULL
;
5837 e
->value
.function
.esym
= target
->n
.sym
;
5838 e
->value
.function
.isym
= NULL
;
5839 e
->symtree
= target
;
5840 e
->ts
= target
->n
.sym
->ts
;
5841 e
->expr_type
= EXPR_FUNCTION
;
5843 /* Resolution is not necessary if this is a class subroutine; this
5844 function only has to identify the specific proc. Resolution of
5845 the call will be done next in resolve_typebound_call. */
5846 return gfc_resolve_expr (e
);
5850 static bool resolve_fl_derived (gfc_symbol
*sym
);
5853 /* Resolve a typebound function, or 'method'. First separate all
5854 the non-CLASS references by calling resolve_compcall directly. */
5857 resolve_typebound_function (gfc_expr
* e
)
5859 gfc_symbol
*declared
;
5871 /* Deal with typebound operators for CLASS objects. */
5872 expr
= e
->value
.compcall
.base_object
;
5873 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5874 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5876 /* If the base_object is not a variable, the corresponding actual
5877 argument expression must be stored in e->base_expression so
5878 that the corresponding tree temporary can be used as the base
5879 object in gfc_conv_procedure_call. */
5880 if (expr
->expr_type
!= EXPR_VARIABLE
)
5882 gfc_actual_arglist
*args
;
5884 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5886 if (expr
== args
->expr
)
5891 /* Since the typebound operators are generic, we have to ensure
5892 that any delays in resolution are corrected and that the vtab
5895 declared
= ts
.u
.derived
;
5896 c
= gfc_find_component (declared
, "_vptr", true, true);
5897 if (c
->ts
.u
.derived
== NULL
)
5898 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5900 if (!resolve_compcall (e
, &name
))
5903 /* Use the generic name if it is there. */
5904 name
= name
? name
: e
->value
.function
.esym
->name
;
5905 e
->symtree
= expr
->symtree
;
5906 e
->ref
= gfc_copy_ref (expr
->ref
);
5907 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5909 /* Trim away the extraneous references that emerge from nested
5910 use of interface.c (extend_expr). */
5911 if (class_ref
&& class_ref
->next
)
5913 gfc_free_ref_list (class_ref
->next
);
5914 class_ref
->next
= NULL
;
5916 else if (e
->ref
&& !class_ref
)
5918 gfc_free_ref_list (e
->ref
);
5922 gfc_add_vptr_component (e
);
5923 gfc_add_component_ref (e
, name
);
5924 e
->value
.function
.esym
= NULL
;
5925 if (expr
->expr_type
!= EXPR_VARIABLE
)
5926 e
->base_expr
= expr
;
5931 return resolve_compcall (e
, NULL
);
5933 if (!resolve_ref (e
))
5936 /* Get the CLASS declared type. */
5937 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5939 if (!resolve_fl_derived (declared
))
5942 /* Weed out cases of the ultimate component being a derived type. */
5943 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5944 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5946 gfc_free_ref_list (new_ref
);
5947 return resolve_compcall (e
, NULL
);
5950 c
= gfc_find_component (declared
, "_data", true, true);
5951 declared
= c
->ts
.u
.derived
;
5953 /* Treat the call as if it is a typebound procedure, in order to roll
5954 out the correct name for the specific function. */
5955 if (!resolve_compcall (e
, &name
))
5957 gfc_free_ref_list (new_ref
);
5964 /* Convert the expression to a procedure pointer component call. */
5965 e
->value
.function
.esym
= NULL
;
5971 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5972 gfc_add_vptr_component (e
);
5973 gfc_add_component_ref (e
, name
);
5975 /* Recover the typespec for the expression. This is really only
5976 necessary for generic procedures, where the additional call
5977 to gfc_add_component_ref seems to throw the collection of the
5978 correct typespec. */
5982 gfc_free_ref_list (new_ref
);
5987 /* Resolve a typebound subroutine, or 'method'. First separate all
5988 the non-CLASS references by calling resolve_typebound_call
5992 resolve_typebound_subroutine (gfc_code
*code
)
5994 gfc_symbol
*declared
;
6004 st
= code
->expr1
->symtree
;
6006 /* Deal with typebound operators for CLASS objects. */
6007 expr
= code
->expr1
->value
.compcall
.base_object
;
6008 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6009 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6011 /* If the base_object is not a variable, the corresponding actual
6012 argument expression must be stored in e->base_expression so
6013 that the corresponding tree temporary can be used as the base
6014 object in gfc_conv_procedure_call. */
6015 if (expr
->expr_type
!= EXPR_VARIABLE
)
6017 gfc_actual_arglist
*args
;
6019 args
= code
->expr1
->value
.function
.actual
;
6020 for (; args
; args
= args
->next
)
6021 if (expr
== args
->expr
)
6025 /* Since the typebound operators are generic, we have to ensure
6026 that any delays in resolution are corrected and that the vtab
6028 declared
= expr
->ts
.u
.derived
;
6029 c
= gfc_find_component (declared
, "_vptr", true, true);
6030 if (c
->ts
.u
.derived
== NULL
)
6031 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6033 if (!resolve_typebound_call (code
, &name
, NULL
))
6036 /* Use the generic name if it is there. */
6037 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6038 code
->expr1
->symtree
= expr
->symtree
;
6039 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6041 /* Trim away the extraneous references that emerge from nested
6042 use of interface.c (extend_expr). */
6043 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6044 if (class_ref
&& class_ref
->next
)
6046 gfc_free_ref_list (class_ref
->next
);
6047 class_ref
->next
= NULL
;
6049 else if (code
->expr1
->ref
&& !class_ref
)
6051 gfc_free_ref_list (code
->expr1
->ref
);
6052 code
->expr1
->ref
= NULL
;
6055 /* Now use the procedure in the vtable. */
6056 gfc_add_vptr_component (code
->expr1
);
6057 gfc_add_component_ref (code
->expr1
, name
);
6058 code
->expr1
->value
.function
.esym
= NULL
;
6059 if (expr
->expr_type
!= EXPR_VARIABLE
)
6060 code
->expr1
->base_expr
= expr
;
6065 return resolve_typebound_call (code
, NULL
, NULL
);
6067 if (!resolve_ref (code
->expr1
))
6070 /* Get the CLASS declared type. */
6071 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6073 /* Weed out cases of the ultimate component being a derived type. */
6074 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6075 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6077 gfc_free_ref_list (new_ref
);
6078 return resolve_typebound_call (code
, NULL
, NULL
);
6081 if (!resolve_typebound_call (code
, &name
, &overridable
))
6083 gfc_free_ref_list (new_ref
);
6086 ts
= code
->expr1
->ts
;
6090 /* Convert the expression to a procedure pointer component call. */
6091 code
->expr1
->value
.function
.esym
= NULL
;
6092 code
->expr1
->symtree
= st
;
6095 code
->expr1
->ref
= new_ref
;
6097 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6098 gfc_add_vptr_component (code
->expr1
);
6099 gfc_add_component_ref (code
->expr1
, name
);
6101 /* Recover the typespec for the expression. This is really only
6102 necessary for generic procedures, where the additional call
6103 to gfc_add_component_ref seems to throw the collection of the
6104 correct typespec. */
6105 code
->expr1
->ts
= ts
;
6108 gfc_free_ref_list (new_ref
);
6114 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6117 resolve_ppc_call (gfc_code
* c
)
6119 gfc_component
*comp
;
6121 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6122 gcc_assert (comp
!= NULL
);
6124 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6125 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6127 if (!comp
->attr
.subroutine
)
6128 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6130 if (!resolve_ref (c
->expr1
))
6133 if (!update_ppc_arglist (c
->expr1
))
6136 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6138 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6139 !(comp
->ts
.interface
6140 && comp
->ts
.interface
->formal
)))
6143 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6146 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6152 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6155 resolve_expr_ppc (gfc_expr
* e
)
6157 gfc_component
*comp
;
6159 comp
= gfc_get_proc_ptr_comp (e
);
6160 gcc_assert (comp
!= NULL
);
6162 /* Convert to EXPR_FUNCTION. */
6163 e
->expr_type
= EXPR_FUNCTION
;
6164 e
->value
.function
.isym
= NULL
;
6165 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6167 if (comp
->as
!= NULL
)
6168 e
->rank
= comp
->as
->rank
;
6170 if (!comp
->attr
.function
)
6171 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6173 if (!resolve_ref (e
))
6176 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6177 !(comp
->ts
.interface
6178 && comp
->ts
.interface
->formal
)))
6181 if (!update_ppc_arglist (e
))
6184 if (!check_pure_function(e
))
6187 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6194 gfc_is_expandable_expr (gfc_expr
*e
)
6196 gfc_constructor
*con
;
6198 if (e
->expr_type
== EXPR_ARRAY
)
6200 /* Traverse the constructor looking for variables that are flavor
6201 parameter. Parameters must be expanded since they are fully used at
6203 con
= gfc_constructor_first (e
->value
.constructor
);
6204 for (; con
; con
= gfc_constructor_next (con
))
6206 if (con
->expr
->expr_type
== EXPR_VARIABLE
6207 && con
->expr
->symtree
6208 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6209 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6211 if (con
->expr
->expr_type
== EXPR_ARRAY
6212 && gfc_is_expandable_expr (con
->expr
))
6220 /* Resolve an expression. That is, make sure that types of operands agree
6221 with their operators, intrinsic operators are converted to function calls
6222 for overloaded types and unresolved function references are resolved. */
6225 gfc_resolve_expr (gfc_expr
*e
)
6228 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6233 /* inquiry_argument only applies to variables. */
6234 inquiry_save
= inquiry_argument
;
6235 actual_arg_save
= actual_arg
;
6236 first_actual_arg_save
= first_actual_arg
;
6238 if (e
->expr_type
!= EXPR_VARIABLE
)
6240 inquiry_argument
= false;
6242 first_actual_arg
= false;
6245 switch (e
->expr_type
)
6248 t
= resolve_operator (e
);
6254 if (check_host_association (e
))
6255 t
= resolve_function (e
);
6257 t
= resolve_variable (e
);
6259 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6260 && e
->ref
->type
!= REF_SUBSTRING
)
6261 gfc_resolve_substring_charlen (e
);
6266 t
= resolve_typebound_function (e
);
6269 case EXPR_SUBSTRING
:
6270 t
= resolve_ref (e
);
6279 t
= resolve_expr_ppc (e
);
6284 if (!resolve_ref (e
))
6287 t
= gfc_resolve_array_constructor (e
);
6288 /* Also try to expand a constructor. */
6291 expression_rank (e
);
6292 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6293 gfc_expand_constructor (e
, false);
6296 /* This provides the opportunity for the length of constructors with
6297 character valued function elements to propagate the string length
6298 to the expression. */
6299 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6301 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6302 here rather then add a duplicate test for it above. */
6303 gfc_expand_constructor (e
, false);
6304 t
= gfc_resolve_character_array_constructor (e
);
6309 case EXPR_STRUCTURE
:
6310 t
= resolve_ref (e
);
6314 t
= resolve_structure_cons (e
, 0);
6318 t
= gfc_simplify_expr (e
, 0);
6322 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6325 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6328 inquiry_argument
= inquiry_save
;
6329 actual_arg
= actual_arg_save
;
6330 first_actual_arg
= first_actual_arg_save
;
6336 /* Resolve an expression from an iterator. They must be scalar and have
6337 INTEGER or (optionally) REAL type. */
6340 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6341 const char *name_msgid
)
6343 if (!gfc_resolve_expr (expr
))
6346 if (expr
->rank
!= 0)
6348 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6352 if (expr
->ts
.type
!= BT_INTEGER
)
6354 if (expr
->ts
.type
== BT_REAL
)
6357 return gfc_notify_std (GFC_STD_F95_DEL
,
6358 "%s at %L must be integer",
6359 _(name_msgid
), &expr
->where
);
6362 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6369 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6377 /* Resolve the expressions in an iterator structure. If REAL_OK is
6378 false allow only INTEGER type iterators, otherwise allow REAL types.
6379 Set own_scope to true for ac-implied-do and data-implied-do as those
6380 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6383 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6385 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6388 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6389 _("iterator variable")))
6392 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6393 "Start expression in DO loop"))
6396 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6397 "End expression in DO loop"))
6400 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6401 "Step expression in DO loop"))
6404 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6406 if ((iter
->step
->ts
.type
== BT_INTEGER
6407 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6408 || (iter
->step
->ts
.type
== BT_REAL
6409 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6411 gfc_error ("Step expression in DO loop at %L cannot be zero",
6412 &iter
->step
->where
);
6417 /* Convert start, end, and step to the same type as var. */
6418 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6419 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6420 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6422 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6423 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6424 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6426 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6427 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6428 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6430 if (iter
->start
->expr_type
== EXPR_CONSTANT
6431 && iter
->end
->expr_type
== EXPR_CONSTANT
6432 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6435 if (iter
->start
->ts
.type
== BT_INTEGER
)
6437 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6438 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6442 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6443 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6445 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6446 gfc_warning (OPT_Wzerotrip
,
6447 "DO loop at %L will be executed zero times",
6448 &iter
->step
->where
);
6455 /* Traversal function for find_forall_index. f == 2 signals that
6456 that variable itself is not to be checked - only the references. */
6459 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6461 if (expr
->expr_type
!= EXPR_VARIABLE
)
6464 /* A scalar assignment */
6465 if (!expr
->ref
|| *f
== 1)
6467 if (expr
->symtree
->n
.sym
== sym
)
6479 /* Check whether the FORALL index appears in the expression or not.
6480 Returns true if SYM is found in EXPR. */
6483 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6485 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6492 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6493 to be a scalar INTEGER variable. The subscripts and stride are scalar
6494 INTEGERs, and if stride is a constant it must be nonzero.
6495 Furthermore "A subscript or stride in a forall-triplet-spec shall
6496 not contain a reference to any index-name in the
6497 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6500 resolve_forall_iterators (gfc_forall_iterator
*it
)
6502 gfc_forall_iterator
*iter
, *iter2
;
6504 for (iter
= it
; iter
; iter
= iter
->next
)
6506 if (gfc_resolve_expr (iter
->var
)
6507 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6508 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6511 if (gfc_resolve_expr (iter
->start
)
6512 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6513 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6514 &iter
->start
->where
);
6515 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6516 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6518 if (gfc_resolve_expr (iter
->end
)
6519 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6520 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6522 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6523 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6525 if (gfc_resolve_expr (iter
->stride
))
6527 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6528 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6529 &iter
->stride
->where
, "INTEGER");
6531 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6532 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6533 gfc_error ("FORALL stride expression at %L cannot be zero",
6534 &iter
->stride
->where
);
6536 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6537 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6540 for (iter
= it
; iter
; iter
= iter
->next
)
6541 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6543 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6544 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6545 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6546 gfc_error ("FORALL index %qs may not appear in triplet "
6547 "specification at %L", iter
->var
->symtree
->name
,
6548 &iter2
->start
->where
);
6553 /* Given a pointer to a symbol that is a derived type, see if it's
6554 inaccessible, i.e. if it's defined in another module and the components are
6555 PRIVATE. The search is recursive if necessary. Returns zero if no
6556 inaccessible components are found, nonzero otherwise. */
6559 derived_inaccessible (gfc_symbol
*sym
)
6563 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6566 for (c
= sym
->components
; c
; c
= c
->next
)
6568 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6576 /* Resolve the argument of a deallocate expression. The expression must be
6577 a pointer or a full array. */
6580 resolve_deallocate_expr (gfc_expr
*e
)
6582 symbol_attribute attr
;
6583 int allocatable
, pointer
;
6589 if (!gfc_resolve_expr (e
))
6592 if (e
->expr_type
!= EXPR_VARIABLE
)
6595 sym
= e
->symtree
->n
.sym
;
6596 unlimited
= UNLIMITED_POLY(sym
);
6598 if (sym
->ts
.type
== BT_CLASS
)
6600 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6601 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6605 allocatable
= sym
->attr
.allocatable
;
6606 pointer
= sym
->attr
.pointer
;
6608 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6613 if (ref
->u
.ar
.type
!= AR_FULL
6614 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6615 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6620 c
= ref
->u
.c
.component
;
6621 if (c
->ts
.type
== BT_CLASS
)
6623 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6624 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6628 allocatable
= c
->attr
.allocatable
;
6629 pointer
= c
->attr
.pointer
;
6639 attr
= gfc_expr_attr (e
);
6641 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6644 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6650 if (gfc_is_coindexed (e
))
6652 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6657 && !gfc_check_vardef_context (e
, true, true, false,
6658 _("DEALLOCATE object")))
6660 if (!gfc_check_vardef_context (e
, false, true, false,
6661 _("DEALLOCATE object")))
6668 /* Returns true if the expression e contains a reference to the symbol sym. */
6670 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6672 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6679 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6681 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6685 /* Given the expression node e for an allocatable/pointer of derived type to be
6686 allocated, get the expression node to be initialized afterwards (needed for
6687 derived types with default initializers, and derived types with allocatable
6688 components that need nullification.) */
6691 gfc_expr_to_initialize (gfc_expr
*e
)
6697 result
= gfc_copy_expr (e
);
6699 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6700 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6701 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6703 ref
->u
.ar
.type
= AR_FULL
;
6705 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6706 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6711 gfc_free_shape (&result
->shape
, result
->rank
);
6713 /* Recalculate rank, shape, etc. */
6714 gfc_resolve_expr (result
);
6719 /* If the last ref of an expression is an array ref, return a copy of the
6720 expression with that one removed. Otherwise, a copy of the original
6721 expression. This is used for allocate-expressions and pointer assignment
6722 LHS, where there may be an array specification that needs to be stripped
6723 off when using gfc_check_vardef_context. */
6726 remove_last_array_ref (gfc_expr
* e
)
6731 e2
= gfc_copy_expr (e
);
6732 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6733 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6735 gfc_free_ref_list (*r
);
6744 /* Used in resolve_allocate_expr to check that a allocation-object and
6745 a source-expr are conformable. This does not catch all possible
6746 cases; in particular a runtime checking is needed. */
6749 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6752 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6754 /* First compare rank. */
6755 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6756 || (!tail
&& e1
->rank
!= e2
->rank
))
6758 gfc_error ("Source-expr at %L must be scalar or have the "
6759 "same rank as the allocate-object at %L",
6760 &e1
->where
, &e2
->where
);
6771 for (i
= 0; i
< e1
->rank
; i
++)
6773 if (tail
->u
.ar
.start
[i
] == NULL
)
6776 if (tail
->u
.ar
.end
[i
])
6778 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6779 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6780 mpz_add_ui (s
, s
, 1);
6784 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6787 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6789 gfc_error ("Source-expr at %L and allocate-object at %L must "
6790 "have the same shape", &e1
->where
, &e2
->where
);
6803 /* Resolve the expression in an ALLOCATE statement, doing the additional
6804 checks to see whether the expression is OK or not. The expression must
6805 have a trailing array reference that gives the size of the array. */
6808 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6810 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6814 symbol_attribute attr
;
6815 gfc_ref
*ref
, *ref2
;
6818 gfc_symbol
*sym
= NULL
;
6823 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6824 checking of coarrays. */
6825 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6826 if (ref
->next
== NULL
)
6829 if (ref
&& ref
->type
== REF_ARRAY
)
6830 ref
->u
.ar
.in_allocate
= true;
6832 if (!gfc_resolve_expr (e
))
6835 /* Make sure the expression is allocatable or a pointer. If it is
6836 pointer, the next-to-last reference must be a pointer. */
6840 sym
= e
->symtree
->n
.sym
;
6842 /* Check whether ultimate component is abstract and CLASS. */
6845 /* Is the allocate-object unlimited polymorphic? */
6846 unlimited
= UNLIMITED_POLY(e
);
6848 if (e
->expr_type
!= EXPR_VARIABLE
)
6851 attr
= gfc_expr_attr (e
);
6852 pointer
= attr
.pointer
;
6853 dimension
= attr
.dimension
;
6854 codimension
= attr
.codimension
;
6858 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6860 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6861 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6862 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6863 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6864 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6868 allocatable
= sym
->attr
.allocatable
;
6869 pointer
= sym
->attr
.pointer
;
6870 dimension
= sym
->attr
.dimension
;
6871 codimension
= sym
->attr
.codimension
;
6876 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6881 if (ref
->u
.ar
.codimen
> 0)
6884 for (n
= ref
->u
.ar
.dimen
;
6885 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6886 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6893 if (ref
->next
!= NULL
)
6901 gfc_error ("Coindexed allocatable object at %L",
6906 c
= ref
->u
.c
.component
;
6907 if (c
->ts
.type
== BT_CLASS
)
6909 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6910 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6911 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6912 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6913 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6917 allocatable
= c
->attr
.allocatable
;
6918 pointer
= c
->attr
.pointer
;
6919 dimension
= c
->attr
.dimension
;
6920 codimension
= c
->attr
.codimension
;
6921 is_abstract
= c
->attr
.abstract
;
6933 /* Check for F08:C628. */
6934 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6936 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6941 /* Some checks for the SOURCE tag. */
6944 /* Check F03:C631. */
6945 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6947 gfc_error ("Type of entity at %L is type incompatible with "
6948 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6952 /* Check F03:C632 and restriction following Note 6.18. */
6953 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6956 /* Check F03:C633. */
6957 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6959 gfc_error ("The allocate-object at %L and the source-expr at %L "
6960 "shall have the same kind type parameter",
6961 &e
->where
, &code
->expr3
->where
);
6965 /* Check F2008, C642. */
6966 if (code
->expr3
->ts
.type
== BT_DERIVED
6967 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6968 || (code
->expr3
->ts
.u
.derived
->from_intmod
6969 == INTMOD_ISO_FORTRAN_ENV
6970 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6971 == ISOFORTRAN_LOCK_TYPE
)))
6973 gfc_error ("The source-expr at %L shall neither be of type "
6974 "LOCK_TYPE nor have a LOCK_TYPE component if "
6975 "allocate-object at %L is a coarray",
6976 &code
->expr3
->where
, &e
->where
);
6981 /* Check F08:C629. */
6982 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6985 gcc_assert (e
->ts
.type
== BT_CLASS
);
6986 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6987 "type-spec or source-expr", sym
->name
, &e
->where
);
6991 /* Check F08:C632. */
6992 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
6993 && !UNLIMITED_POLY (e
))
6995 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6996 code
->ext
.alloc
.ts
.u
.cl
->length
);
6997 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6999 gfc_error ("Allocating %s at %L with type-spec requires the same "
7000 "character-length parameter as in the declaration",
7001 sym
->name
, &e
->where
);
7006 /* In the variable definition context checks, gfc_expr_attr is used
7007 on the expression. This is fooled by the array specification
7008 present in e, thus we have to eliminate that one temporarily. */
7009 e2
= remove_last_array_ref (e
);
7012 t
= gfc_check_vardef_context (e2
, true, true, false,
7013 _("ALLOCATE object"));
7015 t
= gfc_check_vardef_context (e2
, false, true, false,
7016 _("ALLOCATE object"));
7021 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7022 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7024 /* For class arrays, the initialization with SOURCE is done
7025 using _copy and trans_call. It is convenient to exploit that
7026 when the allocated type is different from the declared type but
7027 no SOURCE exists by setting expr3. */
7028 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7030 else if (!code
->expr3
)
7032 /* Set up default initializer if needed. */
7036 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7037 ts
= code
->ext
.alloc
.ts
;
7041 if (ts
.type
== BT_CLASS
)
7042 ts
= ts
.u
.derived
->components
->ts
;
7044 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7046 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
7047 init_st
->loc
= code
->loc
;
7048 init_st
->expr1
= gfc_expr_to_initialize (e
);
7049 init_st
->expr2
= init_e
;
7050 init_st
->next
= code
->next
;
7051 code
->next
= init_st
;
7054 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7056 /* Default initialization via MOLD (non-polymorphic). */
7057 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7060 gfc_resolve_expr (rhs
);
7061 gfc_free_expr (code
->expr3
);
7066 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7068 /* Make sure the vtab symbol is present when
7069 the module variables are generated. */
7070 gfc_typespec ts
= e
->ts
;
7072 ts
= code
->expr3
->ts
;
7073 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7074 ts
= code
->ext
.alloc
.ts
;
7076 gfc_find_derived_vtab (ts
.u
.derived
);
7079 e
= gfc_expr_to_initialize (e
);
7081 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7083 /* Again, make sure the vtab symbol is present when
7084 the module variables are generated. */
7085 gfc_typespec
*ts
= NULL
;
7087 ts
= &code
->expr3
->ts
;
7089 ts
= &code
->ext
.alloc
.ts
;
7096 e
= gfc_expr_to_initialize (e
);
7099 if (dimension
== 0 && codimension
== 0)
7102 /* Make sure the last reference node is an array specification. */
7104 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7105 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7107 gfc_error ("Array specification required in ALLOCATE statement "
7108 "at %L", &e
->where
);
7112 /* Make sure that the array section reference makes sense in the
7113 context of an ALLOCATE specification. */
7118 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7119 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7121 gfc_error ("Coarray specification required in ALLOCATE statement "
7122 "at %L", &e
->where
);
7126 for (i
= 0; i
< ar
->dimen
; i
++)
7128 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7131 switch (ar
->dimen_type
[i
])
7137 if (ar
->start
[i
] != NULL
7138 && ar
->end
[i
] != NULL
7139 && ar
->stride
[i
] == NULL
)
7142 /* Fall Through... */
7147 case DIMEN_THIS_IMAGE
:
7148 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7154 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7156 sym
= a
->expr
->symtree
->n
.sym
;
7158 /* TODO - check derived type components. */
7159 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7162 if ((ar
->start
[i
] != NULL
7163 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7164 || (ar
->end
[i
] != NULL
7165 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7167 gfc_error ("%qs must not appear in the array specification at "
7168 "%L in the same ALLOCATE statement where it is "
7169 "itself allocated", sym
->name
, &ar
->where
);
7175 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7177 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7178 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7180 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7182 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7183 "statement at %L", &e
->where
);
7189 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7190 && ar
->stride
[i
] == NULL
)
7193 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7206 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7208 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7209 gfc_alloc
*a
, *p
, *q
;
7212 errmsg
= code
->expr2
;
7214 /* Check the stat variable. */
7217 gfc_check_vardef_context (stat
, false, false, false,
7218 _("STAT variable"));
7220 if ((stat
->ts
.type
!= BT_INTEGER
7221 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7222 || stat
->ref
->type
== REF_COMPONENT
)))
7224 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7225 "variable", &stat
->where
);
7227 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7228 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7230 gfc_ref
*ref1
, *ref2
;
7233 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7234 ref1
= ref1
->next
, ref2
= ref2
->next
)
7236 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7238 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7247 gfc_error ("Stat-variable at %L shall not be %sd within "
7248 "the same %s statement", &stat
->where
, fcn
, fcn
);
7254 /* Check the errmsg variable. */
7258 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7261 gfc_check_vardef_context (errmsg
, false, false, false,
7262 _("ERRMSG variable"));
7264 if ((errmsg
->ts
.type
!= BT_CHARACTER
7266 && (errmsg
->ref
->type
== REF_ARRAY
7267 || errmsg
->ref
->type
== REF_COMPONENT
)))
7268 || errmsg
->rank
> 0 )
7269 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7270 "variable", &errmsg
->where
);
7272 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7273 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7275 gfc_ref
*ref1
, *ref2
;
7278 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7279 ref1
= ref1
->next
, ref2
= ref2
->next
)
7281 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7283 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7292 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7293 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7299 /* Check that an allocate-object appears only once in the statement. */
7301 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7304 for (q
= p
->next
; q
; q
= q
->next
)
7307 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7309 /* This is a potential collision. */
7310 gfc_ref
*pr
= pe
->ref
;
7311 gfc_ref
*qr
= qe
->ref
;
7313 /* Follow the references until
7314 a) They start to differ, in which case there is no error;
7315 you can deallocate a%b and a%c in a single statement
7316 b) Both of them stop, which is an error
7317 c) One of them stops, which is also an error. */
7320 if (pr
== NULL
&& qr
== NULL
)
7322 gfc_error ("Allocate-object at %L also appears at %L",
7323 &pe
->where
, &qe
->where
);
7326 else if (pr
!= NULL
&& qr
== NULL
)
7328 gfc_error ("Allocate-object at %L is subobject of"
7329 " object at %L", &pe
->where
, &qe
->where
);
7332 else if (pr
== NULL
&& qr
!= NULL
)
7334 gfc_error ("Allocate-object at %L is subobject of"
7335 " object at %L", &qe
->where
, &pe
->where
);
7338 /* Here, pr != NULL && qr != NULL */
7339 gcc_assert(pr
->type
== qr
->type
);
7340 if (pr
->type
== REF_ARRAY
)
7342 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7344 gcc_assert (qr
->type
== REF_ARRAY
);
7346 if (pr
->next
&& qr
->next
)
7349 gfc_array_ref
*par
= &(pr
->u
.ar
);
7350 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7352 for (i
=0; i
<par
->dimen
; i
++)
7354 if ((par
->start
[i
] != NULL
7355 || qar
->start
[i
] != NULL
)
7356 && gfc_dep_compare_expr (par
->start
[i
],
7357 qar
->start
[i
]) != 0)
7364 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7377 if (strcmp (fcn
, "ALLOCATE") == 0)
7379 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7380 resolve_allocate_expr (a
->expr
, code
);
7384 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7385 resolve_deallocate_expr (a
->expr
);
7390 /************ SELECT CASE resolution subroutines ************/
7392 /* Callback function for our mergesort variant. Determines interval
7393 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7394 op1 > op2. Assumes we're not dealing with the default case.
7395 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7396 There are nine situations to check. */
7399 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7403 if (op1
->low
== NULL
) /* op1 = (:L) */
7405 /* op2 = (:N), so overlap. */
7407 /* op2 = (M:) or (M:N), L < M */
7408 if (op2
->low
!= NULL
7409 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7412 else if (op1
->high
== NULL
) /* op1 = (K:) */
7414 /* op2 = (M:), so overlap. */
7416 /* op2 = (:N) or (M:N), K > N */
7417 if (op2
->high
!= NULL
7418 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7421 else /* op1 = (K:L) */
7423 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7424 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7426 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7427 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7429 else /* op2 = (M:N) */
7433 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7436 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7445 /* Merge-sort a double linked case list, detecting overlap in the
7446 process. LIST is the head of the double linked case list before it
7447 is sorted. Returns the head of the sorted list if we don't see any
7448 overlap, or NULL otherwise. */
7451 check_case_overlap (gfc_case
*list
)
7453 gfc_case
*p
, *q
, *e
, *tail
;
7454 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7456 /* If the passed list was empty, return immediately. */
7463 /* Loop unconditionally. The only exit from this loop is a return
7464 statement, when we've finished sorting the case list. */
7471 /* Count the number of merges we do in this pass. */
7474 /* Loop while there exists a merge to be done. */
7479 /* Count this merge. */
7482 /* Cut the list in two pieces by stepping INSIZE places
7483 forward in the list, starting from P. */
7486 for (i
= 0; i
< insize
; i
++)
7495 /* Now we have two lists. Merge them! */
7496 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7498 /* See from which the next case to merge comes from. */
7501 /* P is empty so the next case must come from Q. */
7506 else if (qsize
== 0 || q
== NULL
)
7515 cmp
= compare_cases (p
, q
);
7518 /* The whole case range for P is less than the
7526 /* The whole case range for Q is greater than
7527 the case range for P. */
7534 /* The cases overlap, or they are the same
7535 element in the list. Either way, we must
7536 issue an error and get the next case from P. */
7537 /* FIXME: Sort P and Q by line number. */
7538 gfc_error ("CASE label at %L overlaps with CASE "
7539 "label at %L", &p
->where
, &q
->where
);
7547 /* Add the next element to the merged list. */
7556 /* P has now stepped INSIZE places along, and so has Q. So
7557 they're the same. */
7562 /* If we have done only one merge or none at all, we've
7563 finished sorting the cases. */
7572 /* Otherwise repeat, merging lists twice the size. */
7578 /* Check to see if an expression is suitable for use in a CASE statement.
7579 Makes sure that all case expressions are scalar constants of the same
7580 type. Return false if anything is wrong. */
7583 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7585 if (e
== NULL
) return true;
7587 if (e
->ts
.type
!= case_expr
->ts
.type
)
7589 gfc_error ("Expression in CASE statement at %L must be of type %s",
7590 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7594 /* C805 (R808) For a given case-construct, each case-value shall be of
7595 the same type as case-expr. For character type, length differences
7596 are allowed, but the kind type parameters shall be the same. */
7598 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7600 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7601 &e
->where
, case_expr
->ts
.kind
);
7605 /* Convert the case value kind to that of case expression kind,
7608 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7609 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7613 gfc_error ("Expression in CASE statement at %L must be scalar",
7622 /* Given a completely parsed select statement, we:
7624 - Validate all expressions and code within the SELECT.
7625 - Make sure that the selection expression is not of the wrong type.
7626 - Make sure that no case ranges overlap.
7627 - Eliminate unreachable cases and unreachable code resulting from
7628 removing case labels.
7630 The standard does allow unreachable cases, e.g. CASE (5:3). But
7631 they are a hassle for code generation, and to prevent that, we just
7632 cut them out here. This is not necessary for overlapping cases
7633 because they are illegal and we never even try to generate code.
7635 We have the additional caveat that a SELECT construct could have
7636 been a computed GOTO in the source code. Fortunately we can fairly
7637 easily work around that here: The case_expr for a "real" SELECT CASE
7638 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7639 we have to do is make sure that the case_expr is a scalar integer
7643 resolve_select (gfc_code
*code
, bool select_type
)
7646 gfc_expr
*case_expr
;
7647 gfc_case
*cp
, *default_case
, *tail
, *head
;
7648 int seen_unreachable
;
7654 if (code
->expr1
== NULL
)
7656 /* This was actually a computed GOTO statement. */
7657 case_expr
= code
->expr2
;
7658 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7659 gfc_error ("Selection expression in computed GOTO statement "
7660 "at %L must be a scalar integer expression",
7663 /* Further checking is not necessary because this SELECT was built
7664 by the compiler, so it should always be OK. Just move the
7665 case_expr from expr2 to expr so that we can handle computed
7666 GOTOs as normal SELECTs from here on. */
7667 code
->expr1
= code
->expr2
;
7672 case_expr
= code
->expr1
;
7673 type
= case_expr
->ts
.type
;
7676 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7678 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7679 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7681 /* Punt. Going on here just produce more garbage error messages. */
7686 if (!select_type
&& case_expr
->rank
!= 0)
7688 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7689 "expression", &case_expr
->where
);
7695 /* Raise a warning if an INTEGER case value exceeds the range of
7696 the case-expr. Later, all expressions will be promoted to the
7697 largest kind of all case-labels. */
7699 if (type
== BT_INTEGER
)
7700 for (body
= code
->block
; body
; body
= body
->block
)
7701 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7704 && gfc_check_integer_range (cp
->low
->value
.integer
,
7705 case_expr
->ts
.kind
) != ARITH_OK
)
7706 gfc_warning (0, "Expression in CASE statement at %L is "
7707 "not in the range of %s", &cp
->low
->where
,
7708 gfc_typename (&case_expr
->ts
));
7711 && cp
->low
!= cp
->high
7712 && gfc_check_integer_range (cp
->high
->value
.integer
,
7713 case_expr
->ts
.kind
) != ARITH_OK
)
7714 gfc_warning (0, "Expression in CASE statement at %L is "
7715 "not in the range of %s", &cp
->high
->where
,
7716 gfc_typename (&case_expr
->ts
));
7719 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7720 of the SELECT CASE expression and its CASE values. Walk the lists
7721 of case values, and if we find a mismatch, promote case_expr to
7722 the appropriate kind. */
7724 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7726 for (body
= code
->block
; body
; body
= body
->block
)
7728 /* Walk the case label list. */
7729 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7731 /* Intercept the DEFAULT case. It does not have a kind. */
7732 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7735 /* Unreachable case ranges are discarded, so ignore. */
7736 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7737 && cp
->low
!= cp
->high
7738 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7742 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7743 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7745 if (cp
->high
!= NULL
7746 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7747 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7752 /* Assume there is no DEFAULT case. */
7753 default_case
= NULL
;
7758 for (body
= code
->block
; body
; body
= body
->block
)
7760 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7762 seen_unreachable
= 0;
7764 /* Walk the case label list, making sure that all case labels
7766 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7768 /* Count the number of cases in the whole construct. */
7771 /* Intercept the DEFAULT case. */
7772 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7774 if (default_case
!= NULL
)
7776 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7777 "by a second DEFAULT CASE at %L",
7778 &default_case
->where
, &cp
->where
);
7789 /* Deal with single value cases and case ranges. Errors are
7790 issued from the validation function. */
7791 if (!validate_case_label_expr (cp
->low
, case_expr
)
7792 || !validate_case_label_expr (cp
->high
, case_expr
))
7798 if (type
== BT_LOGICAL
7799 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7800 || cp
->low
!= cp
->high
))
7802 gfc_error ("Logical range in CASE statement at %L is not "
7803 "allowed", &cp
->low
->where
);
7808 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7811 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7812 if (value
& seen_logical
)
7814 gfc_error ("Constant logical value in CASE statement "
7815 "is repeated at %L",
7820 seen_logical
|= value
;
7823 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7824 && cp
->low
!= cp
->high
7825 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7827 if (warn_surprising
)
7828 gfc_warning (OPT_Wsurprising
,
7829 "Range specification at %L can never be matched",
7832 cp
->unreachable
= 1;
7833 seen_unreachable
= 1;
7837 /* If the case range can be matched, it can also overlap with
7838 other cases. To make sure it does not, we put it in a
7839 double linked list here. We sort that with a merge sort
7840 later on to detect any overlapping cases. */
7844 head
->right
= head
->left
= NULL
;
7849 tail
->right
->left
= tail
;
7856 /* It there was a failure in the previous case label, give up
7857 for this case label list. Continue with the next block. */
7861 /* See if any case labels that are unreachable have been seen.
7862 If so, we eliminate them. This is a bit of a kludge because
7863 the case lists for a single case statement (label) is a
7864 single forward linked lists. */
7865 if (seen_unreachable
)
7867 /* Advance until the first case in the list is reachable. */
7868 while (body
->ext
.block
.case_list
!= NULL
7869 && body
->ext
.block
.case_list
->unreachable
)
7871 gfc_case
*n
= body
->ext
.block
.case_list
;
7872 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7874 gfc_free_case_list (n
);
7877 /* Strip all other unreachable cases. */
7878 if (body
->ext
.block
.case_list
)
7880 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7882 if (cp
->next
->unreachable
)
7884 gfc_case
*n
= cp
->next
;
7885 cp
->next
= cp
->next
->next
;
7887 gfc_free_case_list (n
);
7894 /* See if there were overlapping cases. If the check returns NULL,
7895 there was overlap. In that case we don't do anything. If head
7896 is non-NULL, we prepend the DEFAULT case. The sorted list can
7897 then used during code generation for SELECT CASE constructs with
7898 a case expression of a CHARACTER type. */
7901 head
= check_case_overlap (head
);
7903 /* Prepend the default_case if it is there. */
7904 if (head
!= NULL
&& default_case
)
7906 default_case
->left
= NULL
;
7907 default_case
->right
= head
;
7908 head
->left
= default_case
;
7912 /* Eliminate dead blocks that may be the result if we've seen
7913 unreachable case labels for a block. */
7914 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7916 if (body
->block
->ext
.block
.case_list
== NULL
)
7918 /* Cut the unreachable block from the code chain. */
7919 gfc_code
*c
= body
->block
;
7920 body
->block
= c
->block
;
7922 /* Kill the dead block, but not the blocks below it. */
7924 gfc_free_statements (c
);
7928 /* More than two cases is legal but insane for logical selects.
7929 Issue a warning for it. */
7930 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
7931 gfc_warning (OPT_Wsurprising
,
7932 "Logical SELECT CASE block at %L has more that two cases",
7937 /* Check if a derived type is extensible. */
7940 gfc_type_is_extensible (gfc_symbol
*sym
)
7942 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7943 || (sym
->attr
.is_class
7944 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7948 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7949 correct as well as possibly the array-spec. */
7952 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7956 gcc_assert (sym
->assoc
);
7957 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7959 /* If this is for SELECT TYPE, the target may not yet be set. In that
7960 case, return. Resolution will be called later manually again when
7962 target
= sym
->assoc
->target
;
7965 gcc_assert (!sym
->assoc
->dangling
);
7967 if (resolve_target
&& !gfc_resolve_expr (target
))
7970 /* For variable targets, we get some attributes from the target. */
7971 if (target
->expr_type
== EXPR_VARIABLE
)
7975 gcc_assert (target
->symtree
);
7976 tsym
= target
->symtree
->n
.sym
;
7978 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7979 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7981 sym
->attr
.target
= tsym
->attr
.target
7982 || gfc_expr_attr (target
).pointer
;
7983 if (is_subref_array (target
))
7984 sym
->attr
.subref_array_pointer
= 1;
7987 /* Get type if this was not already set. Note that it can be
7988 some other type than the target in case this is a SELECT TYPE
7989 selector! So we must not update when the type is already there. */
7990 if (sym
->ts
.type
== BT_UNKNOWN
)
7991 sym
->ts
= target
->ts
;
7992 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7994 /* See if this is a valid association-to-variable. */
7995 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7996 && !gfc_has_vector_subscript (target
));
7998 /* Finally resolve if this is an array or not. */
7999 if (sym
->attr
.dimension
&& target
->rank
== 0)
8001 /* primary.c makes the assumption that a reference to an associate
8002 name followed by a left parenthesis is an array reference. */
8003 if (sym
->ts
.type
!= BT_CHARACTER
)
8004 gfc_error ("Associate-name %qs at %L is used as array",
8005 sym
->name
, &sym
->declared_at
);
8006 sym
->attr
.dimension
= 0;
8010 /* We cannot deal with class selectors that need temporaries. */
8011 if (target
->ts
.type
== BT_CLASS
8012 && gfc_ref_needs_temporary_p (target
->ref
))
8014 gfc_error ("CLASS selector at %L needs a temporary which is not "
8015 "yet implemented", &target
->where
);
8019 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8020 sym
->attr
.dimension
= 1;
8021 else if (target
->ts
.type
== BT_CLASS
)
8022 gfc_fix_class_refs (target
);
8024 /* The associate-name will have a correct type by now. Make absolutely
8025 sure that it has not picked up a dimension attribute. */
8026 if (sym
->ts
.type
== BT_CLASS
)
8027 sym
->attr
.dimension
= 0;
8029 if (sym
->attr
.dimension
)
8031 sym
->as
= gfc_get_array_spec ();
8032 sym
->as
->rank
= target
->rank
;
8033 sym
->as
->type
= AS_DEFERRED
;
8034 sym
->as
->corank
= gfc_get_corank (target
);
8037 /* Mark this as an associate variable. */
8038 sym
->attr
.associate_var
= 1;
8040 /* If the target is a good class object, so is the associate variable. */
8041 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8042 sym
->attr
.class_ok
= 1;
8046 /* Resolve a SELECT TYPE statement. */
8049 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8051 gfc_symbol
*selector_type
;
8052 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8053 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8056 char name
[GFC_MAX_SYMBOL_LEN
];
8061 ns
= code
->ext
.block
.ns
;
8064 /* Check for F03:C813. */
8065 if (code
->expr1
->ts
.type
!= BT_CLASS
8066 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8068 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8069 "at %L", &code
->loc
);
8073 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8078 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8079 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8080 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8082 /* F2008: C803 The selector expression must not be coindexed. */
8083 if (gfc_is_coindexed (code
->expr2
))
8085 gfc_error ("Selector at %L must not be coindexed",
8086 &code
->expr2
->where
);
8093 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8095 if (gfc_is_coindexed (code
->expr1
))
8097 gfc_error ("Selector at %L must not be coindexed",
8098 &code
->expr1
->where
);
8103 /* Loop over TYPE IS / CLASS IS cases. */
8104 for (body
= code
->block
; body
; body
= body
->block
)
8106 c
= body
->ext
.block
.case_list
;
8108 /* Check F03:C815. */
8109 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8110 && !selector_type
->attr
.unlimited_polymorphic
8111 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8113 gfc_error ("Derived type %qs at %L must be extensible",
8114 c
->ts
.u
.derived
->name
, &c
->where
);
8119 /* Check F03:C816. */
8120 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8121 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8122 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8124 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8125 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8126 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8128 gfc_error ("Unexpected intrinsic type %qs at %L",
8129 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8134 /* Check F03:C814. */
8135 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8137 gfc_error ("The type-spec at %L shall specify that each length "
8138 "type parameter is assumed", &c
->where
);
8143 /* Intercept the DEFAULT case. */
8144 if (c
->ts
.type
== BT_UNKNOWN
)
8146 /* Check F03:C818. */
8149 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8150 "by a second DEFAULT CASE at %L",
8151 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8156 default_case
= body
;
8163 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8164 target if present. If there are any EXIT statements referring to the
8165 SELECT TYPE construct, this is no problem because the gfc_code
8166 reference stays the same and EXIT is equally possible from the BLOCK
8167 it is changed to. */
8168 code
->op
= EXEC_BLOCK
;
8171 gfc_association_list
* assoc
;
8173 assoc
= gfc_get_association_list ();
8174 assoc
->st
= code
->expr1
->symtree
;
8175 assoc
->target
= gfc_copy_expr (code
->expr2
);
8176 assoc
->target
->where
= code
->expr2
->where
;
8177 /* assoc->variable will be set by resolve_assoc_var. */
8179 code
->ext
.block
.assoc
= assoc
;
8180 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8182 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8185 code
->ext
.block
.assoc
= NULL
;
8187 /* Add EXEC_SELECT to switch on type. */
8188 new_st
= gfc_get_code (code
->op
);
8189 new_st
->expr1
= code
->expr1
;
8190 new_st
->expr2
= code
->expr2
;
8191 new_st
->block
= code
->block
;
8192 code
->expr1
= code
->expr2
= NULL
;
8197 ns
->code
->next
= new_st
;
8199 code
->op
= EXEC_SELECT
;
8201 gfc_add_vptr_component (code
->expr1
);
8202 gfc_add_hash_component (code
->expr1
);
8204 /* Loop over TYPE IS / CLASS IS cases. */
8205 for (body
= code
->block
; body
; body
= body
->block
)
8207 c
= body
->ext
.block
.case_list
;
8209 if (c
->ts
.type
== BT_DERIVED
)
8210 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8211 c
->ts
.u
.derived
->hash_value
);
8212 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8217 ivtab
= gfc_find_vtab (&c
->ts
);
8218 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8219 e
= CLASS_DATA (ivtab
)->initializer
;
8220 c
->low
= c
->high
= gfc_copy_expr (e
);
8223 else if (c
->ts
.type
== BT_UNKNOWN
)
8226 /* Associate temporary to selector. This should only be done
8227 when this case is actually true, so build a new ASSOCIATE
8228 that does precisely this here (instead of using the
8231 if (c
->ts
.type
== BT_CLASS
)
8232 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8233 else if (c
->ts
.type
== BT_DERIVED
)
8234 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8235 else if (c
->ts
.type
== BT_CHARACTER
)
8237 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8238 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8239 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8240 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8241 charlen
, c
->ts
.kind
);
8244 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8247 st
= gfc_find_symtree (ns
->sym_root
, name
);
8248 gcc_assert (st
->n
.sym
->assoc
);
8249 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8250 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8251 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8252 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8254 new_st
= gfc_get_code (EXEC_BLOCK
);
8255 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8256 new_st
->ext
.block
.ns
->code
= body
->next
;
8257 body
->next
= new_st
;
8259 /* Chain in the new list only if it is marked as dangling. Otherwise
8260 there is a CASE label overlap and this is already used. Just ignore,
8261 the error is diagnosed elsewhere. */
8262 if (st
->n
.sym
->assoc
->dangling
)
8264 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8265 st
->n
.sym
->assoc
->dangling
= 0;
8268 resolve_assoc_var (st
->n
.sym
, false);
8271 /* Take out CLASS IS cases for separate treatment. */
8273 while (body
&& body
->block
)
8275 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8277 /* Add to class_is list. */
8278 if (class_is
== NULL
)
8280 class_is
= body
->block
;
8285 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8286 tail
->block
= body
->block
;
8289 /* Remove from EXEC_SELECT list. */
8290 body
->block
= body
->block
->block
;
8303 /* Add a default case to hold the CLASS IS cases. */
8304 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8305 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8307 tail
->ext
.block
.case_list
= gfc_get_case ();
8308 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8310 default_case
= tail
;
8313 /* More than one CLASS IS block? */
8314 if (class_is
->block
)
8318 /* Sort CLASS IS blocks by extension level. */
8322 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8325 /* F03:C817 (check for doubles). */
8326 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8327 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8329 gfc_error ("Double CLASS IS block in SELECT TYPE "
8331 &c2
->ext
.block
.case_list
->where
);
8334 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8335 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8338 (*c1
)->block
= c2
->block
;
8348 /* Generate IF chain. */
8349 if_st
= gfc_get_code (EXEC_IF
);
8351 for (body
= class_is
; body
; body
= body
->block
)
8353 new_st
->block
= gfc_get_code (EXEC_IF
);
8354 new_st
= new_st
->block
;
8355 /* Set up IF condition: Call _gfortran_is_extension_of. */
8356 new_st
->expr1
= gfc_get_expr ();
8357 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8358 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8359 new_st
->expr1
->ts
.kind
= 4;
8360 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8361 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8362 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8363 /* Set up arguments. */
8364 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8365 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8366 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8367 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8368 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8369 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8370 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8371 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8372 new_st
->next
= body
->next
;
8374 if (default_case
->next
)
8376 new_st
->block
= gfc_get_code (EXEC_IF
);
8377 new_st
= new_st
->block
;
8378 new_st
->next
= default_case
->next
;
8381 /* Replace CLASS DEFAULT code by the IF chain. */
8382 default_case
->next
= if_st
;
8385 /* Resolve the internal code. This can not be done earlier because
8386 it requires that the sym->assoc of selectors is set already. */
8387 gfc_current_ns
= ns
;
8388 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8389 gfc_current_ns
= old_ns
;
8391 resolve_select (code
, true);
8395 /* Resolve a transfer statement. This is making sure that:
8396 -- a derived type being transferred has only non-pointer components
8397 -- a derived type being transferred doesn't have private components, unless
8398 it's being transferred from the module where the type was defined
8399 -- we're not trying to transfer a whole assumed size array. */
8402 resolve_transfer (gfc_code
*code
)
8411 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8412 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8413 exp
= exp
->value
.op
.op1
;
8415 if (exp
&& exp
->expr_type
== EXPR_NULL
8418 gfc_error ("Invalid context for NULL () intrinsic at %L",
8423 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8424 && exp
->expr_type
!= EXPR_FUNCTION
8425 && exp
->expr_type
!= EXPR_STRUCTURE
))
8428 /* If we are reading, the variable will be changed. Note that
8429 code->ext.dt may be NULL if the TRANSFER is related to
8430 an INQUIRE statement -- but in this case, we are not reading, either. */
8431 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8432 && !gfc_check_vardef_context (exp
, false, false, false,
8436 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8438 /* Go to actual component transferred. */
8439 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8440 if (ref
->type
== REF_COMPONENT
)
8441 ts
= &ref
->u
.c
.component
->ts
;
8443 if (ts
->type
== BT_CLASS
)
8445 /* FIXME: Test for defined input/output. */
8446 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8447 "it is processed by a defined input/output procedure",
8452 if (ts
->type
== BT_DERIVED
)
8454 /* Check that transferred derived type doesn't contain POINTER
8456 if (ts
->u
.derived
->attr
.pointer_comp
)
8458 gfc_error ("Data transfer element at %L cannot have POINTER "
8459 "components unless it is processed by a defined "
8460 "input/output procedure", &code
->loc
);
8465 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8467 gfc_error ("Data transfer element at %L cannot have "
8468 "procedure pointer components", &code
->loc
);
8472 if (ts
->u
.derived
->attr
.alloc_comp
)
8474 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8475 "components unless it is processed by a defined "
8476 "input/output procedure", &code
->loc
);
8480 /* C_PTR and C_FUNPTR have private components which means they can not
8481 be printed. However, if -std=gnu and not -pedantic, allow
8482 the component to be printed to help debugging. */
8483 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8485 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8486 "cannot have PRIVATE components", &code
->loc
))
8489 else if (derived_inaccessible (ts
->u
.derived
))
8491 gfc_error ("Data transfer element at %L cannot have "
8492 "PRIVATE components",&code
->loc
);
8497 if (exp
->expr_type
== EXPR_STRUCTURE
)
8500 sym
= exp
->symtree
->n
.sym
;
8502 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8503 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8505 gfc_error ("Data transfer element at %L cannot be a full reference to "
8506 "an assumed-size array", &code
->loc
);
8512 /*********** Toplevel code resolution subroutines ***********/
8514 /* Find the set of labels that are reachable from this block. We also
8515 record the last statement in each block. */
8518 find_reachable_labels (gfc_code
*block
)
8525 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8527 /* Collect labels in this block. We don't keep those corresponding
8528 to END {IF|SELECT}, these are checked in resolve_branch by going
8529 up through the code_stack. */
8530 for (c
= block
; c
; c
= c
->next
)
8532 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8533 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8536 /* Merge with labels from parent block. */
8539 gcc_assert (cs_base
->prev
->reachable_labels
);
8540 bitmap_ior_into (cs_base
->reachable_labels
,
8541 cs_base
->prev
->reachable_labels
);
8547 resolve_lock_unlock (gfc_code
*code
)
8549 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8550 && code
->expr1
->value
.function
.isym
8551 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8552 remove_caf_get_intrinsic (code
->expr1
);
8554 if (code
->expr1
->ts
.type
!= BT_DERIVED
8555 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8556 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8557 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8558 || code
->expr1
->rank
!= 0
8559 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8560 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8561 &code
->expr1
->where
);
8565 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8566 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8567 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8568 &code
->expr2
->where
);
8571 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8572 _("STAT variable")))
8577 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8578 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8579 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8580 &code
->expr3
->where
);
8583 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8584 _("ERRMSG variable")))
8587 /* Check ACQUIRED_LOCK. */
8589 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8590 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8591 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8592 "variable", &code
->expr4
->where
);
8595 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8596 _("ACQUIRED_LOCK variable")))
8602 resolve_critical (gfc_code
*code
)
8604 gfc_symtree
*symtree
;
8605 gfc_symbol
*lock_type
;
8606 char name
[GFC_MAX_SYMBOL_LEN
];
8607 static int serial
= 0;
8609 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8612 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8613 GFC_PREFIX ("lock_type"));
8615 lock_type
= symtree
->n
.sym
;
8618 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8621 lock_type
= symtree
->n
.sym
;
8622 lock_type
->attr
.flavor
= FL_DERIVED
;
8623 lock_type
->attr
.zero_comp
= 1;
8624 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8625 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8628 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8629 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8632 code
->resolved_sym
= symtree
->n
.sym
;
8633 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8634 symtree
->n
.sym
->attr
.referenced
= 1;
8635 symtree
->n
.sym
->attr
.artificial
= 1;
8636 symtree
->n
.sym
->attr
.codimension
= 1;
8637 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8638 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8639 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8640 symtree
->n
.sym
->as
->corank
= 1;
8641 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8642 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8643 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8649 resolve_sync (gfc_code
*code
)
8651 /* Check imageset. The * case matches expr1 == NULL. */
8654 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8655 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8656 "INTEGER expression", &code
->expr1
->where
);
8657 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8658 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8659 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8660 &code
->expr1
->where
);
8661 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8662 && gfc_simplify_expr (code
->expr1
, 0))
8664 gfc_constructor
*cons
;
8665 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8666 for (; cons
; cons
= gfc_constructor_next (cons
))
8667 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8668 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8669 gfc_error ("Imageset argument at %L must between 1 and "
8670 "num_images()", &cons
->expr
->where
);
8676 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8677 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8678 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8679 &code
->expr2
->where
);
8683 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8684 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8685 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8686 &code
->expr3
->where
);
8690 /* Given a branch to a label, see if the branch is conforming.
8691 The code node describes where the branch is located. */
8694 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8701 /* Step one: is this a valid branching target? */
8703 if (label
->defined
== ST_LABEL_UNKNOWN
)
8705 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8710 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8712 gfc_error ("Statement at %L is not a valid branch target statement "
8713 "for the branch statement at %L", &label
->where
, &code
->loc
);
8717 /* Step two: make sure this branch is not a branch to itself ;-) */
8719 if (code
->here
== label
)
8722 "Branch at %L may result in an infinite loop", &code
->loc
);
8726 /* Step three: See if the label is in the same block as the
8727 branching statement. The hard work has been done by setting up
8728 the bitmap reachable_labels. */
8730 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8732 /* Check now whether there is a CRITICAL construct; if so, check
8733 whether the label is still visible outside of the CRITICAL block,
8734 which is invalid. */
8735 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8737 if (stack
->current
->op
== EXEC_CRITICAL
8738 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8739 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8740 "label at %L", &code
->loc
, &label
->where
);
8741 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8742 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8743 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8744 "for label at %L", &code
->loc
, &label
->where
);
8750 /* Step four: If we haven't found the label in the bitmap, it may
8751 still be the label of the END of the enclosing block, in which
8752 case we find it by going up the code_stack. */
8754 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8756 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8758 if (stack
->current
->op
== EXEC_CRITICAL
)
8760 /* Note: A label at END CRITICAL does not leave the CRITICAL
8761 construct as END CRITICAL is still part of it. */
8762 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8763 " at %L", &code
->loc
, &label
->where
);
8766 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8768 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8769 "label at %L", &code
->loc
, &label
->where
);
8776 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8780 /* The label is not in an enclosing block, so illegal. This was
8781 allowed in Fortran 66, so we allow it as extension. No
8782 further checks are necessary in this case. */
8783 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8784 "as the GOTO statement at %L", &label
->where
,
8790 /* Check whether EXPR1 has the same shape as EXPR2. */
8793 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8795 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8796 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8797 bool result
= false;
8800 /* Compare the rank. */
8801 if (expr1
->rank
!= expr2
->rank
)
8804 /* Compare the size of each dimension. */
8805 for (i
=0; i
<expr1
->rank
; i
++)
8807 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8810 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8813 if (mpz_cmp (shape
[i
], shape2
[i
]))
8817 /* When either of the two expression is an assumed size array, we
8818 ignore the comparison of dimension sizes. */
8823 gfc_clear_shape (shape
, i
);
8824 gfc_clear_shape (shape2
, i
);
8829 /* Check whether a WHERE assignment target or a WHERE mask expression
8830 has the same shape as the outmost WHERE mask expression. */
8833 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8839 cblock
= code
->block
;
8841 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8842 In case of nested WHERE, only the outmost one is stored. */
8843 if (mask
== NULL
) /* outmost WHERE */
8845 else /* inner WHERE */
8852 /* Check if the mask-expr has a consistent shape with the
8853 outmost WHERE mask-expr. */
8854 if (!resolve_where_shape (cblock
->expr1
, e
))
8855 gfc_error ("WHERE mask at %L has inconsistent shape",
8856 &cblock
->expr1
->where
);
8859 /* the assignment statement of a WHERE statement, or the first
8860 statement in where-body-construct of a WHERE construct */
8861 cnext
= cblock
->next
;
8866 /* WHERE assignment statement */
8869 /* Check shape consistent for WHERE assignment target. */
8870 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8871 gfc_error ("WHERE assignment target at %L has "
8872 "inconsistent shape", &cnext
->expr1
->where
);
8876 case EXEC_ASSIGN_CALL
:
8877 resolve_call (cnext
);
8878 if (!cnext
->resolved_sym
->attr
.elemental
)
8879 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8880 &cnext
->ext
.actual
->expr
->where
);
8883 /* WHERE or WHERE construct is part of a where-body-construct */
8885 resolve_where (cnext
, e
);
8889 gfc_error ("Unsupported statement inside WHERE at %L",
8892 /* the next statement within the same where-body-construct */
8893 cnext
= cnext
->next
;
8895 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8896 cblock
= cblock
->block
;
8901 /* Resolve assignment in FORALL construct.
8902 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8903 FORALL index variables. */
8906 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8910 for (n
= 0; n
< nvar
; n
++)
8912 gfc_symbol
*forall_index
;
8914 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8916 /* Check whether the assignment target is one of the FORALL index
8918 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8919 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8920 gfc_error ("Assignment to a FORALL index variable at %L",
8921 &code
->expr1
->where
);
8924 /* If one of the FORALL index variables doesn't appear in the
8925 assignment variable, then there could be a many-to-one
8926 assignment. Emit a warning rather than an error because the
8927 mask could be resolving this problem. */
8928 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8929 gfc_warning (0, "The FORALL with index %qs is not used on the "
8930 "left side of the assignment at %L and so might "
8931 "cause multiple assignment to this object",
8932 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8938 /* Resolve WHERE statement in FORALL construct. */
8941 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8942 gfc_expr
**var_expr
)
8947 cblock
= code
->block
;
8950 /* the assignment statement of a WHERE statement, or the first
8951 statement in where-body-construct of a WHERE construct */
8952 cnext
= cblock
->next
;
8957 /* WHERE assignment statement */
8959 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8962 /* WHERE operator assignment statement */
8963 case EXEC_ASSIGN_CALL
:
8964 resolve_call (cnext
);
8965 if (!cnext
->resolved_sym
->attr
.elemental
)
8966 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8967 &cnext
->ext
.actual
->expr
->where
);
8970 /* WHERE or WHERE construct is part of a where-body-construct */
8972 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8976 gfc_error ("Unsupported statement inside WHERE at %L",
8979 /* the next statement within the same where-body-construct */
8980 cnext
= cnext
->next
;
8982 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8983 cblock
= cblock
->block
;
8988 /* Traverse the FORALL body to check whether the following errors exist:
8989 1. For assignment, check if a many-to-one assignment happens.
8990 2. For WHERE statement, check the WHERE body to see if there is any
8991 many-to-one assignment. */
8994 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8998 c
= code
->block
->next
;
9004 case EXEC_POINTER_ASSIGN
:
9005 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9008 case EXEC_ASSIGN_CALL
:
9012 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9013 there is no need to handle it here. */
9017 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9022 /* The next statement in the FORALL body. */
9028 /* Counts the number of iterators needed inside a forall construct, including
9029 nested forall constructs. This is used to allocate the needed memory
9030 in gfc_resolve_forall. */
9033 gfc_count_forall_iterators (gfc_code
*code
)
9035 int max_iters
, sub_iters
, current_iters
;
9036 gfc_forall_iterator
*fa
;
9038 gcc_assert(code
->op
== EXEC_FORALL
);
9042 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9045 code
= code
->block
->next
;
9049 if (code
->op
== EXEC_FORALL
)
9051 sub_iters
= gfc_count_forall_iterators (code
);
9052 if (sub_iters
> max_iters
)
9053 max_iters
= sub_iters
;
9058 return current_iters
+ max_iters
;
9062 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9063 gfc_resolve_forall_body to resolve the FORALL body. */
9066 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9068 static gfc_expr
**var_expr
;
9069 static int total_var
= 0;
9070 static int nvar
= 0;
9072 gfc_forall_iterator
*fa
;
9077 /* Start to resolve a FORALL construct */
9078 if (forall_save
== 0)
9080 /* Count the total number of FORALL index in the nested FORALL
9081 construct in order to allocate the VAR_EXPR with proper size. */
9082 total_var
= gfc_count_forall_iterators (code
);
9084 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9085 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9088 /* The information about FORALL iterator, including FORALL index start, end
9089 and stride. The FORALL index can not appear in start, end or stride. */
9090 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9092 /* Check if any outer FORALL index name is the same as the current
9094 for (i
= 0; i
< nvar
; i
++)
9096 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9098 gfc_error ("An outer FORALL construct already has an index "
9099 "with this name %L", &fa
->var
->where
);
9103 /* Record the current FORALL index. */
9104 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9108 /* No memory leak. */
9109 gcc_assert (nvar
<= total_var
);
9112 /* Resolve the FORALL body. */
9113 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9115 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9116 gfc_resolve_blocks (code
->block
, ns
);
9120 /* Free only the VAR_EXPRs allocated in this frame. */
9121 for (i
= nvar
; i
< tmp
; i
++)
9122 gfc_free_expr (var_expr
[i
]);
9126 /* We are in the outermost FORALL construct. */
9127 gcc_assert (forall_save
== 0);
9129 /* VAR_EXPR is not needed any more. */
9136 /* Resolve a BLOCK construct statement. */
9139 resolve_block_construct (gfc_code
* code
)
9141 /* Resolve the BLOCK's namespace. */
9142 gfc_resolve (code
->ext
.block
.ns
);
9144 /* For an ASSOCIATE block, the associations (and their targets) are already
9145 resolved during resolve_symbol. */
9149 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9153 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9157 for (; b
; b
= b
->block
)
9159 t
= gfc_resolve_expr (b
->expr1
);
9160 if (!gfc_resolve_expr (b
->expr2
))
9166 if (t
&& b
->expr1
!= NULL
9167 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9168 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9175 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9176 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9181 resolve_branch (b
->label1
, b
);
9185 resolve_block_construct (b
);
9189 case EXEC_SELECT_TYPE
:
9193 case EXEC_DO_CONCURRENT
:
9201 case EXEC_OACC_PARALLEL_LOOP
:
9202 case EXEC_OACC_PARALLEL
:
9203 case EXEC_OACC_KERNELS_LOOP
:
9204 case EXEC_OACC_KERNELS
:
9205 case EXEC_OACC_DATA
:
9206 case EXEC_OACC_HOST_DATA
:
9207 case EXEC_OACC_LOOP
:
9208 case EXEC_OACC_UPDATE
:
9209 case EXEC_OACC_WAIT
:
9210 case EXEC_OACC_CACHE
:
9211 case EXEC_OACC_ENTER_DATA
:
9212 case EXEC_OACC_EXIT_DATA
:
9213 case EXEC_OMP_ATOMIC
:
9214 case EXEC_OMP_CRITICAL
:
9215 case EXEC_OMP_DISTRIBUTE
:
9216 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9217 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9218 case EXEC_OMP_DISTRIBUTE_SIMD
:
9220 case EXEC_OMP_DO_SIMD
:
9221 case EXEC_OMP_MASTER
:
9222 case EXEC_OMP_ORDERED
:
9223 case EXEC_OMP_PARALLEL
:
9224 case EXEC_OMP_PARALLEL_DO
:
9225 case EXEC_OMP_PARALLEL_DO_SIMD
:
9226 case EXEC_OMP_PARALLEL_SECTIONS
:
9227 case EXEC_OMP_PARALLEL_WORKSHARE
:
9228 case EXEC_OMP_SECTIONS
:
9230 case EXEC_OMP_SINGLE
:
9231 case EXEC_OMP_TARGET
:
9232 case EXEC_OMP_TARGET_DATA
:
9233 case EXEC_OMP_TARGET_TEAMS
:
9234 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9235 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9236 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9237 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9238 case EXEC_OMP_TARGET_UPDATE
:
9240 case EXEC_OMP_TASKGROUP
:
9241 case EXEC_OMP_TASKWAIT
:
9242 case EXEC_OMP_TASKYIELD
:
9243 case EXEC_OMP_TEAMS
:
9244 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9245 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9246 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9247 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9248 case EXEC_OMP_WORKSHARE
:
9252 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9255 gfc_resolve_code (b
->next
, ns
);
9260 /* Does everything to resolve an ordinary assignment. Returns true
9261 if this is an interface assignment. */
9263 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9272 symbol_attribute attr
;
9274 if (gfc_extend_assign (code
, ns
))
9278 if (code
->op
== EXEC_ASSIGN_CALL
)
9280 lhs
= code
->ext
.actual
->expr
;
9281 rhsptr
= &code
->ext
.actual
->next
->expr
;
9285 gfc_actual_arglist
* args
;
9286 gfc_typebound_proc
* tbp
;
9288 gcc_assert (code
->op
== EXEC_COMPCALL
);
9290 args
= code
->expr1
->value
.compcall
.actual
;
9292 rhsptr
= &args
->next
->expr
;
9294 tbp
= code
->expr1
->value
.compcall
.tbp
;
9295 gcc_assert (!tbp
->is_generic
);
9298 /* Make a temporary rhs when there is a default initializer
9299 and rhs is the same symbol as the lhs. */
9300 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9301 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9302 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9303 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9304 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9313 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9314 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9318 /* Handle the case of a BOZ literal on the RHS. */
9319 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9322 if (warn_surprising
)
9323 gfc_warning (OPT_Wsurprising
,
9324 "BOZ literal at %L is bitwise transferred "
9325 "non-integer symbol %qs", &code
->loc
,
9326 lhs
->symtree
->n
.sym
->name
);
9328 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9330 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9332 if (rc
== ARITH_UNDERFLOW
)
9333 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9334 ". This check can be disabled with the option "
9335 "%<-fno-range-check%>", &rhs
->where
);
9336 else if (rc
== ARITH_OVERFLOW
)
9337 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9338 ". This check can be disabled with the option "
9339 "%<-fno-range-check%>", &rhs
->where
);
9340 else if (rc
== ARITH_NAN
)
9341 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9342 ". This check can be disabled with the option "
9343 "%<-fno-range-check%>", &rhs
->where
);
9348 if (lhs
->ts
.type
== BT_CHARACTER
9349 && warn_character_truncation
)
9351 if (lhs
->ts
.u
.cl
!= NULL
9352 && lhs
->ts
.u
.cl
->length
!= NULL
9353 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9354 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9356 if (rhs
->expr_type
== EXPR_CONSTANT
)
9357 rlen
= rhs
->value
.character
.length
;
9359 else if (rhs
->ts
.u
.cl
!= NULL
9360 && rhs
->ts
.u
.cl
->length
!= NULL
9361 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9362 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9364 if (rlen
&& llen
&& rlen
> llen
)
9365 gfc_warning_now (OPT_Wcharacter_truncation
,
9366 "CHARACTER expression will be truncated "
9367 "in assignment (%d/%d) at %L",
9368 llen
, rlen
, &code
->loc
);
9371 /* Ensure that a vector index expression for the lvalue is evaluated
9372 to a temporary if the lvalue symbol is referenced in it. */
9375 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9376 if (ref
->type
== REF_ARRAY
)
9378 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9379 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9380 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9381 ref
->u
.ar
.start
[n
]))
9383 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9387 if (gfc_pure (NULL
))
9389 if (lhs
->ts
.type
== BT_DERIVED
9390 && lhs
->expr_type
== EXPR_VARIABLE
9391 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9392 && rhs
->expr_type
== EXPR_VARIABLE
9393 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9394 || gfc_is_coindexed (rhs
)))
9397 if (gfc_is_coindexed (rhs
))
9398 gfc_error ("Coindexed expression at %L is assigned to "
9399 "a derived type variable with a POINTER "
9400 "component in a PURE procedure",
9403 gfc_error ("The impure variable at %L is assigned to "
9404 "a derived type variable with a POINTER "
9405 "component in a PURE procedure (12.6)",
9410 /* Fortran 2008, C1283. */
9411 if (gfc_is_coindexed (lhs
))
9413 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9414 "procedure", &rhs
->where
);
9419 if (gfc_implicit_pure (NULL
))
9421 if (lhs
->expr_type
== EXPR_VARIABLE
9422 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9423 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9424 gfc_unset_implicit_pure (NULL
);
9426 if (lhs
->ts
.type
== BT_DERIVED
9427 && lhs
->expr_type
== EXPR_VARIABLE
9428 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9429 && rhs
->expr_type
== EXPR_VARIABLE
9430 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9431 || gfc_is_coindexed (rhs
)))
9432 gfc_unset_implicit_pure (NULL
);
9434 /* Fortran 2008, C1283. */
9435 if (gfc_is_coindexed (lhs
))
9436 gfc_unset_implicit_pure (NULL
);
9439 /* F2008, 7.2.1.2. */
9440 attr
= gfc_expr_attr (lhs
);
9441 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9443 if (attr
.codimension
)
9445 gfc_error ("Assignment to polymorphic coarray at %L is not "
9446 "permitted", &lhs
->where
);
9449 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9450 "polymorphic variable at %L", &lhs
->where
))
9452 if (!flag_realloc_lhs
)
9454 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9455 "requires %<-frealloc-lhs%>", &lhs
->where
);
9459 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9460 "is not yet supported", &lhs
->where
);
9463 else if (lhs
->ts
.type
== BT_CLASS
)
9465 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9466 "assignment at %L - check that there is a matching specific "
9467 "subroutine for '=' operator", &lhs
->where
);
9471 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9473 /* F2008, Section 7.2.1.2. */
9474 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9476 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9477 "component in assignment at %L", &lhs
->where
);
9481 gfc_check_assign (lhs
, rhs
, 1);
9483 /* Assign the 'data' of a class object to a derived type. */
9484 if (lhs
->ts
.type
== BT_DERIVED
9485 && rhs
->ts
.type
== BT_CLASS
)
9486 gfc_add_data_component (rhs
);
9488 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9489 Additionally, insert this code when the RHS is a CAF as we then use the
9490 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9491 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9492 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9494 if (flag_coarray
== GFC_FCOARRAY_LIB
9496 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9497 && code
->expr2
->value
.function
.isym
9498 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9499 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9500 && !gfc_expr_attr (rhs
).allocatable
9501 && !gfc_has_vector_subscript (rhs
))))
9503 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9504 && code
->expr2
->value
.function
.isym
9505 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9506 remove_caf_get_intrinsic (code
->expr2
);
9507 code
->op
= EXEC_CALL
;
9508 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9509 code
->resolved_sym
= code
->symtree
->n
.sym
;
9510 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9511 code
->resolved_sym
->attr
.intrinsic
= 1;
9512 code
->resolved_sym
->attr
.subroutine
= 1;
9513 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9514 gfc_commit_symbol (code
->resolved_sym
);
9515 code
->ext
.actual
= gfc_get_actual_arglist ();
9516 code
->ext
.actual
->expr
= lhs
;
9517 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9518 code
->ext
.actual
->next
->expr
= rhs
;
9527 /* Add a component reference onto an expression. */
9530 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9535 ref
= &((*ref
)->next
);
9536 *ref
= gfc_get_ref ();
9537 (*ref
)->type
= REF_COMPONENT
;
9538 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9539 (*ref
)->u
.c
.component
= c
;
9542 /* Add a full array ref, as necessary. */
9545 gfc_add_full_array_ref (e
, c
->as
);
9546 e
->rank
= c
->as
->rank
;
9551 /* Build an assignment. Keep the argument 'op' for future use, so that
9552 pointer assignments can be made. */
9555 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9556 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9558 gfc_code
*this_code
;
9560 this_code
= gfc_get_code (op
);
9561 this_code
->next
= NULL
;
9562 this_code
->expr1
= gfc_copy_expr (expr1
);
9563 this_code
->expr2
= gfc_copy_expr (expr2
);
9564 this_code
->loc
= loc
;
9567 add_comp_ref (this_code
->expr1
, comp1
);
9568 add_comp_ref (this_code
->expr2
, comp2
);
9575 /* Makes a temporary variable expression based on the characteristics of
9576 a given variable expression. */
9579 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9581 static int serial
= 0;
9582 char name
[GFC_MAX_SYMBOL_LEN
];
9585 gfc_array_ref
*aref
;
9588 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9589 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9590 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9596 /* This function could be expanded to support other expression type
9597 but this is not needed here. */
9598 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9600 /* Obtain the arrayspec for the temporary. */
9603 aref
= gfc_find_array_ref (e
);
9604 if (e
->expr_type
== EXPR_VARIABLE
9605 && e
->symtree
->n
.sym
->as
== aref
->as
)
9609 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9610 if (ref
->type
== REF_COMPONENT
9611 && ref
->u
.c
.component
->as
== aref
->as
)
9619 /* Add the attributes and the arrayspec to the temporary. */
9620 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9621 tmp
->n
.sym
->attr
.function
= 0;
9622 tmp
->n
.sym
->attr
.result
= 0;
9623 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9627 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9630 if (as
->type
== AS_DEFERRED
)
9631 tmp
->n
.sym
->attr
.allocatable
= 1;
9634 tmp
->n
.sym
->attr
.dimension
= 0;
9636 gfc_set_sym_referenced (tmp
->n
.sym
);
9637 gfc_commit_symbol (tmp
->n
.sym
);
9638 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9640 /* Should the lhs be a section, use its array ref for the
9641 temporary expression. */
9642 if (aref
&& aref
->type
!= AR_FULL
)
9644 gfc_free_ref_list (e
->ref
);
9645 e
->ref
= gfc_copy_ref (ref
);
9651 /* Add one line of code to the code chain, making sure that 'head' and
9652 'tail' are appropriately updated. */
9655 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9657 gcc_assert (this_code
);
9659 *head
= *tail
= *this_code
;
9661 *tail
= gfc_append_code (*tail
, *this_code
);
9666 /* Counts the potential number of part array references that would
9667 result from resolution of typebound defined assignments. */
9670 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9673 int c_depth
= 0, t_depth
;
9675 for (c
= derived
->components
; c
; c
= c
->next
)
9677 if ((c
->ts
.type
!= BT_DERIVED
9679 || c
->attr
.allocatable
9680 || c
->attr
.proc_pointer_comp
9681 || c
->attr
.class_pointer
9682 || c
->attr
.proc_pointer
)
9683 && !c
->attr
.defined_assign_comp
)
9686 if (c
->as
&& c_depth
== 0)
9689 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9690 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9695 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9697 return depth
+ c_depth
;
9701 /* Implement 7.2.1.3 of the F08 standard:
9702 "An intrinsic assignment where the variable is of derived type is
9703 performed as if each component of the variable were assigned from the
9704 corresponding component of expr using pointer assignment (7.2.2) for
9705 each pointer component, defined assignment for each nonpointer
9706 nonallocatable component of a type that has a type-bound defined
9707 assignment consistent with the component, intrinsic assignment for
9708 each other nonpointer nonallocatable component, ..."
9710 The pointer assignments are taken care of by the intrinsic
9711 assignment of the structure itself. This function recursively adds
9712 defined assignments where required. The recursion is accomplished
9713 by calling gfc_resolve_code.
9715 When the lhs in a defined assignment has intent INOUT, we need a
9716 temporary for the lhs. In pseudo-code:
9718 ! Only call function lhs once.
9719 if (lhs is not a constant or an variable)
9722 ! Do the intrinsic assignment
9724 ! Now do the defined assignments
9725 do over components with typebound defined assignment [%cmp]
9726 #if one component's assignment procedure is INOUT
9728 #if expr2 non-variable
9734 t1%cmp {defined=} expr2%cmp
9740 expr1%cmp {defined=} expr2%cmp
9744 /* The temporary assignments have to be put on top of the additional
9745 code to avoid the result being changed by the intrinsic assignment.
9747 static int component_assignment_level
= 0;
9748 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9751 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9753 gfc_component
*comp1
, *comp2
;
9754 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9756 int error_count
, depth
;
9758 gfc_get_errors (NULL
, &error_count
);
9760 /* Filter out continuing processing after an error. */
9762 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9763 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9766 /* TODO: Handle more than one part array reference in assignments. */
9767 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9768 (*code
)->expr1
->rank
? 1 : 0);
9771 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
9772 "done because multiple part array references would "
9773 "occur in intermediate expressions.", &(*code
)->loc
);
9777 component_assignment_level
++;
9779 /* Create a temporary so that functions get called only once. */
9780 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9781 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9785 /* Assign the rhs to the temporary. */
9786 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9787 this_code
= build_assignment (EXEC_ASSIGN
,
9788 tmp_expr
, (*code
)->expr2
,
9789 NULL
, NULL
, (*code
)->loc
);
9790 /* Add the code and substitute the rhs expression. */
9791 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9792 gfc_free_expr ((*code
)->expr2
);
9793 (*code
)->expr2
= tmp_expr
;
9796 /* Do the intrinsic assignment. This is not needed if the lhs is one
9797 of the temporaries generated here, since the intrinsic assignment
9798 to the final result already does this. */
9799 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9801 this_code
= build_assignment (EXEC_ASSIGN
,
9802 (*code
)->expr1
, (*code
)->expr2
,
9803 NULL
, NULL
, (*code
)->loc
);
9804 add_code_to_chain (&this_code
, &head
, &tail
);
9807 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9808 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9811 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9815 /* The intrinsic assignment does the right thing for pointers
9816 of all kinds and allocatable components. */
9817 if (comp1
->ts
.type
!= BT_DERIVED
9818 || comp1
->attr
.pointer
9819 || comp1
->attr
.allocatable
9820 || comp1
->attr
.proc_pointer_comp
9821 || comp1
->attr
.class_pointer
9822 || comp1
->attr
.proc_pointer
)
9825 /* Make an assigment for this component. */
9826 this_code
= build_assignment (EXEC_ASSIGN
,
9827 (*code
)->expr1
, (*code
)->expr2
,
9828 comp1
, comp2
, (*code
)->loc
);
9830 /* Convert the assignment if there is a defined assignment for
9831 this type. Otherwise, using the call from gfc_resolve_code,
9832 recurse into its components. */
9833 gfc_resolve_code (this_code
, ns
);
9835 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9837 gfc_formal_arglist
*dummy_args
;
9839 /* Check that there is a typebound defined assignment. If not,
9840 then this must be a module defined assignment. We cannot
9841 use the defined_assign_comp attribute here because it must
9842 be this derived type that has the defined assignment and not
9844 if (!(comp1
->ts
.u
.derived
->f2k_derived
9845 && comp1
->ts
.u
.derived
->f2k_derived
9846 ->tb_op
[INTRINSIC_ASSIGN
]))
9848 gfc_free_statements (this_code
);
9853 /* If the first argument of the subroutine has intent INOUT
9854 a temporary must be generated and used instead. */
9855 rsym
= this_code
->resolved_sym
;
9856 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9858 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9860 gfc_code
*temp_code
;
9863 /* Build the temporary required for the assignment and put
9864 it at the head of the generated code. */
9867 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9868 temp_code
= build_assignment (EXEC_ASSIGN
,
9870 NULL
, NULL
, (*code
)->loc
);
9872 /* For allocatable LHS, check whether it is allocated. Note
9873 that allocatable components with defined assignment are
9874 not yet support. See PR 57696. */
9875 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9879 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9880 block
= gfc_get_code (EXEC_IF
);
9881 block
->block
= gfc_get_code (EXEC_IF
);
9883 = gfc_build_intrinsic_call (ns
,
9884 GFC_ISYM_ALLOCATED
, "allocated",
9885 (*code
)->loc
, 1, e
);
9886 block
->block
->next
= temp_code
;
9889 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9892 /* Replace the first actual arg with the component of the
9894 gfc_free_expr (this_code
->ext
.actual
->expr
);
9895 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9896 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9898 /* If the LHS variable is allocatable and wasn't allocated and
9899 the temporary is allocatable, pointer assign the address of
9900 the freshly allocated LHS to the temporary. */
9901 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9902 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9907 cond
= gfc_get_expr ();
9908 cond
->ts
.type
= BT_LOGICAL
;
9909 cond
->ts
.kind
= gfc_default_logical_kind
;
9910 cond
->expr_type
= EXPR_OP
;
9911 cond
->where
= (*code
)->loc
;
9912 cond
->value
.op
.op
= INTRINSIC_NOT
;
9913 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9914 GFC_ISYM_ALLOCATED
, "allocated",
9915 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9916 block
= gfc_get_code (EXEC_IF
);
9917 block
->block
= gfc_get_code (EXEC_IF
);
9918 block
->block
->expr1
= cond
;
9919 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9921 NULL
, NULL
, (*code
)->loc
);
9922 add_code_to_chain (&block
, &head
, &tail
);
9926 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9928 /* Don't add intrinsic assignments since they are already
9929 effected by the intrinsic assignment of the structure. */
9930 gfc_free_statements (this_code
);
9935 add_code_to_chain (&this_code
, &head
, &tail
);
9939 /* Transfer the value to the final result. */
9940 this_code
= build_assignment (EXEC_ASSIGN
,
9942 comp1
, comp2
, (*code
)->loc
);
9943 add_code_to_chain (&this_code
, &head
, &tail
);
9947 /* Put the temporary assignments at the top of the generated code. */
9948 if (tmp_head
&& component_assignment_level
== 1)
9950 gfc_append_code (tmp_head
, head
);
9952 tmp_head
= tmp_tail
= NULL
;
9955 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9956 // not accidentally deallocated. Hence, nullify t1.
9957 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9958 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9964 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9965 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9966 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9967 block
= gfc_get_code (EXEC_IF
);
9968 block
->block
= gfc_get_code (EXEC_IF
);
9969 block
->block
->expr1
= cond
;
9970 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9971 t1
, gfc_get_null_expr (&(*code
)->loc
),
9972 NULL
, NULL
, (*code
)->loc
);
9973 gfc_append_code (tail
, block
);
9977 /* Now attach the remaining code chain to the input code. Step on
9978 to the end of the new code since resolution is complete. */
9979 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9980 tail
->next
= (*code
)->next
;
9981 /* Overwrite 'code' because this would place the intrinsic assignment
9982 before the temporary for the lhs is created. */
9983 gfc_free_expr ((*code
)->expr1
);
9984 gfc_free_expr ((*code
)->expr2
);
9990 component_assignment_level
--;
9994 /* Given a block of code, recursively resolve everything pointed to by this
9998 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10000 int omp_workshare_save
;
10001 int forall_save
, do_concurrent_save
;
10005 frame
.prev
= cs_base
;
10009 find_reachable_labels (code
);
10011 for (; code
; code
= code
->next
)
10013 frame
.current
= code
;
10014 forall_save
= forall_flag
;
10015 do_concurrent_save
= gfc_do_concurrent_flag
;
10017 if (code
->op
== EXEC_FORALL
)
10020 gfc_resolve_forall (code
, ns
, forall_save
);
10023 else if (code
->block
)
10025 omp_workshare_save
= -1;
10028 case EXEC_OACC_PARALLEL_LOOP
:
10029 case EXEC_OACC_PARALLEL
:
10030 case EXEC_OACC_KERNELS_LOOP
:
10031 case EXEC_OACC_KERNELS
:
10032 case EXEC_OACC_DATA
:
10033 case EXEC_OACC_HOST_DATA
:
10034 case EXEC_OACC_LOOP
:
10035 gfc_resolve_oacc_blocks (code
, ns
);
10037 case EXEC_OMP_PARALLEL_WORKSHARE
:
10038 omp_workshare_save
= omp_workshare_flag
;
10039 omp_workshare_flag
= 1;
10040 gfc_resolve_omp_parallel_blocks (code
, ns
);
10042 case EXEC_OMP_PARALLEL
:
10043 case EXEC_OMP_PARALLEL_DO
:
10044 case EXEC_OMP_PARALLEL_DO_SIMD
:
10045 case EXEC_OMP_PARALLEL_SECTIONS
:
10046 case EXEC_OMP_TARGET_TEAMS
:
10047 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10048 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10049 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10050 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10051 case EXEC_OMP_TASK
:
10052 case EXEC_OMP_TEAMS
:
10053 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10054 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10055 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10056 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10057 omp_workshare_save
= omp_workshare_flag
;
10058 omp_workshare_flag
= 0;
10059 gfc_resolve_omp_parallel_blocks (code
, ns
);
10061 case EXEC_OMP_DISTRIBUTE
:
10062 case EXEC_OMP_DISTRIBUTE_SIMD
:
10064 case EXEC_OMP_DO_SIMD
:
10065 case EXEC_OMP_SIMD
:
10066 gfc_resolve_omp_do_blocks (code
, ns
);
10068 case EXEC_SELECT_TYPE
:
10069 /* Blocks are handled in resolve_select_type because we have
10070 to transform the SELECT TYPE into ASSOCIATE first. */
10072 case EXEC_DO_CONCURRENT
:
10073 gfc_do_concurrent_flag
= 1;
10074 gfc_resolve_blocks (code
->block
, ns
);
10075 gfc_do_concurrent_flag
= 2;
10077 case EXEC_OMP_WORKSHARE
:
10078 omp_workshare_save
= omp_workshare_flag
;
10079 omp_workshare_flag
= 1;
10082 gfc_resolve_blocks (code
->block
, ns
);
10086 if (omp_workshare_save
!= -1)
10087 omp_workshare_flag
= omp_workshare_save
;
10091 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10092 t
= gfc_resolve_expr (code
->expr1
);
10093 forall_flag
= forall_save
;
10094 gfc_do_concurrent_flag
= do_concurrent_save
;
10096 if (!gfc_resolve_expr (code
->expr2
))
10099 if (code
->op
== EXEC_ALLOCATE
10100 && !gfc_resolve_expr (code
->expr3
))
10106 case EXEC_END_BLOCK
:
10107 case EXEC_END_NESTED_BLOCK
:
10111 case EXEC_ERROR_STOP
:
10113 case EXEC_CONTINUE
:
10115 case EXEC_ASSIGN_CALL
:
10118 case EXEC_CRITICAL
:
10119 resolve_critical (code
);
10122 case EXEC_SYNC_ALL
:
10123 case EXEC_SYNC_IMAGES
:
10124 case EXEC_SYNC_MEMORY
:
10125 resolve_sync (code
);
10130 resolve_lock_unlock (code
);
10134 /* Keep track of which entry we are up to. */
10135 current_entry_id
= code
->ext
.entry
->id
;
10139 resolve_where (code
, NULL
);
10143 if (code
->expr1
!= NULL
)
10145 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10146 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10147 "INTEGER variable", &code
->expr1
->where
);
10148 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10149 gfc_error ("Variable %qs has not been assigned a target "
10150 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10151 &code
->expr1
->where
);
10154 resolve_branch (code
->label1
, code
);
10158 if (code
->expr1
!= NULL
10159 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10160 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10161 "INTEGER return specifier", &code
->expr1
->where
);
10164 case EXEC_INIT_ASSIGN
:
10165 case EXEC_END_PROCEDURE
:
10172 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10174 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10175 && code
->expr1
->value
.function
.isym
10176 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10177 remove_caf_get_intrinsic (code
->expr1
);
10179 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10183 if (resolve_ordinary_assign (code
, ns
))
10185 if (code
->op
== EXEC_COMPCALL
)
10191 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10192 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10193 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10194 generate_component_assignments (&code
, ns
);
10198 case EXEC_LABEL_ASSIGN
:
10199 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10200 gfc_error ("Label %d referenced at %L is never defined",
10201 code
->label1
->value
, &code
->label1
->where
);
10203 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10204 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10205 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10206 != gfc_default_integer_kind
10207 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10208 gfc_error ("ASSIGN statement at %L requires a scalar "
10209 "default INTEGER variable", &code
->expr1
->where
);
10212 case EXEC_POINTER_ASSIGN
:
10219 /* This is both a variable definition and pointer assignment
10220 context, so check both of them. For rank remapping, a final
10221 array ref may be present on the LHS and fool gfc_expr_attr
10222 used in gfc_check_vardef_context. Remove it. */
10223 e
= remove_last_array_ref (code
->expr1
);
10224 t
= gfc_check_vardef_context (e
, true, false, false,
10225 _("pointer assignment"));
10227 t
= gfc_check_vardef_context (e
, false, false, false,
10228 _("pointer assignment"));
10233 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10237 case EXEC_ARITHMETIC_IF
:
10239 && code
->expr1
->ts
.type
!= BT_INTEGER
10240 && code
->expr1
->ts
.type
!= BT_REAL
)
10241 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10242 "expression", &code
->expr1
->where
);
10244 resolve_branch (code
->label1
, code
);
10245 resolve_branch (code
->label2
, code
);
10246 resolve_branch (code
->label3
, code
);
10250 if (t
&& code
->expr1
!= NULL
10251 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10252 || code
->expr1
->rank
!= 0))
10253 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10254 &code
->expr1
->where
);
10259 resolve_call (code
);
10262 case EXEC_COMPCALL
:
10264 resolve_typebound_subroutine (code
);
10267 case EXEC_CALL_PPC
:
10268 resolve_ppc_call (code
);
10272 /* Select is complicated. Also, a SELECT construct could be
10273 a transformed computed GOTO. */
10274 resolve_select (code
, false);
10277 case EXEC_SELECT_TYPE
:
10278 resolve_select_type (code
, ns
);
10282 resolve_block_construct (code
);
10286 if (code
->ext
.iterator
!= NULL
)
10288 gfc_iterator
*iter
= code
->ext
.iterator
;
10289 if (gfc_resolve_iterator (iter
, true, false))
10290 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10294 case EXEC_DO_WHILE
:
10295 if (code
->expr1
== NULL
)
10296 gfc_internal_error ("gfc_resolve_code(): No expression on "
10299 && (code
->expr1
->rank
!= 0
10300 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10301 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10302 "a scalar LOGICAL expression", &code
->expr1
->where
);
10305 case EXEC_ALLOCATE
:
10307 resolve_allocate_deallocate (code
, "ALLOCATE");
10311 case EXEC_DEALLOCATE
:
10313 resolve_allocate_deallocate (code
, "DEALLOCATE");
10318 if (!gfc_resolve_open (code
->ext
.open
))
10321 resolve_branch (code
->ext
.open
->err
, code
);
10325 if (!gfc_resolve_close (code
->ext
.close
))
10328 resolve_branch (code
->ext
.close
->err
, code
);
10331 case EXEC_BACKSPACE
:
10335 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10338 resolve_branch (code
->ext
.filepos
->err
, code
);
10342 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10345 resolve_branch (code
->ext
.inquire
->err
, code
);
10348 case EXEC_IOLENGTH
:
10349 gcc_assert (code
->ext
.inquire
!= NULL
);
10350 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10353 resolve_branch (code
->ext
.inquire
->err
, code
);
10357 if (!gfc_resolve_wait (code
->ext
.wait
))
10360 resolve_branch (code
->ext
.wait
->err
, code
);
10361 resolve_branch (code
->ext
.wait
->end
, code
);
10362 resolve_branch (code
->ext
.wait
->eor
, code
);
10367 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10370 resolve_branch (code
->ext
.dt
->err
, code
);
10371 resolve_branch (code
->ext
.dt
->end
, code
);
10372 resolve_branch (code
->ext
.dt
->eor
, code
);
10375 case EXEC_TRANSFER
:
10376 resolve_transfer (code
);
10379 case EXEC_DO_CONCURRENT
:
10381 resolve_forall_iterators (code
->ext
.forall_iterator
);
10383 if (code
->expr1
!= NULL
10384 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10385 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10386 "expression", &code
->expr1
->where
);
10389 case EXEC_OACC_PARALLEL_LOOP
:
10390 case EXEC_OACC_PARALLEL
:
10391 case EXEC_OACC_KERNELS_LOOP
:
10392 case EXEC_OACC_KERNELS
:
10393 case EXEC_OACC_DATA
:
10394 case EXEC_OACC_HOST_DATA
:
10395 case EXEC_OACC_LOOP
:
10396 case EXEC_OACC_UPDATE
:
10397 case EXEC_OACC_WAIT
:
10398 case EXEC_OACC_CACHE
:
10399 case EXEC_OACC_ENTER_DATA
:
10400 case EXEC_OACC_EXIT_DATA
:
10401 gfc_resolve_oacc_directive (code
, ns
);
10404 case EXEC_OMP_ATOMIC
:
10405 case EXEC_OMP_BARRIER
:
10406 case EXEC_OMP_CANCEL
:
10407 case EXEC_OMP_CANCELLATION_POINT
:
10408 case EXEC_OMP_CRITICAL
:
10409 case EXEC_OMP_FLUSH
:
10410 case EXEC_OMP_DISTRIBUTE
:
10411 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10412 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10413 case EXEC_OMP_DISTRIBUTE_SIMD
:
10415 case EXEC_OMP_DO_SIMD
:
10416 case EXEC_OMP_MASTER
:
10417 case EXEC_OMP_ORDERED
:
10418 case EXEC_OMP_SECTIONS
:
10419 case EXEC_OMP_SIMD
:
10420 case EXEC_OMP_SINGLE
:
10421 case EXEC_OMP_TARGET
:
10422 case EXEC_OMP_TARGET_DATA
:
10423 case EXEC_OMP_TARGET_TEAMS
:
10424 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10425 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10426 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10427 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10428 case EXEC_OMP_TARGET_UPDATE
:
10429 case EXEC_OMP_TASK
:
10430 case EXEC_OMP_TASKGROUP
:
10431 case EXEC_OMP_TASKWAIT
:
10432 case EXEC_OMP_TASKYIELD
:
10433 case EXEC_OMP_TEAMS
:
10434 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10435 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10436 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10437 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10438 case EXEC_OMP_WORKSHARE
:
10439 gfc_resolve_omp_directive (code
, ns
);
10442 case EXEC_OMP_PARALLEL
:
10443 case EXEC_OMP_PARALLEL_DO
:
10444 case EXEC_OMP_PARALLEL_DO_SIMD
:
10445 case EXEC_OMP_PARALLEL_SECTIONS
:
10446 case EXEC_OMP_PARALLEL_WORKSHARE
:
10447 omp_workshare_save
= omp_workshare_flag
;
10448 omp_workshare_flag
= 0;
10449 gfc_resolve_omp_directive (code
, ns
);
10450 omp_workshare_flag
= omp_workshare_save
;
10454 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10458 cs_base
= frame
.prev
;
10462 /* Resolve initial values and make sure they are compatible with
10466 resolve_values (gfc_symbol
*sym
)
10470 if (sym
->value
== NULL
)
10473 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10474 t
= resolve_structure_cons (sym
->value
, 1);
10476 t
= gfc_resolve_expr (sym
->value
);
10481 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10485 /* Verify any BIND(C) derived types in the namespace so we can report errors
10486 for them once, rather than for each variable declared of that type. */
10489 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10491 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10492 && derived_sym
->attr
.is_bind_c
== 1)
10493 verify_bind_c_derived_type (derived_sym
);
10499 /* Verify that any binding labels used in a given namespace do not collide
10500 with the names or binding labels of any global symbols. Multiple INTERFACE
10501 for the same procedure are permitted. */
10504 gfc_verify_binding_labels (gfc_symbol
*sym
)
10507 const char *module
;
10509 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10510 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10513 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10516 module
= sym
->module
;
10517 else if (sym
->ns
&& sym
->ns
->proc_name
10518 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10519 module
= sym
->ns
->proc_name
->name
;
10520 else if (sym
->ns
&& sym
->ns
->parent
10521 && sym
->ns
&& sym
->ns
->parent
->proc_name
10522 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10523 module
= sym
->ns
->parent
->proc_name
->name
;
10529 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10532 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10533 gsym
->where
= sym
->declared_at
;
10534 gsym
->sym_name
= sym
->name
;
10535 gsym
->binding_label
= sym
->binding_label
;
10536 gsym
->ns
= sym
->ns
;
10537 gsym
->mod_name
= module
;
10538 if (sym
->attr
.function
)
10539 gsym
->type
= GSYM_FUNCTION
;
10540 else if (sym
->attr
.subroutine
)
10541 gsym
->type
= GSYM_SUBROUTINE
;
10542 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10543 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10547 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10549 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10550 "identifier as entity at %L", sym
->name
,
10551 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10552 /* Clear the binding label to prevent checking multiple times. */
10553 sym
->binding_label
= NULL
;
10556 else if (sym
->attr
.flavor
== FL_VARIABLE
10557 && (strcmp (module
, gsym
->mod_name
) != 0
10558 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10560 /* This can only happen if the variable is defined in a module - if it
10561 isn't the same module, reject it. */
10562 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10563 "the same global identifier as entity at %L from module %s",
10564 sym
->name
, module
, sym
->binding_label
,
10565 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10566 sym
->binding_label
= NULL
;
10568 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10569 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10570 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10571 && sym
!= gsym
->ns
->proc_name
10572 && (module
!= gsym
->mod_name
10573 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10574 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10576 /* Print an error if the procedure is defined multiple times; we have to
10577 exclude references to the same procedure via module association or
10578 multiple checks for the same procedure. */
10579 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10580 "global identifier as entity at %L", sym
->name
,
10581 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10582 sym
->binding_label
= NULL
;
10587 /* Resolve an index expression. */
10590 resolve_index_expr (gfc_expr
*e
)
10592 if (!gfc_resolve_expr (e
))
10595 if (!gfc_simplify_expr (e
, 0))
10598 if (!gfc_specification_expr (e
))
10605 /* Resolve a charlen structure. */
10608 resolve_charlen (gfc_charlen
*cl
)
10611 bool saved_specification_expr
;
10617 saved_specification_expr
= specification_expr
;
10618 specification_expr
= true;
10620 if (cl
->length_from_typespec
)
10622 if (!gfc_resolve_expr (cl
->length
))
10624 specification_expr
= saved_specification_expr
;
10628 if (!gfc_simplify_expr (cl
->length
, 0))
10630 specification_expr
= saved_specification_expr
;
10637 if (!resolve_index_expr (cl
->length
))
10639 specification_expr
= saved_specification_expr
;
10644 /* "If the character length parameter value evaluates to a negative
10645 value, the length of character entities declared is zero." */
10646 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10648 if (warn_surprising
)
10649 gfc_warning_now (OPT_Wsurprising
,
10650 "CHARACTER variable at %L has negative length %d,"
10651 " the length has been set to zero",
10652 &cl
->length
->where
, i
);
10653 gfc_replace_expr (cl
->length
,
10654 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10657 /* Check that the character length is not too large. */
10658 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10659 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10660 && cl
->length
->ts
.type
== BT_INTEGER
10661 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10663 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10664 specification_expr
= saved_specification_expr
;
10668 specification_expr
= saved_specification_expr
;
10673 /* Test for non-constant shape arrays. */
10676 is_non_constant_shape_array (gfc_symbol
*sym
)
10682 not_constant
= false;
10683 if (sym
->as
!= NULL
)
10685 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10686 has not been simplified; parameter array references. Do the
10687 simplification now. */
10688 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10690 e
= sym
->as
->lower
[i
];
10691 if (e
&& (!resolve_index_expr(e
)
10692 || !gfc_is_constant_expr (e
)))
10693 not_constant
= true;
10694 e
= sym
->as
->upper
[i
];
10695 if (e
&& (!resolve_index_expr(e
)
10696 || !gfc_is_constant_expr (e
)))
10697 not_constant
= true;
10700 return not_constant
;
10703 /* Given a symbol and an initialization expression, add code to initialize
10704 the symbol to the function entry. */
10706 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10710 gfc_namespace
*ns
= sym
->ns
;
10712 /* Search for the function namespace if this is a contained
10713 function without an explicit result. */
10714 if (sym
->attr
.function
&& sym
== sym
->result
10715 && sym
->name
!= sym
->ns
->proc_name
->name
)
10717 ns
= ns
->contained
;
10718 for (;ns
; ns
= ns
->sibling
)
10719 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10725 gfc_free_expr (init
);
10729 /* Build an l-value expression for the result. */
10730 lval
= gfc_lval_expr_from_sym (sym
);
10732 /* Add the code at scope entry. */
10733 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10734 init_st
->next
= ns
->code
;
10735 ns
->code
= init_st
;
10737 /* Assign the default initializer to the l-value. */
10738 init_st
->loc
= sym
->declared_at
;
10739 init_st
->expr1
= lval
;
10740 init_st
->expr2
= init
;
10743 /* Assign the default initializer to a derived type variable or result. */
10746 apply_default_init (gfc_symbol
*sym
)
10748 gfc_expr
*init
= NULL
;
10750 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10753 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10754 init
= gfc_default_initializer (&sym
->ts
);
10756 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10759 build_init_assign (sym
, init
);
10760 sym
->attr
.referenced
= 1;
10763 /* Build an initializer for a local integer, real, complex, logical, or
10764 character variable, based on the command line flags finit-local-zero,
10765 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10766 null if the symbol should not have a default initialization. */
10768 build_default_init_expr (gfc_symbol
*sym
)
10771 gfc_expr
*init_expr
;
10774 /* These symbols should never have a default initialization. */
10775 if (sym
->attr
.allocatable
10776 || sym
->attr
.external
10778 || sym
->attr
.pointer
10779 || sym
->attr
.in_equivalence
10780 || sym
->attr
.in_common
10783 || sym
->attr
.cray_pointee
10784 || sym
->attr
.cray_pointer
10788 /* Now we'll try to build an initializer expression. */
10789 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10790 &sym
->declared_at
);
10792 /* We will only initialize integers, reals, complex, logicals, and
10793 characters, and only if the corresponding command-line flags
10794 were set. Otherwise, we free init_expr and return null. */
10795 switch (sym
->ts
.type
)
10798 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10799 mpz_set_si (init_expr
->value
.integer
,
10800 gfc_option
.flag_init_integer_value
);
10803 gfc_free_expr (init_expr
);
10809 switch (flag_init_real
)
10811 case GFC_INIT_REAL_SNAN
:
10812 init_expr
->is_snan
= 1;
10813 /* Fall through. */
10814 case GFC_INIT_REAL_NAN
:
10815 mpfr_set_nan (init_expr
->value
.real
);
10818 case GFC_INIT_REAL_INF
:
10819 mpfr_set_inf (init_expr
->value
.real
, 1);
10822 case GFC_INIT_REAL_NEG_INF
:
10823 mpfr_set_inf (init_expr
->value
.real
, -1);
10826 case GFC_INIT_REAL_ZERO
:
10827 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10831 gfc_free_expr (init_expr
);
10838 switch (flag_init_real
)
10840 case GFC_INIT_REAL_SNAN
:
10841 init_expr
->is_snan
= 1;
10842 /* Fall through. */
10843 case GFC_INIT_REAL_NAN
:
10844 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10845 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10848 case GFC_INIT_REAL_INF
:
10849 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10850 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10853 case GFC_INIT_REAL_NEG_INF
:
10854 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10855 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10858 case GFC_INIT_REAL_ZERO
:
10859 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10863 gfc_free_expr (init_expr
);
10870 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10871 init_expr
->value
.logical
= 0;
10872 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10873 init_expr
->value
.logical
= 1;
10876 gfc_free_expr (init_expr
);
10882 /* For characters, the length must be constant in order to
10883 create a default initializer. */
10884 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10885 && sym
->ts
.u
.cl
->length
10886 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10888 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10889 init_expr
->value
.character
.length
= char_len
;
10890 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10891 for (i
= 0; i
< char_len
; i
++)
10892 init_expr
->value
.character
.string
[i
]
10893 = (unsigned char) gfc_option
.flag_init_character_value
;
10897 gfc_free_expr (init_expr
);
10900 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10901 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
10903 gfc_actual_arglist
*arg
;
10904 init_expr
= gfc_get_expr ();
10905 init_expr
->where
= sym
->declared_at
;
10906 init_expr
->ts
= sym
->ts
;
10907 init_expr
->expr_type
= EXPR_FUNCTION
;
10908 init_expr
->value
.function
.isym
=
10909 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10910 init_expr
->value
.function
.name
= "repeat";
10911 arg
= gfc_get_actual_arglist ();
10912 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10914 arg
->expr
->value
.character
.string
[0]
10915 = gfc_option
.flag_init_character_value
;
10916 arg
->next
= gfc_get_actual_arglist ();
10917 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10918 init_expr
->value
.function
.actual
= arg
;
10923 gfc_free_expr (init_expr
);
10929 /* Add an initialization expression to a local variable. */
10931 apply_default_init_local (gfc_symbol
*sym
)
10933 gfc_expr
*init
= NULL
;
10935 /* The symbol should be a variable or a function return value. */
10936 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10937 || (sym
->attr
.function
&& sym
->result
!= sym
))
10940 /* Try to build the initializer expression. If we can't initialize
10941 this symbol, then init will be NULL. */
10942 init
= build_default_init_expr (sym
);
10946 /* For saved variables, we don't want to add an initializer at function
10947 entry, so we just add a static initializer. Note that automatic variables
10948 are stack allocated even with -fno-automatic; we have also to exclude
10949 result variable, which are also nonstatic. */
10950 if (sym
->attr
.save
|| sym
->ns
->save_all
10951 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
10952 && !sym
->ns
->proc_name
->attr
.recursive
10953 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10955 /* Don't clobber an existing initializer! */
10956 gcc_assert (sym
->value
== NULL
);
10961 build_init_assign (sym
, init
);
10965 /* Resolution of common features of flavors variable and procedure. */
10968 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10970 gfc_array_spec
*as
;
10972 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10973 as
= CLASS_DATA (sym
)->as
;
10977 /* Constraints on deferred shape variable. */
10978 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10980 bool pointer
, allocatable
, dimension
;
10982 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10984 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10985 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10986 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10990 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10991 allocatable
= sym
->attr
.allocatable
;
10992 dimension
= sym
->attr
.dimension
;
10997 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10999 gfc_error ("Allocatable array %qs at %L must have a deferred "
11000 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11003 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11004 "%qs at %L may not be ALLOCATABLE",
11005 sym
->name
, &sym
->declared_at
))
11009 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11011 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11012 "assumed rank", sym
->name
, &sym
->declared_at
);
11018 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11019 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11021 gfc_error ("Array %qs at %L cannot have a deferred shape",
11022 sym
->name
, &sym
->declared_at
);
11027 /* Constraints on polymorphic variables. */
11028 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11031 if (sym
->attr
.class_ok
11032 && !sym
->attr
.select_type_temporary
11033 && !UNLIMITED_POLY (sym
)
11034 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11036 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11037 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11038 &sym
->declared_at
);
11043 /* Assume that use associated symbols were checked in the module ns.
11044 Class-variables that are associate-names are also something special
11045 and excepted from the test. */
11046 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11048 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11049 "or pointer", sym
->name
, &sym
->declared_at
);
11058 /* Additional checks for symbols with flavor variable and derived
11059 type. To be called from resolve_fl_variable. */
11062 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11064 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11066 /* Check to see if a derived type is blocked from being host
11067 associated by the presence of another class I symbol in the same
11068 namespace. 14.6.1.3 of the standard and the discussion on
11069 comp.lang.fortran. */
11070 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11071 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11074 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11075 if (s
&& s
->attr
.generic
)
11076 s
= gfc_find_dt_in_generic (s
);
11077 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11079 gfc_error ("The type %qs cannot be host associated at %L "
11080 "because it is blocked by an incompatible object "
11081 "of the same name declared at %L",
11082 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11088 /* 4th constraint in section 11.3: "If an object of a type for which
11089 component-initialization is specified (R429) appears in the
11090 specification-part of a module and does not have the ALLOCATABLE
11091 or POINTER attribute, the object shall have the SAVE attribute."
11093 The check for initializers is performed with
11094 gfc_has_default_initializer because gfc_default_initializer generates
11095 a hidden default for allocatable components. */
11096 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11097 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11098 && !sym
->ns
->save_all
&& !sym
->attr
.save
11099 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11100 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11101 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11102 "%qs at %L, needed due to the default "
11103 "initialization", sym
->name
, &sym
->declared_at
))
11106 /* Assign default initializer. */
11107 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11108 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11110 sym
->value
= gfc_default_initializer (&sym
->ts
);
11117 /* Resolve symbols with flavor variable. */
11120 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11122 int no_init_flag
, automatic_flag
;
11124 const char *auto_save_msg
;
11125 bool saved_specification_expr
;
11127 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11130 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11133 /* Set this flag to check that variables are parameters of all entries.
11134 This check is effected by the call to gfc_resolve_expr through
11135 is_non_constant_shape_array. */
11136 saved_specification_expr
= specification_expr
;
11137 specification_expr
= true;
11139 if (sym
->ns
->proc_name
11140 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11141 || sym
->ns
->proc_name
->attr
.is_main_program
)
11142 && !sym
->attr
.use_assoc
11143 && !sym
->attr
.allocatable
11144 && !sym
->attr
.pointer
11145 && is_non_constant_shape_array (sym
))
11147 /* The shape of a main program or module array needs to be
11149 gfc_error ("The module or main program array %qs at %L must "
11150 "have constant shape", sym
->name
, &sym
->declared_at
);
11151 specification_expr
= saved_specification_expr
;
11155 /* Constraints on deferred type parameter. */
11156 if (sym
->ts
.deferred
11157 && !(sym
->attr
.pointer
11158 || sym
->attr
.allocatable
11159 || sym
->attr
.omp_udr_artificial_var
))
11161 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11162 "requires either the pointer or allocatable attribute",
11163 sym
->name
, &sym
->declared_at
);
11164 specification_expr
= saved_specification_expr
;
11168 if (sym
->ts
.type
== BT_CHARACTER
)
11170 /* Make sure that character string variables with assumed length are
11171 dummy arguments. */
11172 e
= sym
->ts
.u
.cl
->length
;
11173 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11174 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11175 && !sym
->attr
.omp_udr_artificial_var
)
11177 gfc_error ("Entity with assumed character length at %L must be a "
11178 "dummy argument or a PARAMETER", &sym
->declared_at
);
11179 specification_expr
= saved_specification_expr
;
11183 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11185 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11186 specification_expr
= saved_specification_expr
;
11190 if (!gfc_is_constant_expr (e
)
11191 && !(e
->expr_type
== EXPR_VARIABLE
11192 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11194 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11195 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11196 || sym
->ns
->proc_name
->attr
.is_main_program
))
11198 gfc_error ("%qs at %L must have constant character length "
11199 "in this context", sym
->name
, &sym
->declared_at
);
11200 specification_expr
= saved_specification_expr
;
11203 if (sym
->attr
.in_common
)
11205 gfc_error ("COMMON variable %qs at %L must have constant "
11206 "character length", sym
->name
, &sym
->declared_at
);
11207 specification_expr
= saved_specification_expr
;
11213 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11214 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11216 /* Determine if the symbol may not have an initializer. */
11217 no_init_flag
= automatic_flag
= 0;
11218 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11219 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11221 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11222 && is_non_constant_shape_array (sym
))
11224 no_init_flag
= automatic_flag
= 1;
11226 /* Also, they must not have the SAVE attribute.
11227 SAVE_IMPLICIT is checked below. */
11228 if (sym
->as
&& sym
->attr
.codimension
)
11230 int corank
= sym
->as
->corank
;
11231 sym
->as
->corank
= 0;
11232 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11233 sym
->as
->corank
= corank
;
11235 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11237 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11238 specification_expr
= saved_specification_expr
;
11243 /* Ensure that any initializer is simplified. */
11245 gfc_simplify_expr (sym
->value
, 1);
11247 /* Reject illegal initializers. */
11248 if (!sym
->mark
&& sym
->value
)
11250 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11251 && CLASS_DATA (sym
)->attr
.allocatable
))
11252 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11253 sym
->name
, &sym
->declared_at
);
11254 else if (sym
->attr
.external
)
11255 gfc_error ("External %qs at %L cannot have an initializer",
11256 sym
->name
, &sym
->declared_at
);
11257 else if (sym
->attr
.dummy
11258 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11259 gfc_error ("Dummy %qs at %L cannot have an initializer",
11260 sym
->name
, &sym
->declared_at
);
11261 else if (sym
->attr
.intrinsic
)
11262 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11263 sym
->name
, &sym
->declared_at
);
11264 else if (sym
->attr
.result
)
11265 gfc_error ("Function result %qs at %L cannot have an initializer",
11266 sym
->name
, &sym
->declared_at
);
11267 else if (automatic_flag
)
11268 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11269 sym
->name
, &sym
->declared_at
);
11271 goto no_init_error
;
11272 specification_expr
= saved_specification_expr
;
11277 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11279 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11280 specification_expr
= saved_specification_expr
;
11284 specification_expr
= saved_specification_expr
;
11289 /* Resolve a procedure. */
11292 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11294 gfc_formal_arglist
*arg
;
11296 if (sym
->attr
.function
11297 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11300 if (sym
->ts
.type
== BT_CHARACTER
)
11302 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11304 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11305 && !resolve_charlen (cl
))
11308 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11309 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11311 gfc_error ("Character-valued statement function %qs at %L must "
11312 "have constant length", sym
->name
, &sym
->declared_at
);
11317 /* Ensure that derived type for are not of a private type. Internal
11318 module procedures are excluded by 2.2.3.3 - i.e., they are not
11319 externally accessible and can access all the objects accessible in
11321 if (!(sym
->ns
->parent
11322 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11323 && gfc_check_symbol_access (sym
))
11325 gfc_interface
*iface
;
11327 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11330 && arg
->sym
->ts
.type
== BT_DERIVED
11331 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11332 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11333 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11334 "and cannot be a dummy argument"
11335 " of %qs, which is PUBLIC at %L",
11336 arg
->sym
->name
, sym
->name
,
11337 &sym
->declared_at
))
11339 /* Stop this message from recurring. */
11340 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11345 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11346 PRIVATE to the containing module. */
11347 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11349 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11352 && arg
->sym
->ts
.type
== BT_DERIVED
11353 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11354 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11355 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11356 "PUBLIC interface %qs at %L "
11357 "takes dummy arguments of %qs which "
11358 "is PRIVATE", iface
->sym
->name
,
11359 sym
->name
, &iface
->sym
->declared_at
,
11360 gfc_typename(&arg
->sym
->ts
)))
11362 /* Stop this message from recurring. */
11363 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11370 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11371 && !sym
->attr
.proc_pointer
)
11373 gfc_error ("Function %qs at %L cannot have an initializer",
11374 sym
->name
, &sym
->declared_at
);
11378 /* An external symbol may not have an initializer because it is taken to be
11379 a procedure. Exception: Procedure Pointers. */
11380 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11382 gfc_error ("External object %qs at %L may not have an initializer",
11383 sym
->name
, &sym
->declared_at
);
11387 /* An elemental function is required to return a scalar 12.7.1 */
11388 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11390 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11391 "result", sym
->name
, &sym
->declared_at
);
11392 /* Reset so that the error only occurs once. */
11393 sym
->attr
.elemental
= 0;
11397 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11398 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11400 gfc_error ("Statement function %qs at %L may not have pointer or "
11401 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11405 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11406 char-len-param shall not be array-valued, pointer-valued, recursive
11407 or pure. ....snip... A character value of * may only be used in the
11408 following ways: (i) Dummy arg of procedure - dummy associates with
11409 actual length; (ii) To declare a named constant; or (iii) External
11410 function - but length must be declared in calling scoping unit. */
11411 if (sym
->attr
.function
11412 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11413 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11415 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11416 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11418 if (sym
->as
&& sym
->as
->rank
)
11419 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11420 "array-valued", sym
->name
, &sym
->declared_at
);
11422 if (sym
->attr
.pointer
)
11423 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11424 "pointer-valued", sym
->name
, &sym
->declared_at
);
11426 if (sym
->attr
.pure
)
11427 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11428 "pure", sym
->name
, &sym
->declared_at
);
11430 if (sym
->attr
.recursive
)
11431 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11432 "recursive", sym
->name
, &sym
->declared_at
);
11437 /* Appendix B.2 of the standard. Contained functions give an
11438 error anyway. Deferred character length is an F2003 feature.
11439 Don't warn on intrinsic conversion functions, which start
11440 with two underscores. */
11441 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11442 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11443 gfc_notify_std (GFC_STD_F95_OBS
,
11444 "CHARACTER(*) function %qs at %L",
11445 sym
->name
, &sym
->declared_at
);
11448 /* F2008, C1218. */
11449 if (sym
->attr
.elemental
)
11451 if (sym
->attr
.proc_pointer
)
11453 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11454 sym
->name
, &sym
->declared_at
);
11457 if (sym
->attr
.dummy
)
11459 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11460 sym
->name
, &sym
->declared_at
);
11465 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11467 gfc_formal_arglist
*curr_arg
;
11468 int has_non_interop_arg
= 0;
11470 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11471 sym
->common_block
))
11473 /* Clear these to prevent looking at them again if there was an
11475 sym
->attr
.is_bind_c
= 0;
11476 sym
->attr
.is_c_interop
= 0;
11477 sym
->ts
.is_c_interop
= 0;
11481 /* So far, no errors have been found. */
11482 sym
->attr
.is_c_interop
= 1;
11483 sym
->ts
.is_c_interop
= 1;
11486 curr_arg
= gfc_sym_get_dummy_args (sym
);
11487 while (curr_arg
!= NULL
)
11489 /* Skip implicitly typed dummy args here. */
11490 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11491 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11492 /* If something is found to fail, record the fact so we
11493 can mark the symbol for the procedure as not being
11494 BIND(C) to try and prevent multiple errors being
11496 has_non_interop_arg
= 1;
11498 curr_arg
= curr_arg
->next
;
11501 /* See if any of the arguments were not interoperable and if so, clear
11502 the procedure symbol to prevent duplicate error messages. */
11503 if (has_non_interop_arg
!= 0)
11505 sym
->attr
.is_c_interop
= 0;
11506 sym
->ts
.is_c_interop
= 0;
11507 sym
->attr
.is_bind_c
= 0;
11511 if (!sym
->attr
.proc_pointer
)
11513 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11515 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11516 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11519 if (sym
->attr
.intent
)
11521 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11522 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11525 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11527 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11528 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11531 if (sym
->attr
.external
&& sym
->attr
.function
11532 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11533 || sym
->attr
.contained
))
11535 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11536 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11539 if (strcmp ("ppr@", sym
->name
) == 0)
11541 gfc_error ("Procedure pointer result %qs at %L "
11542 "is missing the pointer attribute",
11543 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11548 /* Assume that a procedure whose body is not known has references
11549 to external arrays. */
11550 if (sym
->attr
.if_source
!= IFSRC_DECL
)
11551 sym
->attr
.array_outer_dependency
= 1;
11557 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11558 been defined and we now know their defined arguments, check that they fulfill
11559 the requirements of the standard for procedures used as finalizers. */
11562 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11564 gfc_finalizer
* list
;
11565 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11566 bool result
= true;
11567 bool seen_scalar
= false;
11570 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11573 gfc_resolve_finalizers (parent
, finalizable
);
11575 /* Return early when not finalizable. Additionally, ensure that derived-type
11576 components have a their finalizables resolved. */
11577 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11579 bool has_final
= false;
11580 for (c
= derived
->components
; c
; c
= c
->next
)
11581 if (c
->ts
.type
== BT_DERIVED
11582 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11584 bool has_final2
= false;
11585 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11586 return false; /* Error. */
11587 has_final
= has_final
|| has_final2
;
11592 *finalizable
= false;
11597 /* Walk over the list of finalizer-procedures, check them, and if any one
11598 does not fit in with the standard's definition, print an error and remove
11599 it from the list. */
11600 prev_link
= &derived
->f2k_derived
->finalizers
;
11601 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11603 gfc_formal_arglist
*dummy_args
;
11608 /* Skip this finalizer if we already resolved it. */
11609 if (list
->proc_tree
)
11611 prev_link
= &(list
->next
);
11615 /* Check this exists and is a SUBROUTINE. */
11616 if (!list
->proc_sym
->attr
.subroutine
)
11618 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
11619 list
->proc_sym
->name
, &list
->where
);
11623 /* We should have exactly one argument. */
11624 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11625 if (!dummy_args
|| dummy_args
->next
)
11627 gfc_error ("FINAL procedure at %L must have exactly one argument",
11631 arg
= dummy_args
->sym
;
11633 /* This argument must be of our type. */
11634 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11636 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
11637 &arg
->declared_at
, derived
->name
);
11641 /* It must neither be a pointer nor allocatable nor optional. */
11642 if (arg
->attr
.pointer
)
11644 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11645 &arg
->declared_at
);
11648 if (arg
->attr
.allocatable
)
11650 gfc_error ("Argument of FINAL procedure at %L must not be"
11651 " ALLOCATABLE", &arg
->declared_at
);
11654 if (arg
->attr
.optional
)
11656 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11657 &arg
->declared_at
);
11661 /* It must not be INTENT(OUT). */
11662 if (arg
->attr
.intent
== INTENT_OUT
)
11664 gfc_error ("Argument of FINAL procedure at %L must not be"
11665 " INTENT(OUT)", &arg
->declared_at
);
11669 /* Warn if the procedure is non-scalar and not assumed shape. */
11670 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11671 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11672 gfc_warning (OPT_Wsurprising
,
11673 "Non-scalar FINAL procedure at %L should have assumed"
11674 " shape argument", &arg
->declared_at
);
11676 /* Check that it does not match in kind and rank with a FINAL procedure
11677 defined earlier. To really loop over the *earlier* declarations,
11678 we need to walk the tail of the list as new ones were pushed at the
11680 /* TODO: Handle kind parameters once they are implemented. */
11681 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11682 for (i
= list
->next
; i
; i
= i
->next
)
11684 gfc_formal_arglist
*dummy_args
;
11686 /* Argument list might be empty; that is an error signalled earlier,
11687 but we nevertheless continued resolving. */
11688 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11691 gfc_symbol
* i_arg
= dummy_args
->sym
;
11692 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11693 if (i_rank
== my_rank
)
11695 gfc_error ("FINAL procedure %qs declared at %L has the same"
11696 " rank (%d) as %qs",
11697 list
->proc_sym
->name
, &list
->where
, my_rank
,
11698 i
->proc_sym
->name
);
11704 /* Is this the/a scalar finalizer procedure? */
11705 if (!arg
->as
|| arg
->as
->rank
== 0)
11706 seen_scalar
= true;
11708 /* Find the symtree for this procedure. */
11709 gcc_assert (!list
->proc_tree
);
11710 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11712 prev_link
= &list
->next
;
11715 /* Remove wrong nodes immediately from the list so we don't risk any
11716 troubles in the future when they might fail later expectations. */
11719 *prev_link
= list
->next
;
11720 gfc_free_finalizer (i
);
11724 if (result
== false)
11727 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11728 were nodes in the list, must have been for arrays. It is surely a good
11729 idea to have a scalar version there if there's something to finalize. */
11730 if (warn_surprising
&& result
&& !seen_scalar
)
11731 gfc_warning (OPT_Wsurprising
,
11732 "Only array FINAL procedures declared for derived type %qs"
11733 " defined at %L, suggest also scalar one",
11734 derived
->name
, &derived
->declared_at
);
11736 vtab
= gfc_find_derived_vtab (derived
);
11737 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11738 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11741 *finalizable
= true;
11747 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11750 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11751 const char* generic_name
, locus where
)
11753 gfc_symbol
*sym1
, *sym2
;
11754 const char *pass1
, *pass2
;
11755 gfc_formal_arglist
*dummy_args
;
11757 gcc_assert (t1
->specific
&& t2
->specific
);
11758 gcc_assert (!t1
->specific
->is_generic
);
11759 gcc_assert (!t2
->specific
->is_generic
);
11760 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11762 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11763 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11768 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11769 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11770 || sym1
->attr
.function
!= sym2
->attr
.function
)
11772 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
11773 " GENERIC %qs at %L",
11774 sym1
->name
, sym2
->name
, generic_name
, &where
);
11778 /* Determine PASS arguments. */
11779 if (t1
->specific
->nopass
)
11781 else if (t1
->specific
->pass_arg
)
11782 pass1
= t1
->specific
->pass_arg
;
11785 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11787 pass1
= dummy_args
->sym
->name
;
11791 if (t2
->specific
->nopass
)
11793 else if (t2
->specific
->pass_arg
)
11794 pass2
= t2
->specific
->pass_arg
;
11797 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11799 pass2
= dummy_args
->sym
->name
;
11804 /* Compare the interfaces. */
11805 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11806 NULL
, 0, pass1
, pass2
))
11808 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
11809 sym1
->name
, sym2
->name
, generic_name
, &where
);
11817 /* Worker function for resolving a generic procedure binding; this is used to
11818 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11820 The difference between those cases is finding possible inherited bindings
11821 that are overridden, as one has to look for them in tb_sym_root,
11822 tb_uop_root or tb_op, respectively. Thus the caller must already find
11823 the super-type and set p->overridden correctly. */
11826 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11827 gfc_typebound_proc
* p
, const char* name
)
11829 gfc_tbp_generic
* target
;
11830 gfc_symtree
* first_target
;
11831 gfc_symtree
* inherited
;
11833 gcc_assert (p
&& p
->is_generic
);
11835 /* Try to find the specific bindings for the symtrees in our target-list. */
11836 gcc_assert (p
->u
.generic
);
11837 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11838 if (!target
->specific
)
11840 gfc_typebound_proc
* overridden_tbp
;
11841 gfc_tbp_generic
* g
;
11842 const char* target_name
;
11844 target_name
= target
->specific_st
->name
;
11846 /* Defined for this type directly. */
11847 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11849 target
->specific
= target
->specific_st
->n
.tb
;
11850 goto specific_found
;
11853 /* Look for an inherited specific binding. */
11856 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11861 gcc_assert (inherited
->n
.tb
);
11862 target
->specific
= inherited
->n
.tb
;
11863 goto specific_found
;
11867 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
11868 " at %L", target_name
, name
, &p
->where
);
11871 /* Once we've found the specific binding, check it is not ambiguous with
11872 other specifics already found or inherited for the same GENERIC. */
11874 gcc_assert (target
->specific
);
11876 /* This must really be a specific binding! */
11877 if (target
->specific
->is_generic
)
11879 gfc_error ("GENERIC %qs at %L must target a specific binding,"
11880 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
11884 /* Check those already resolved on this type directly. */
11885 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11886 if (g
!= target
&& g
->specific
11887 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11890 /* Check for ambiguity with inherited specific targets. */
11891 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11892 overridden_tbp
= overridden_tbp
->overridden
)
11893 if (overridden_tbp
->is_generic
)
11895 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11897 gcc_assert (g
->specific
);
11898 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11904 /* If we attempt to "overwrite" a specific binding, this is an error. */
11905 if (p
->overridden
&& !p
->overridden
->is_generic
)
11907 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
11908 " the same name", name
, &p
->where
);
11912 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11913 all must have the same attributes here. */
11914 first_target
= p
->u
.generic
->specific
->u
.specific
;
11915 gcc_assert (first_target
);
11916 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11917 p
->function
= first_target
->n
.sym
->attr
.function
;
11923 /* Resolve a GENERIC procedure binding for a derived type. */
11926 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11928 gfc_symbol
* super_type
;
11930 /* Find the overridden binding if any. */
11931 st
->n
.tb
->overridden
= NULL
;
11932 super_type
= gfc_get_derived_super_type (derived
);
11935 gfc_symtree
* overridden
;
11936 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11939 if (overridden
&& overridden
->n
.tb
)
11940 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11943 /* Resolve using worker function. */
11944 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11948 /* Retrieve the target-procedure of an operator binding and do some checks in
11949 common for intrinsic and user-defined type-bound operators. */
11952 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11954 gfc_symbol
* target_proc
;
11956 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11957 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11958 gcc_assert (target_proc
);
11960 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11961 if (target
->specific
->nopass
)
11963 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11967 return target_proc
;
11971 /* Resolve a type-bound intrinsic operator. */
11974 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11975 gfc_typebound_proc
* p
)
11977 gfc_symbol
* super_type
;
11978 gfc_tbp_generic
* target
;
11980 /* If there's already an error here, do nothing (but don't fail again). */
11984 /* Operators should always be GENERIC bindings. */
11985 gcc_assert (p
->is_generic
);
11987 /* Look for an overridden binding. */
11988 super_type
= gfc_get_derived_super_type (derived
);
11989 if (super_type
&& super_type
->f2k_derived
)
11990 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11993 p
->overridden
= NULL
;
11995 /* Resolve general GENERIC properties using worker function. */
11996 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11999 /* Check the targets to be procedures of correct interface. */
12000 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12002 gfc_symbol
* target_proc
;
12004 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12008 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12011 /* Add target to non-typebound operator list. */
12012 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12013 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12015 gfc_interface
*head
, *intr
;
12016 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
12018 head
= derived
->ns
->op
[op
];
12019 intr
= gfc_get_interface ();
12020 intr
->sym
= target_proc
;
12021 intr
->where
= p
->where
;
12023 derived
->ns
->op
[op
] = intr
;
12035 /* Resolve a type-bound user operator (tree-walker callback). */
12037 static gfc_symbol
* resolve_bindings_derived
;
12038 static bool resolve_bindings_result
;
12040 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12043 resolve_typebound_user_op (gfc_symtree
* stree
)
12045 gfc_symbol
* super_type
;
12046 gfc_tbp_generic
* target
;
12048 gcc_assert (stree
&& stree
->n
.tb
);
12050 if (stree
->n
.tb
->error
)
12053 /* Operators should always be GENERIC bindings. */
12054 gcc_assert (stree
->n
.tb
->is_generic
);
12056 /* Find overridden procedure, if any. */
12057 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12058 if (super_type
&& super_type
->f2k_derived
)
12060 gfc_symtree
* overridden
;
12061 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12062 stree
->name
, true, NULL
);
12064 if (overridden
&& overridden
->n
.tb
)
12065 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12068 stree
->n
.tb
->overridden
= NULL
;
12070 /* Resolve basically using worker function. */
12071 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12074 /* Check the targets to be functions of correct interface. */
12075 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12077 gfc_symbol
* target_proc
;
12079 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12083 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12090 resolve_bindings_result
= false;
12091 stree
->n
.tb
->error
= 1;
12095 /* Resolve the type-bound procedures for a derived type. */
12098 resolve_typebound_procedure (gfc_symtree
* stree
)
12102 gfc_symbol
* me_arg
;
12103 gfc_symbol
* super_type
;
12104 gfc_component
* comp
;
12106 gcc_assert (stree
);
12108 /* Undefined specific symbol from GENERIC target definition. */
12112 if (stree
->n
.tb
->error
)
12115 /* If this is a GENERIC binding, use that routine. */
12116 if (stree
->n
.tb
->is_generic
)
12118 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12123 /* Get the target-procedure to check it. */
12124 gcc_assert (!stree
->n
.tb
->is_generic
);
12125 gcc_assert (stree
->n
.tb
->u
.specific
);
12126 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12127 where
= stree
->n
.tb
->where
;
12129 /* Default access should already be resolved from the parser. */
12130 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12132 if (stree
->n
.tb
->deferred
)
12134 if (!check_proc_interface (proc
, &where
))
12139 /* Check for F08:C465. */
12140 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12141 || (proc
->attr
.proc
!= PROC_MODULE
12142 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12143 || proc
->attr
.abstract
)
12145 gfc_error ("%qs must be a module procedure or an external procedure with"
12146 " an explicit interface at %L", proc
->name
, &where
);
12151 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12152 stree
->n
.tb
->function
= proc
->attr
.function
;
12154 /* Find the super-type of the current derived type. We could do this once and
12155 store in a global if speed is needed, but as long as not I believe this is
12156 more readable and clearer. */
12157 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12159 /* If PASS, resolve and check arguments if not already resolved / loaded
12160 from a .mod file. */
12161 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12163 gfc_formal_arglist
*dummy_args
;
12165 dummy_args
= gfc_sym_get_dummy_args (proc
);
12166 if (stree
->n
.tb
->pass_arg
)
12168 gfc_formal_arglist
*i
;
12170 /* If an explicit passing argument name is given, walk the arg-list
12171 and look for it. */
12174 stree
->n
.tb
->pass_arg_num
= 1;
12175 for (i
= dummy_args
; i
; i
= i
->next
)
12177 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12182 ++stree
->n
.tb
->pass_arg_num
;
12187 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12189 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12190 stree
->n
.tb
->pass_arg
);
12196 /* Otherwise, take the first one; there should in fact be at least
12198 stree
->n
.tb
->pass_arg_num
= 1;
12201 gfc_error ("Procedure %qs with PASS at %L must have at"
12202 " least one argument", proc
->name
, &where
);
12205 me_arg
= dummy_args
->sym
;
12208 /* Now check that the argument-type matches and the passed-object
12209 dummy argument is generally fine. */
12211 gcc_assert (me_arg
);
12213 if (me_arg
->ts
.type
!= BT_CLASS
)
12215 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12216 " at %L", proc
->name
, &where
);
12220 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12221 != resolve_bindings_derived
)
12223 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12224 " the derived-type %qs", me_arg
->name
, proc
->name
,
12225 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12229 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12230 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12232 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12233 " scalar", proc
->name
, &where
);
12236 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12238 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12239 " be ALLOCATABLE", proc
->name
, &where
);
12242 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12244 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12245 " be POINTER", proc
->name
, &where
);
12250 /* If we are extending some type, check that we don't override a procedure
12251 flagged NON_OVERRIDABLE. */
12252 stree
->n
.tb
->overridden
= NULL
;
12255 gfc_symtree
* overridden
;
12256 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12257 stree
->name
, true, NULL
);
12261 if (overridden
->n
.tb
)
12262 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12264 if (!gfc_check_typebound_override (stree
, overridden
))
12269 /* See if there's a name collision with a component directly in this type. */
12270 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12271 if (!strcmp (comp
->name
, stree
->name
))
12273 gfc_error ("Procedure %qs at %L has the same name as a component of"
12275 stree
->name
, &where
, resolve_bindings_derived
->name
);
12279 /* Try to find a name collision with an inherited component. */
12280 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12282 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12283 " component of %qs",
12284 stree
->name
, &where
, resolve_bindings_derived
->name
);
12288 stree
->n
.tb
->error
= 0;
12292 resolve_bindings_result
= false;
12293 stree
->n
.tb
->error
= 1;
12298 resolve_typebound_procedures (gfc_symbol
* derived
)
12301 gfc_symbol
* super_type
;
12303 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12306 super_type
= gfc_get_derived_super_type (derived
);
12308 resolve_symbol (super_type
);
12310 resolve_bindings_derived
= derived
;
12311 resolve_bindings_result
= true;
12313 if (derived
->f2k_derived
->tb_sym_root
)
12314 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12315 &resolve_typebound_procedure
);
12317 if (derived
->f2k_derived
->tb_uop_root
)
12318 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12319 &resolve_typebound_user_op
);
12321 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12323 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12324 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12325 (gfc_intrinsic_op
)op
, p
))
12326 resolve_bindings_result
= false;
12329 return resolve_bindings_result
;
12333 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12334 to give all identical derived types the same backend_decl. */
12336 add_dt_to_dt_list (gfc_symbol
*derived
)
12338 gfc_dt_list
*dt_list
;
12340 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12341 if (derived
== dt_list
->derived
)
12344 dt_list
= gfc_get_dt_list ();
12345 dt_list
->next
= gfc_derived_types
;
12346 dt_list
->derived
= derived
;
12347 gfc_derived_types
= dt_list
;
12351 /* Ensure that a derived-type is really not abstract, meaning that every
12352 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12355 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12360 if (!ensure_not_abstract_walker (sub
, st
->left
))
12362 if (!ensure_not_abstract_walker (sub
, st
->right
))
12365 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12367 gfc_symtree
* overriding
;
12368 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12371 gcc_assert (overriding
->n
.tb
);
12372 if (overriding
->n
.tb
->deferred
)
12374 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12375 " %qs is DEFERRED and not overridden",
12376 sub
->name
, &sub
->declared_at
, st
->name
);
12385 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12387 /* The algorithm used here is to recursively travel up the ancestry of sub
12388 and for each ancestor-type, check all bindings. If any of them is
12389 DEFERRED, look it up starting from sub and see if the found (overriding)
12390 binding is not DEFERRED.
12391 This is not the most efficient way to do this, but it should be ok and is
12392 clearer than something sophisticated. */
12394 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12396 if (!ancestor
->attr
.abstract
)
12399 /* Walk bindings of this ancestor. */
12400 if (ancestor
->f2k_derived
)
12403 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12408 /* Find next ancestor type and recurse on it. */
12409 ancestor
= gfc_get_derived_super_type (ancestor
);
12411 return ensure_not_abstract (sub
, ancestor
);
12417 /* This check for typebound defined assignments is done recursively
12418 since the order in which derived types are resolved is not always in
12419 order of the declarations. */
12422 check_defined_assignments (gfc_symbol
*derived
)
12426 for (c
= derived
->components
; c
; c
= c
->next
)
12428 if (c
->ts
.type
!= BT_DERIVED
12430 || c
->attr
.allocatable
12431 || c
->attr
.proc_pointer_comp
12432 || c
->attr
.class_pointer
12433 || c
->attr
.proc_pointer
)
12436 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12437 || (c
->ts
.u
.derived
->f2k_derived
12438 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12440 derived
->attr
.defined_assign_comp
= 1;
12444 check_defined_assignments (c
->ts
.u
.derived
);
12445 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12447 derived
->attr
.defined_assign_comp
= 1;
12454 /* Resolve the components of a derived type. This does not have to wait until
12455 resolution stage, but can be done as soon as the dt declaration has been
12459 resolve_fl_derived0 (gfc_symbol
*sym
)
12461 gfc_symbol
* super_type
;
12464 if (sym
->attr
.unlimited_polymorphic
)
12467 super_type
= gfc_get_derived_super_type (sym
);
12470 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12472 gfc_error ("As extending type %qs at %L has a coarray component, "
12473 "parent type %qs shall also have one", sym
->name
,
12474 &sym
->declared_at
, super_type
->name
);
12478 /* Ensure the extended type gets resolved before we do. */
12479 if (super_type
&& !resolve_fl_derived0 (super_type
))
12482 /* An ABSTRACT type must be extensible. */
12483 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12485 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12486 sym
->name
, &sym
->declared_at
);
12490 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12493 bool success
= true;
12495 for ( ; c
!= NULL
; c
= c
->next
)
12497 if (c
->attr
.artificial
)
12501 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12502 && c
->attr
.codimension
12503 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12505 gfc_error ("Coarray component %qs at %L must be allocatable with "
12506 "deferred shape", c
->name
, &c
->loc
);
12512 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12513 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12515 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12516 "shall not be a coarray", c
->name
, &c
->loc
);
12522 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12523 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12524 || c
->attr
.allocatable
))
12526 gfc_error ("Component %qs at %L with coarray component "
12527 "shall be a nonpointer, nonallocatable scalar",
12534 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12536 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12537 "is not an array pointer", c
->name
, &c
->loc
);
12542 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12544 gfc_symbol
*ifc
= c
->ts
.interface
;
12546 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
12553 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12555 /* Resolve interface and copy attributes. */
12556 if (ifc
->formal
&& !ifc
->formal_ns
)
12557 resolve_symbol (ifc
);
12558 if (ifc
->attr
.intrinsic
)
12559 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12563 c
->ts
= ifc
->result
->ts
;
12564 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12565 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12566 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12567 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12568 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12573 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12574 c
->attr
.pointer
= ifc
->attr
.pointer
;
12575 c
->attr
.dimension
= ifc
->attr
.dimension
;
12576 c
->as
= gfc_copy_array_spec (ifc
->as
);
12577 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12579 c
->ts
.interface
= ifc
;
12580 c
->attr
.function
= ifc
->attr
.function
;
12581 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12583 c
->attr
.pure
= ifc
->attr
.pure
;
12584 c
->attr
.elemental
= ifc
->attr
.elemental
;
12585 c
->attr
.recursive
= ifc
->attr
.recursive
;
12586 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12587 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12588 /* Copy char length. */
12589 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12591 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12592 if (cl
->length
&& !cl
->resolved
12593 && !gfc_resolve_expr (cl
->length
))
12603 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12605 /* Since PPCs are not implicitly typed, a PPC without an explicit
12606 interface must be a subroutine. */
12607 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12610 /* Procedure pointer components: Check PASS arg. */
12611 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12612 && !sym
->attr
.vtype
)
12614 gfc_symbol
* me_arg
;
12616 if (c
->tb
->pass_arg
)
12618 gfc_formal_arglist
* i
;
12620 /* If an explicit passing argument name is given, walk the arg-list
12621 and look for it. */
12624 c
->tb
->pass_arg_num
= 1;
12625 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12627 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12632 c
->tb
->pass_arg_num
++;
12637 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12638 "at %L has no argument %qs", c
->name
,
12639 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12647 /* Otherwise, take the first one; there should in fact be at least
12649 c
->tb
->pass_arg_num
= 1;
12650 if (!c
->ts
.interface
->formal
)
12652 gfc_error ("Procedure pointer component %qs with PASS at %L "
12653 "must have at least one argument",
12659 me_arg
= c
->ts
.interface
->formal
->sym
;
12662 /* Now check that the argument-type matches. */
12663 gcc_assert (me_arg
);
12664 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12665 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12666 || (me_arg
->ts
.type
== BT_CLASS
12667 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12669 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12670 " the derived type %qs", me_arg
->name
, c
->name
,
12671 me_arg
->name
, &c
->loc
, sym
->name
);
12677 /* Check for C453. */
12678 if (me_arg
->attr
.dimension
)
12680 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12681 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12688 if (me_arg
->attr
.pointer
)
12690 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12691 "may not have the POINTER attribute", me_arg
->name
,
12692 c
->name
, me_arg
->name
, &c
->loc
);
12698 if (me_arg
->attr
.allocatable
)
12700 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12701 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12702 me_arg
->name
, &c
->loc
);
12708 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12710 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12711 " at %L", c
->name
, &c
->loc
);
12718 /* Check type-spec if this is not the parent-type component. */
12719 if (((sym
->attr
.is_class
12720 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12721 || c
!= sym
->components
->ts
.u
.derived
->components
))
12722 || (!sym
->attr
.is_class
12723 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12724 && !sym
->attr
.vtype
12725 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12728 /* If this type is an extension, set the accessibility of the parent
12731 && ((sym
->attr
.is_class
12732 && c
== sym
->components
->ts
.u
.derived
->components
)
12733 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12734 && strcmp (super_type
->name
, c
->name
) == 0)
12735 c
->attr
.access
= super_type
->attr
.access
;
12737 /* If this type is an extension, see if this component has the same name
12738 as an inherited type-bound procedure. */
12739 if (super_type
&& !sym
->attr
.is_class
12740 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12742 gfc_error ("Component %qs of %qs at %L has the same name as an"
12743 " inherited type-bound procedure",
12744 c
->name
, sym
->name
, &c
->loc
);
12748 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12749 && !c
->ts
.deferred
)
12751 if (c
->ts
.u
.cl
->length
== NULL
12752 || (!resolve_charlen(c
->ts
.u
.cl
))
12753 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12755 gfc_error ("Character length of component %qs needs to "
12756 "be a constant specification expression at %L",
12758 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12763 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12764 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12766 gfc_error ("Character component %qs of %qs at %L with deferred "
12767 "length must be a POINTER or ALLOCATABLE",
12768 c
->name
, sym
->name
, &c
->loc
);
12772 /* Add the hidden deferred length field. */
12773 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12774 && !sym
->attr
.is_class
)
12776 char name
[GFC_MAX_SYMBOL_LEN
+9];
12777 gfc_component
*strlen
;
12778 sprintf (name
, "_%s_length", c
->name
);
12779 strlen
= gfc_find_component (sym
, name
, true, true);
12780 if (strlen
== NULL
)
12782 if (!gfc_add_component (sym
, name
, &strlen
))
12784 strlen
->ts
.type
= BT_INTEGER
;
12785 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12786 strlen
->attr
.access
= ACCESS_PRIVATE
;
12787 strlen
->attr
.artificial
= 1;
12791 if (c
->ts
.type
== BT_DERIVED
12792 && sym
->component_access
!= ACCESS_PRIVATE
12793 && gfc_check_symbol_access (sym
)
12794 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12795 && !c
->ts
.u
.derived
->attr
.use_assoc
12796 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12797 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
12798 "PRIVATE type and cannot be a component of "
12799 "%qs, which is PUBLIC at %L", c
->name
,
12800 sym
->name
, &sym
->declared_at
))
12803 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12805 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12806 "type %s", c
->name
, &c
->loc
, sym
->name
);
12810 if (sym
->attr
.sequence
)
12812 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12814 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12815 "not have the SEQUENCE attribute",
12816 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12821 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12822 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12823 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12824 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12825 CLASS_DATA (c
)->ts
.u
.derived
12826 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12828 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12829 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12830 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12832 gfc_error ("The pointer component %qs of %qs at %L is a type "
12833 "that has not been declared", c
->name
, sym
->name
,
12838 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12839 && CLASS_DATA (c
)->attr
.class_pointer
12840 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12841 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12842 && !UNLIMITED_POLY (c
))
12844 gfc_error ("The pointer component %qs of %qs at %L is a type "
12845 "that has not been declared", c
->name
, sym
->name
,
12851 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12852 && (!c
->attr
.class_ok
12853 || !(CLASS_DATA (c
)->attr
.class_pointer
12854 || CLASS_DATA (c
)->attr
.allocatable
)))
12856 gfc_error ("Component %qs with CLASS at %L must be allocatable "
12857 "or pointer", c
->name
, &c
->loc
);
12858 /* Prevent a recurrence of the error. */
12859 c
->ts
.type
= BT_UNKNOWN
;
12863 /* Ensure that all the derived type components are put on the
12864 derived type list; even in formal namespaces, where derived type
12865 pointer components might not have been declared. */
12866 if (c
->ts
.type
== BT_DERIVED
12868 && c
->ts
.u
.derived
->components
12870 && sym
!= c
->ts
.u
.derived
)
12871 add_dt_to_dt_list (c
->ts
.u
.derived
);
12873 if (!gfc_resolve_array_spec (c
->as
,
12874 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12875 || c
->attr
.allocatable
)))
12878 if (c
->initializer
&& !sym
->attr
.vtype
12879 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12886 check_defined_assignments (sym
);
12888 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12889 sym
->attr
.defined_assign_comp
12890 = super_type
->attr
.defined_assign_comp
;
12892 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12893 all DEFERRED bindings are overridden. */
12894 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12895 && !sym
->attr
.is_class
12896 && !ensure_not_abstract (sym
, super_type
))
12899 /* Add derived type to the derived type list. */
12900 add_dt_to_dt_list (sym
);
12906 /* The following procedure does the full resolution of a derived type,
12907 including resolution of all type-bound procedures (if present). In contrast
12908 to 'resolve_fl_derived0' this can only be done after the module has been
12909 parsed completely. */
12912 resolve_fl_derived (gfc_symbol
*sym
)
12914 gfc_symbol
*gen_dt
= NULL
;
12916 if (sym
->attr
.unlimited_polymorphic
)
12919 if (!sym
->attr
.is_class
)
12920 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12921 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12922 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12923 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12924 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
12925 "%qs at %L being the same name as derived "
12926 "type at %L", sym
->name
,
12927 gen_dt
->generic
->sym
== sym
12928 ? gen_dt
->generic
->next
->sym
->name
12929 : gen_dt
->generic
->sym
->name
,
12930 gen_dt
->generic
->sym
== sym
12931 ? &gen_dt
->generic
->next
->sym
->declared_at
12932 : &gen_dt
->generic
->sym
->declared_at
,
12933 &sym
->declared_at
))
12936 /* Resolve the finalizer procedures. */
12937 if (!gfc_resolve_finalizers (sym
, NULL
))
12940 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12942 /* Fix up incomplete CLASS symbols. */
12943 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12944 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12946 /* Nothing more to do for unlimited polymorphic entities. */
12947 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12949 else if (vptr
->ts
.u
.derived
== NULL
)
12951 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12953 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12957 if (!resolve_fl_derived0 (sym
))
12960 /* Resolve the type-bound procedures. */
12961 if (!resolve_typebound_procedures (sym
))
12969 resolve_fl_namelist (gfc_symbol
*sym
)
12974 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12976 /* Check again, the check in match only works if NAMELIST comes
12978 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12980 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
12981 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12985 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12986 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12987 "with assumed shape in namelist %qs at %L",
12988 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12991 if (is_non_constant_shape_array (nl
->sym
)
12992 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12993 "with nonconstant shape in namelist %qs at %L",
12994 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12997 if (nl
->sym
->ts
.type
== BT_CHARACTER
12998 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12999 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13000 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13001 "nonconstant character length in "
13002 "namelist %qs at %L", nl
->sym
->name
,
13003 sym
->name
, &sym
->declared_at
))
13006 /* FIXME: Once UDDTIO is implemented, the following can be
13008 if (nl
->sym
->ts
.type
== BT_CLASS
)
13010 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13011 "polymorphic and requires a defined input/output "
13012 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13016 if (nl
->sym
->ts
.type
== BT_DERIVED
13017 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13018 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13020 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13021 "namelist %qs at %L with ALLOCATABLE "
13022 "or POINTER components", nl
->sym
->name
,
13023 sym
->name
, &sym
->declared_at
))
13026 /* FIXME: Once UDDTIO is implemented, the following can be
13028 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13029 "ALLOCATABLE or POINTER components and thus requires "
13030 "a defined input/output procedure", nl
->sym
->name
,
13031 sym
->name
, &sym
->declared_at
);
13036 /* Reject PRIVATE objects in a PUBLIC namelist. */
13037 if (gfc_check_symbol_access (sym
))
13039 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13041 if (!nl
->sym
->attr
.use_assoc
13042 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13043 && !gfc_check_symbol_access (nl
->sym
))
13045 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13046 "cannot be member of PUBLIC namelist %qs at %L",
13047 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13051 /* Types with private components that came here by USE-association. */
13052 if (nl
->sym
->ts
.type
== BT_DERIVED
13053 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13055 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13056 "components and cannot be member of namelist %qs at %L",
13057 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13061 /* Types with private components that are defined in the same module. */
13062 if (nl
->sym
->ts
.type
== BT_DERIVED
13063 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13064 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13066 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13067 "cannot be a member of PUBLIC namelist %qs at %L",
13068 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13075 /* 14.1.2 A module or internal procedure represent local entities
13076 of the same type as a namelist member and so are not allowed. */
13077 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13079 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13082 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13083 if ((nl
->sym
== sym
->ns
->proc_name
)
13085 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13090 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13091 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13093 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13094 "attribute in %qs at %L", nlsym
->name
,
13095 &sym
->declared_at
);
13105 resolve_fl_parameter (gfc_symbol
*sym
)
13107 /* A parameter array's shape needs to be constant. */
13108 if (sym
->as
!= NULL
13109 && (sym
->as
->type
== AS_DEFERRED
13110 || is_non_constant_shape_array (sym
)))
13112 gfc_error ("Parameter array %qs at %L cannot be automatic "
13113 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13117 /* Make sure a parameter that has been implicitly typed still
13118 matches the implicit type, since PARAMETER statements can precede
13119 IMPLICIT statements. */
13120 if (sym
->attr
.implicit_type
13121 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13124 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13125 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13129 /* Make sure the types of derived parameters are consistent. This
13130 type checking is deferred until resolution because the type may
13131 refer to a derived type from the host. */
13132 if (sym
->ts
.type
== BT_DERIVED
13133 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13135 gfc_error ("Incompatible derived type in PARAMETER at %L",
13136 &sym
->value
->where
);
13143 /* Do anything necessary to resolve a symbol. Right now, we just
13144 assume that an otherwise unknown symbol is a variable. This sort
13145 of thing commonly happens for symbols in module. */
13148 resolve_symbol (gfc_symbol
*sym
)
13150 int check_constant
, mp_flag
;
13151 gfc_symtree
*symtree
;
13152 gfc_symtree
*this_symtree
;
13155 symbol_attribute class_attr
;
13156 gfc_array_spec
*as
;
13157 bool saved_specification_expr
;
13163 if (sym
->attr
.artificial
)
13166 if (sym
->attr
.unlimited_polymorphic
)
13169 if (sym
->attr
.flavor
== FL_UNKNOWN
13170 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13171 && !sym
->attr
.generic
&& !sym
->attr
.external
13172 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13173 && sym
->ts
.type
== BT_UNKNOWN
))
13176 /* If we find that a flavorless symbol is an interface in one of the
13177 parent namespaces, find its symtree in this namespace, free the
13178 symbol and set the symtree to point to the interface symbol. */
13179 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13181 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13182 if (symtree
&& (symtree
->n
.sym
->generic
||
13183 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13184 && sym
->ns
->construct_entities
)))
13186 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13188 if (this_symtree
->n
.sym
== sym
)
13190 symtree
->n
.sym
->refs
++;
13191 gfc_release_symbol (sym
);
13192 this_symtree
->n
.sym
= symtree
->n
.sym
;
13198 /* Otherwise give it a flavor according to such attributes as
13200 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13201 && sym
->attr
.intrinsic
== 0)
13202 sym
->attr
.flavor
= FL_VARIABLE
;
13203 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13205 sym
->attr
.flavor
= FL_PROCEDURE
;
13206 if (sym
->attr
.dimension
)
13207 sym
->attr
.function
= 1;
13211 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13212 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13214 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13215 && !resolve_procedure_interface (sym
))
13218 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13219 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13221 if (sym
->attr
.external
)
13222 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13223 "at %L", &sym
->declared_at
);
13225 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13226 "at %L", &sym
->declared_at
);
13231 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13234 /* Symbols that are module procedures with results (functions) have
13235 the types and array specification copied for type checking in
13236 procedures that call them, as well as for saving to a module
13237 file. These symbols can't stand the scrutiny that their results
13239 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13241 /* Make sure that the intrinsic is consistent with its internal
13242 representation. This needs to be done before assigning a default
13243 type to avoid spurious warnings. */
13244 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13245 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13248 /* Resolve associate names. */
13250 resolve_assoc_var (sym
, true);
13252 /* Assign default type to symbols that need one and don't have one. */
13253 if (sym
->ts
.type
== BT_UNKNOWN
)
13255 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13257 gfc_set_default_type (sym
, 1, NULL
);
13260 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13261 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13262 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13263 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13265 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13267 /* The specific case of an external procedure should emit an error
13268 in the case that there is no implicit type. */
13270 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13273 /* Result may be in another namespace. */
13274 resolve_symbol (sym
->result
);
13276 if (!sym
->result
->attr
.proc_pointer
)
13278 sym
->ts
= sym
->result
->ts
;
13279 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13280 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13281 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13282 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13283 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13288 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13290 bool saved_specification_expr
= specification_expr
;
13291 specification_expr
= true;
13292 gfc_resolve_array_spec (sym
->result
->as
, false);
13293 specification_expr
= saved_specification_expr
;
13296 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13298 as
= CLASS_DATA (sym
)->as
;
13299 class_attr
= CLASS_DATA (sym
)->attr
;
13300 class_attr
.pointer
= class_attr
.class_pointer
;
13304 class_attr
= sym
->attr
;
13309 if (sym
->attr
.contiguous
13310 && (!class_attr
.dimension
13311 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13312 && !class_attr
.pointer
)))
13314 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13315 "array pointer or an assumed-shape or assumed-rank array",
13316 sym
->name
, &sym
->declared_at
);
13320 /* Assumed size arrays and assumed shape arrays must be dummy
13321 arguments. Array-spec's of implied-shape should have been resolved to
13322 AS_EXPLICIT already. */
13326 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13327 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13328 || as
->type
== AS_ASSUMED_SHAPE
)
13329 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13331 if (as
->type
== AS_ASSUMED_SIZE
)
13332 gfc_error ("Assumed size array at %L must be a dummy argument",
13333 &sym
->declared_at
);
13335 gfc_error ("Assumed shape array at %L must be a dummy argument",
13336 &sym
->declared_at
);
13339 /* TS 29113, C535a. */
13340 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13341 && !sym
->attr
.select_type_temporary
)
13343 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13344 &sym
->declared_at
);
13347 if (as
->type
== AS_ASSUMED_RANK
13348 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13350 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13351 "CODIMENSION attribute", &sym
->declared_at
);
13356 /* Make sure symbols with known intent or optional are really dummy
13357 variable. Because of ENTRY statement, this has to be deferred
13358 until resolution time. */
13360 if (!sym
->attr
.dummy
13361 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13363 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13367 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13369 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13370 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13374 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13376 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13377 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13379 gfc_error ("Character dummy variable %qs at %L with VALUE "
13380 "attribute must have constant length",
13381 sym
->name
, &sym
->declared_at
);
13385 if (sym
->ts
.is_c_interop
13386 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13388 gfc_error ("C interoperable character dummy variable %qs at %L "
13389 "with VALUE attribute must have length one",
13390 sym
->name
, &sym
->declared_at
);
13395 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13396 && sym
->ts
.u
.derived
->attr
.generic
)
13398 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13399 if (!sym
->ts
.u
.derived
)
13401 gfc_error ("The derived type %qs at %L is of type %qs, "
13402 "which has not been defined", sym
->name
,
13403 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13404 sym
->ts
.type
= BT_UNKNOWN
;
13409 /* Use the same constraints as TYPE(*), except for the type check
13410 and that only scalars and assumed-size arrays are permitted. */
13411 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13413 if (!sym
->attr
.dummy
)
13415 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13416 "a dummy argument", sym
->name
, &sym
->declared_at
);
13420 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13421 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13422 && sym
->ts
.type
!= BT_COMPLEX
)
13424 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13425 "of type TYPE(*) or of an numeric intrinsic type",
13426 sym
->name
, &sym
->declared_at
);
13430 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13431 || sym
->attr
.pointer
|| sym
->attr
.value
)
13433 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13434 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13435 "attribute", sym
->name
, &sym
->declared_at
);
13439 if (sym
->attr
.intent
== INTENT_OUT
)
13441 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13442 "have the INTENT(OUT) attribute",
13443 sym
->name
, &sym
->declared_at
);
13446 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13448 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13449 "either be a scalar or an assumed-size array",
13450 sym
->name
, &sym
->declared_at
);
13454 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13455 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13457 sym
->ts
.type
= BT_ASSUMED
;
13458 sym
->as
= gfc_get_array_spec ();
13459 sym
->as
->type
= AS_ASSUMED_SIZE
;
13461 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13463 else if (sym
->ts
.type
== BT_ASSUMED
)
13465 /* TS 29113, C407a. */
13466 if (!sym
->attr
.dummy
)
13468 gfc_error ("Assumed type of variable %s at %L is only permitted "
13469 "for dummy variables", sym
->name
, &sym
->declared_at
);
13472 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13473 || sym
->attr
.pointer
|| sym
->attr
.value
)
13475 gfc_error ("Assumed-type variable %s at %L may not have the "
13476 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13477 sym
->name
, &sym
->declared_at
);
13480 if (sym
->attr
.intent
== INTENT_OUT
)
13482 gfc_error ("Assumed-type variable %s at %L may not have the "
13483 "INTENT(OUT) attribute",
13484 sym
->name
, &sym
->declared_at
);
13487 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13489 gfc_error ("Assumed-type variable %s at %L shall not be an "
13490 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13495 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13496 do this for something that was implicitly typed because that is handled
13497 in gfc_set_default_type. Handle dummy arguments and procedure
13498 definitions separately. Also, anything that is use associated is not
13499 handled here but instead is handled in the module it is declared in.
13500 Finally, derived type definitions are allowed to be BIND(C) since that
13501 only implies that they're interoperable, and they are checked fully for
13502 interoperability when a variable is declared of that type. */
13503 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13504 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13505 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13509 /* First, make sure the variable is declared at the
13510 module-level scope (J3/04-007, Section 15.3). */
13511 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13512 sym
->attr
.in_common
== 0)
13514 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13515 "is neither a COMMON block nor declared at the "
13516 "module level scope", sym
->name
, &(sym
->declared_at
));
13519 else if (sym
->common_head
!= NULL
)
13521 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13525 /* If type() declaration, we need to verify that the components
13526 of the given type are all C interoperable, etc. */
13527 if (sym
->ts
.type
== BT_DERIVED
&&
13528 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13530 /* Make sure the user marked the derived type as BIND(C). If
13531 not, call the verify routine. This could print an error
13532 for the derived type more than once if multiple variables
13533 of that type are declared. */
13534 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13535 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13539 /* Verify the variable itself as C interoperable if it
13540 is BIND(C). It is not possible for this to succeed if
13541 the verify_bind_c_derived_type failed, so don't have to handle
13542 any error returned by verify_bind_c_derived_type. */
13543 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13544 sym
->common_block
);
13549 /* clear the is_bind_c flag to prevent reporting errors more than
13550 once if something failed. */
13551 sym
->attr
.is_bind_c
= 0;
13556 /* If a derived type symbol has reached this point, without its
13557 type being declared, we have an error. Notice that most
13558 conditions that produce undefined derived types have already
13559 been dealt with. However, the likes of:
13560 implicit type(t) (t) ..... call foo (t) will get us here if
13561 the type is not declared in the scope of the implicit
13562 statement. Change the type to BT_UNKNOWN, both because it is so
13563 and to prevent an ICE. */
13564 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13565 && sym
->ts
.u
.derived
->components
== NULL
13566 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13568 gfc_error ("The derived type %qs at %L is of type %qs, "
13569 "which has not been defined", sym
->name
,
13570 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13571 sym
->ts
.type
= BT_UNKNOWN
;
13575 /* Make sure that the derived type has been resolved and that the
13576 derived type is visible in the symbol's namespace, if it is a
13577 module function and is not PRIVATE. */
13578 if (sym
->ts
.type
== BT_DERIVED
13579 && sym
->ts
.u
.derived
->attr
.use_assoc
13580 && sym
->ns
->proc_name
13581 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13582 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13585 /* Unless the derived-type declaration is use associated, Fortran 95
13586 does not allow public entries of private derived types.
13587 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13588 161 in 95-006r3. */
13589 if (sym
->ts
.type
== BT_DERIVED
13590 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13591 && !sym
->ts
.u
.derived
->attr
.use_assoc
13592 && gfc_check_symbol_access (sym
)
13593 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13594 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
13595 "derived type %qs",
13596 (sym
->attr
.flavor
== FL_PARAMETER
)
13597 ? "parameter" : "variable",
13598 sym
->name
, &sym
->declared_at
,
13599 sym
->ts
.u
.derived
->name
))
13602 /* F2008, C1302. */
13603 if (sym
->ts
.type
== BT_DERIVED
13604 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13605 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13606 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13607 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13609 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13610 "type LOCK_TYPE must be a coarray", sym
->name
,
13611 &sym
->declared_at
);
13615 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13616 default initialization is defined (5.1.2.4.4). */
13617 if (sym
->ts
.type
== BT_DERIVED
13619 && sym
->attr
.intent
== INTENT_OUT
13621 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13623 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13625 if (c
->initializer
)
13627 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
13628 "ASSUMED SIZE and so cannot have a default initializer",
13629 sym
->name
, &sym
->declared_at
);
13636 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13637 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13639 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
13640 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13645 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13646 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13647 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13648 || class_attr
.codimension
)
13649 && (sym
->attr
.result
|| sym
->result
== sym
))
13651 gfc_error ("Function result %qs at %L shall not be a coarray or have "
13652 "a coarray component", sym
->name
, &sym
->declared_at
);
13657 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13658 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13660 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13661 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13666 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13667 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13668 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13669 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13670 || class_attr
.allocatable
))
13672 gfc_error ("Variable %qs at %L with coarray component shall be a "
13673 "nonpointer, nonallocatable scalar, which is not a coarray",
13674 sym
->name
, &sym
->declared_at
);
13678 /* F2008, C526. The function-result case was handled above. */
13679 if (class_attr
.codimension
13680 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13681 || sym
->attr
.select_type_temporary
13682 || sym
->ns
->save_all
13683 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13684 || sym
->ns
->proc_name
->attr
.is_main_program
13685 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13687 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
13688 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13692 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13693 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13695 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
13696 "deferred shape", sym
->name
, &sym
->declared_at
);
13699 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13700 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13702 gfc_error ("Allocatable coarray variable %qs at %L must have "
13703 "deferred shape", sym
->name
, &sym
->declared_at
);
13708 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13709 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13710 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13711 || (class_attr
.codimension
&& class_attr
.allocatable
))
13712 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13714 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
13715 "allocatable coarray or have coarray components",
13716 sym
->name
, &sym
->declared_at
);
13720 if (class_attr
.codimension
&& sym
->attr
.dummy
13721 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13723 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
13724 "procedure %qs", sym
->name
, &sym
->declared_at
,
13725 sym
->ns
->proc_name
->name
);
13729 if (sym
->ts
.type
== BT_LOGICAL
13730 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13731 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13732 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13735 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13736 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13738 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13739 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
13740 "%L with non-C_Bool kind in BIND(C) procedure "
13741 "%qs", sym
->name
, &sym
->declared_at
,
13742 sym
->ns
->proc_name
->name
))
13744 else if (!gfc_logical_kinds
[i
].c_bool
13745 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13746 "%qs at %L with non-C_Bool kind in "
13747 "BIND(C) procedure %qs", sym
->name
,
13749 sym
->attr
.function
? sym
->name
13750 : sym
->ns
->proc_name
->name
))
13754 switch (sym
->attr
.flavor
)
13757 if (!resolve_fl_variable (sym
, mp_flag
))
13762 if (!resolve_fl_procedure (sym
, mp_flag
))
13767 if (!resolve_fl_namelist (sym
))
13772 if (!resolve_fl_parameter (sym
))
13780 /* Resolve array specifier. Check as well some constraints
13781 on COMMON blocks. */
13783 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13785 /* Set the formal_arg_flag so that check_conflict will not throw
13786 an error for host associated variables in the specification
13787 expression for an array_valued function. */
13788 if (sym
->attr
.function
&& sym
->as
)
13789 formal_arg_flag
= 1;
13791 saved_specification_expr
= specification_expr
;
13792 specification_expr
= true;
13793 gfc_resolve_array_spec (sym
->as
, check_constant
);
13794 specification_expr
= saved_specification_expr
;
13796 formal_arg_flag
= 0;
13798 /* Resolve formal namespaces. */
13799 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13800 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13801 gfc_resolve (sym
->formal_ns
);
13803 /* Make sure the formal namespace is present. */
13804 if (sym
->formal
&& !sym
->formal_ns
)
13806 gfc_formal_arglist
*formal
= sym
->formal
;
13807 while (formal
&& !formal
->sym
)
13808 formal
= formal
->next
;
13812 sym
->formal_ns
= formal
->sym
->ns
;
13813 if (sym
->ns
!= formal
->sym
->ns
)
13814 sym
->formal_ns
->refs
++;
13818 /* Check threadprivate restrictions. */
13819 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13820 && (!sym
->attr
.in_common
13821 && sym
->module
== NULL
13822 && (sym
->ns
->proc_name
== NULL
13823 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13824 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13826 /* Check omp declare target restrictions. */
13827 if (sym
->attr
.omp_declare_target
13828 && sym
->attr
.flavor
== FL_VARIABLE
13830 && !sym
->ns
->save_all
13831 && (!sym
->attr
.in_common
13832 && sym
->module
== NULL
13833 && (sym
->ns
->proc_name
== NULL
13834 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13835 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
13836 sym
->name
, &sym
->declared_at
);
13838 /* If we have come this far we can apply default-initializers, as
13839 described in 14.7.5, to those variables that have not already
13840 been assigned one. */
13841 if (sym
->ts
.type
== BT_DERIVED
13843 && !sym
->attr
.allocatable
13844 && !sym
->attr
.alloc_comp
)
13846 symbol_attribute
*a
= &sym
->attr
;
13848 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13849 && !a
->in_common
&& !a
->use_assoc
13850 && (a
->referenced
|| a
->result
)
13851 && !(a
->function
&& sym
!= sym
->result
))
13852 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13853 apply_default_init (sym
);
13856 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13857 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13858 && !CLASS_DATA (sym
)->attr
.class_pointer
13859 && !CLASS_DATA (sym
)->attr
.allocatable
)
13860 apply_default_init (sym
);
13862 /* If this symbol has a type-spec, check it. */
13863 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13864 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13865 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13870 /************* Resolve DATA statements *************/
13874 gfc_data_value
*vnode
;
13880 /* Advance the values structure to point to the next value in the data list. */
13883 next_data_value (void)
13885 while (mpz_cmp_ui (values
.left
, 0) == 0)
13888 if (values
.vnode
->next
== NULL
)
13891 values
.vnode
= values
.vnode
->next
;
13892 mpz_set (values
.left
, values
.vnode
->repeat
);
13900 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13906 ar_type mark
= AR_UNKNOWN
;
13908 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13914 if (!gfc_resolve_expr (var
->expr
))
13918 mpz_init_set_si (offset
, 0);
13921 if (e
->expr_type
!= EXPR_VARIABLE
)
13922 gfc_internal_error ("check_data_variable(): Bad expression");
13924 sym
= e
->symtree
->n
.sym
;
13926 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13928 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
13929 sym
->name
, &sym
->declared_at
);
13932 if (e
->ref
== NULL
&& sym
->as
)
13934 gfc_error ("DATA array %qs at %L must be specified in a previous"
13935 " declaration", sym
->name
, where
);
13939 has_pointer
= sym
->attr
.pointer
;
13941 if (gfc_is_coindexed (e
))
13943 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
13948 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13950 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13954 && ref
->type
== REF_ARRAY
13955 && ref
->u
.ar
.type
!= AR_FULL
)
13957 gfc_error ("DATA element %qs at %L is a pointer and so must "
13958 "be a full array", sym
->name
, where
);
13963 if (e
->rank
== 0 || has_pointer
)
13965 mpz_init_set_ui (size
, 1);
13972 /* Find the array section reference. */
13973 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13975 if (ref
->type
!= REF_ARRAY
)
13977 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13983 /* Set marks according to the reference pattern. */
13984 switch (ref
->u
.ar
.type
)
13992 /* Get the start position of array section. */
13993 gfc_get_section_index (ar
, section_index
, &offset
);
13998 gcc_unreachable ();
14001 if (!gfc_array_size (e
, &size
))
14003 gfc_error ("Nonconstant array section at %L in DATA statement",
14005 mpz_clear (offset
);
14012 while (mpz_cmp_ui (size
, 0) > 0)
14014 if (!next_data_value ())
14016 gfc_error ("DATA statement at %L has more variables than values",
14022 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14026 /* If we have more than one element left in the repeat count,
14027 and we have more than one element left in the target variable,
14028 then create a range assignment. */
14029 /* FIXME: Only done for full arrays for now, since array sections
14031 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14032 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14036 if (mpz_cmp (size
, values
.left
) >= 0)
14038 mpz_init_set (range
, values
.left
);
14039 mpz_sub (size
, size
, values
.left
);
14040 mpz_set_ui (values
.left
, 0);
14044 mpz_init_set (range
, size
);
14045 mpz_sub (values
.left
, values
.left
, size
);
14046 mpz_set_ui (size
, 0);
14049 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14052 mpz_add (offset
, offset
, range
);
14059 /* Assign initial value to symbol. */
14062 mpz_sub_ui (values
.left
, values
.left
, 1);
14063 mpz_sub_ui (size
, size
, 1);
14065 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14070 if (mark
== AR_FULL
)
14071 mpz_add_ui (offset
, offset
, 1);
14073 /* Modify the array section indexes and recalculate the offset
14074 for next element. */
14075 else if (mark
== AR_SECTION
)
14076 gfc_advance_section (section_index
, ar
, &offset
);
14080 if (mark
== AR_SECTION
)
14082 for (i
= 0; i
< ar
->dimen
; i
++)
14083 mpz_clear (section_index
[i
]);
14087 mpz_clear (offset
);
14093 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14095 /* Iterate over a list of elements in a DATA statement. */
14098 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14101 iterator_stack frame
;
14102 gfc_expr
*e
, *start
, *end
, *step
;
14103 bool retval
= true;
14105 mpz_init (frame
.value
);
14108 start
= gfc_copy_expr (var
->iter
.start
);
14109 end
= gfc_copy_expr (var
->iter
.end
);
14110 step
= gfc_copy_expr (var
->iter
.step
);
14112 if (!gfc_simplify_expr (start
, 1)
14113 || start
->expr_type
!= EXPR_CONSTANT
)
14115 gfc_error ("start of implied-do loop at %L could not be "
14116 "simplified to a constant value", &start
->where
);
14120 if (!gfc_simplify_expr (end
, 1)
14121 || end
->expr_type
!= EXPR_CONSTANT
)
14123 gfc_error ("end of implied-do loop at %L could not be "
14124 "simplified to a constant value", &start
->where
);
14128 if (!gfc_simplify_expr (step
, 1)
14129 || step
->expr_type
!= EXPR_CONSTANT
)
14131 gfc_error ("step of implied-do loop at %L could not be "
14132 "simplified to a constant value", &start
->where
);
14137 mpz_set (trip
, end
->value
.integer
);
14138 mpz_sub (trip
, trip
, start
->value
.integer
);
14139 mpz_add (trip
, trip
, step
->value
.integer
);
14141 mpz_div (trip
, trip
, step
->value
.integer
);
14143 mpz_set (frame
.value
, start
->value
.integer
);
14145 frame
.prev
= iter_stack
;
14146 frame
.variable
= var
->iter
.var
->symtree
;
14147 iter_stack
= &frame
;
14149 while (mpz_cmp_ui (trip
, 0) > 0)
14151 if (!traverse_data_var (var
->list
, where
))
14157 e
= gfc_copy_expr (var
->expr
);
14158 if (!gfc_simplify_expr (e
, 1))
14165 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14167 mpz_sub_ui (trip
, trip
, 1);
14171 mpz_clear (frame
.value
);
14174 gfc_free_expr (start
);
14175 gfc_free_expr (end
);
14176 gfc_free_expr (step
);
14178 iter_stack
= frame
.prev
;
14183 /* Type resolve variables in the variable list of a DATA statement. */
14186 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14190 for (; var
; var
= var
->next
)
14192 if (var
->expr
== NULL
)
14193 t
= traverse_data_list (var
, where
);
14195 t
= check_data_variable (var
, where
);
14205 /* Resolve the expressions and iterators associated with a data statement.
14206 This is separate from the assignment checking because data lists should
14207 only be resolved once. */
14210 resolve_data_variables (gfc_data_variable
*d
)
14212 for (; d
; d
= d
->next
)
14214 if (d
->list
== NULL
)
14216 if (!gfc_resolve_expr (d
->expr
))
14221 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14224 if (!resolve_data_variables (d
->list
))
14233 /* Resolve a single DATA statement. We implement this by storing a pointer to
14234 the value list into static variables, and then recursively traversing the
14235 variables list, expanding iterators and such. */
14238 resolve_data (gfc_data
*d
)
14241 if (!resolve_data_variables (d
->var
))
14244 values
.vnode
= d
->value
;
14245 if (d
->value
== NULL
)
14246 mpz_set_ui (values
.left
, 0);
14248 mpz_set (values
.left
, d
->value
->repeat
);
14250 if (!traverse_data_var (d
->var
, &d
->where
))
14253 /* At this point, we better not have any values left. */
14255 if (next_data_value ())
14256 gfc_error ("DATA statement at %L has more values than variables",
14261 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14262 accessed by host or use association, is a dummy argument to a pure function,
14263 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14264 is storage associated with any such variable, shall not be used in the
14265 following contexts: (clients of this function). */
14267 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14268 procedure. Returns zero if assignment is OK, nonzero if there is a
14271 gfc_impure_variable (gfc_symbol
*sym
)
14276 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14279 /* Check if the symbol's ns is inside the pure procedure. */
14280 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14284 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14288 proc
= sym
->ns
->proc_name
;
14289 if (sym
->attr
.dummy
14290 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14291 || proc
->attr
.function
))
14294 /* TODO: Sort out what can be storage associated, if anything, and include
14295 it here. In principle equivalences should be scanned but it does not
14296 seem to be possible to storage associate an impure variable this way. */
14301 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14302 current namespace is inside a pure procedure. */
14305 gfc_pure (gfc_symbol
*sym
)
14307 symbol_attribute attr
;
14312 /* Check if the current namespace or one of its parents
14313 belongs to a pure procedure. */
14314 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14316 sym
= ns
->proc_name
;
14320 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14328 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14332 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14333 checks if the current namespace is implicitly pure. Note that this
14334 function returns false for a PURE procedure. */
14337 gfc_implicit_pure (gfc_symbol
*sym
)
14343 /* Check if the current procedure is implicit_pure. Walk up
14344 the procedure list until we find a procedure. */
14345 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14347 sym
= ns
->proc_name
;
14351 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14356 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14357 && !sym
->attr
.pure
;
14362 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14368 /* Check if the current procedure is implicit_pure. Walk up
14369 the procedure list until we find a procedure. */
14370 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14372 sym
= ns
->proc_name
;
14376 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14381 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14382 sym
->attr
.implicit_pure
= 0;
14384 sym
->attr
.pure
= 0;
14388 /* Test whether the current procedure is elemental or not. */
14391 gfc_elemental (gfc_symbol
*sym
)
14393 symbol_attribute attr
;
14396 sym
= gfc_current_ns
->proc_name
;
14401 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14405 /* Warn about unused labels. */
14408 warn_unused_fortran_label (gfc_st_label
*label
)
14413 warn_unused_fortran_label (label
->left
);
14415 if (label
->defined
== ST_LABEL_UNKNOWN
)
14418 switch (label
->referenced
)
14420 case ST_LABEL_UNKNOWN
:
14421 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
14425 case ST_LABEL_BAD_TARGET
:
14426 gfc_warning (0, "Label %d at %L defined but cannot be used",
14427 label
->value
, &label
->where
);
14434 warn_unused_fortran_label (label
->right
);
14438 /* Returns the sequence type of a symbol or sequence. */
14441 sequence_type (gfc_typespec ts
)
14450 if (ts
.u
.derived
->components
== NULL
)
14451 return SEQ_NONDEFAULT
;
14453 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14454 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14455 if (sequence_type (c
->ts
) != result
)
14461 if (ts
.kind
!= gfc_default_character_kind
)
14462 return SEQ_NONDEFAULT
;
14464 return SEQ_CHARACTER
;
14467 if (ts
.kind
!= gfc_default_integer_kind
)
14468 return SEQ_NONDEFAULT
;
14470 return SEQ_NUMERIC
;
14473 if (!(ts
.kind
== gfc_default_real_kind
14474 || ts
.kind
== gfc_default_double_kind
))
14475 return SEQ_NONDEFAULT
;
14477 return SEQ_NUMERIC
;
14480 if (ts
.kind
!= gfc_default_complex_kind
)
14481 return SEQ_NONDEFAULT
;
14483 return SEQ_NUMERIC
;
14486 if (ts
.kind
!= gfc_default_logical_kind
)
14487 return SEQ_NONDEFAULT
;
14489 return SEQ_NUMERIC
;
14492 return SEQ_NONDEFAULT
;
14497 /* Resolve derived type EQUIVALENCE object. */
14500 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14502 gfc_component
*c
= derived
->components
;
14507 /* Shall not be an object of nonsequence derived type. */
14508 if (!derived
->attr
.sequence
)
14510 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14511 "attribute to be an EQUIVALENCE object", sym
->name
,
14516 /* Shall not have allocatable components. */
14517 if (derived
->attr
.alloc_comp
)
14519 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14520 "components to be an EQUIVALENCE object",sym
->name
,
14525 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14527 gfc_error ("Derived type variable %qs at %L with default "
14528 "initialization cannot be in EQUIVALENCE with a variable "
14529 "in COMMON", sym
->name
, &e
->where
);
14533 for (; c
; c
= c
->next
)
14535 if (c
->ts
.type
== BT_DERIVED
14536 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14539 /* Shall not be an object of sequence derived type containing a pointer
14540 in the structure. */
14541 if (c
->attr
.pointer
)
14543 gfc_error ("Derived type variable %qs at %L with pointer "
14544 "component(s) cannot be an EQUIVALENCE object",
14545 sym
->name
, &e
->where
);
14553 /* Resolve equivalence object.
14554 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14555 an allocatable array, an object of nonsequence derived type, an object of
14556 sequence derived type containing a pointer at any level of component
14557 selection, an automatic object, a function name, an entry name, a result
14558 name, a named constant, a structure component, or a subobject of any of
14559 the preceding objects. A substring shall not have length zero. A
14560 derived type shall not have components with default initialization nor
14561 shall two objects of an equivalence group be initialized.
14562 Either all or none of the objects shall have an protected attribute.
14563 The simple constraints are done in symbol.c(check_conflict) and the rest
14564 are implemented here. */
14567 resolve_equivalence (gfc_equiv
*eq
)
14570 gfc_symbol
*first_sym
;
14573 locus
*last_where
= NULL
;
14574 seq_type eq_type
, last_eq_type
;
14575 gfc_typespec
*last_ts
;
14576 int object
, cnt_protected
;
14579 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14581 first_sym
= eq
->expr
->symtree
->n
.sym
;
14585 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14589 e
->ts
= e
->symtree
->n
.sym
->ts
;
14590 /* match_varspec might not know yet if it is seeing
14591 array reference or substring reference, as it doesn't
14593 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14595 gfc_ref
*ref
= e
->ref
;
14596 sym
= e
->symtree
->n
.sym
;
14598 if (sym
->attr
.dimension
)
14600 ref
->u
.ar
.as
= sym
->as
;
14604 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14605 if (e
->ts
.type
== BT_CHARACTER
14607 && ref
->type
== REF_ARRAY
14608 && ref
->u
.ar
.dimen
== 1
14609 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14610 && ref
->u
.ar
.stride
[0] == NULL
)
14612 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14613 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14616 /* Optimize away the (:) reference. */
14617 if (start
== NULL
&& end
== NULL
)
14620 e
->ref
= ref
->next
;
14622 e
->ref
->next
= ref
->next
;
14627 ref
->type
= REF_SUBSTRING
;
14629 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14631 ref
->u
.ss
.start
= start
;
14632 if (end
== NULL
&& e
->ts
.u
.cl
)
14633 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14634 ref
->u
.ss
.end
= end
;
14635 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14642 /* Any further ref is an error. */
14645 gcc_assert (ref
->type
== REF_ARRAY
);
14646 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14652 if (!gfc_resolve_expr (e
))
14655 sym
= e
->symtree
->n
.sym
;
14657 if (sym
->attr
.is_protected
)
14659 if (cnt_protected
> 0 && cnt_protected
!= object
)
14661 gfc_error ("Either all or none of the objects in the "
14662 "EQUIVALENCE set at %L shall have the "
14663 "PROTECTED attribute",
14668 /* Shall not equivalence common block variables in a PURE procedure. */
14669 if (sym
->ns
->proc_name
14670 && sym
->ns
->proc_name
->attr
.pure
14671 && sym
->attr
.in_common
)
14673 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
14674 "object in the pure procedure %qs",
14675 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14679 /* Shall not be a named constant. */
14680 if (e
->expr_type
== EXPR_CONSTANT
)
14682 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
14683 "object", sym
->name
, &e
->where
);
14687 if (e
->ts
.type
== BT_DERIVED
14688 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14691 /* Check that the types correspond correctly:
14693 A numeric sequence structure may be equivalenced to another sequence
14694 structure, an object of default integer type, default real type, double
14695 precision real type, default logical type such that components of the
14696 structure ultimately only become associated to objects of the same
14697 kind. A character sequence structure may be equivalenced to an object
14698 of default character kind or another character sequence structure.
14699 Other objects may be equivalenced only to objects of the same type and
14700 kind parameters. */
14702 /* Identical types are unconditionally OK. */
14703 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14704 goto identical_types
;
14706 last_eq_type
= sequence_type (*last_ts
);
14707 eq_type
= sequence_type (sym
->ts
);
14709 /* Since the pair of objects is not of the same type, mixed or
14710 non-default sequences can be rejected. */
14712 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14713 "statement at %L with different type objects";
14715 && last_eq_type
== SEQ_MIXED
14716 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14717 || (eq_type
== SEQ_MIXED
14718 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14721 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14722 "statement at %L with objects of different type";
14724 && last_eq_type
== SEQ_NONDEFAULT
14725 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14726 || (eq_type
== SEQ_NONDEFAULT
14727 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14730 msg
="Non-CHARACTER object %qs in default CHARACTER "
14731 "EQUIVALENCE statement at %L";
14732 if (last_eq_type
== SEQ_CHARACTER
14733 && eq_type
!= SEQ_CHARACTER
14734 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14737 msg
="Non-NUMERIC object %qs in default NUMERIC "
14738 "EQUIVALENCE statement at %L";
14739 if (last_eq_type
== SEQ_NUMERIC
14740 && eq_type
!= SEQ_NUMERIC
14741 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14746 last_where
= &e
->where
;
14751 /* Shall not be an automatic array. */
14752 if (e
->ref
->type
== REF_ARRAY
14753 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14755 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
14756 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14763 /* Shall not be a structure component. */
14764 if (r
->type
== REF_COMPONENT
)
14766 gfc_error ("Structure component %qs at %L cannot be an "
14767 "EQUIVALENCE object",
14768 r
->u
.c
.component
->name
, &e
->where
);
14772 /* A substring shall not have length zero. */
14773 if (r
->type
== REF_SUBSTRING
)
14775 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14777 gfc_error ("Substring at %L has length zero",
14778 &r
->u
.ss
.start
->where
);
14788 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14791 resolve_fntype (gfc_namespace
*ns
)
14793 gfc_entry_list
*el
;
14796 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14799 /* If there are any entries, ns->proc_name is the entry master
14800 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14802 sym
= ns
->entries
->sym
;
14804 sym
= ns
->proc_name
;
14805 if (sym
->result
== sym
14806 && sym
->ts
.type
== BT_UNKNOWN
14807 && !gfc_set_default_type (sym
, 0, NULL
)
14808 && !sym
->attr
.untyped
)
14810 gfc_error ("Function %qs at %L has no IMPLICIT type",
14811 sym
->name
, &sym
->declared_at
);
14812 sym
->attr
.untyped
= 1;
14815 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14816 && !sym
->attr
.contained
14817 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14818 && gfc_check_symbol_access (sym
))
14820 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
14821 "%L of PRIVATE type %qs", sym
->name
,
14822 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14826 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14828 if (el
->sym
->result
== el
->sym
14829 && el
->sym
->ts
.type
== BT_UNKNOWN
14830 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14831 && !el
->sym
->attr
.untyped
)
14833 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
14834 el
->sym
->name
, &el
->sym
->declared_at
);
14835 el
->sym
->attr
.untyped
= 1;
14841 /* 12.3.2.1.1 Defined operators. */
14844 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14846 gfc_formal_arglist
*formal
;
14848 if (!sym
->attr
.function
)
14850 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
14851 sym
->name
, &where
);
14855 if (sym
->ts
.type
== BT_CHARACTER
14856 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14857 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14858 && sym
->result
->ts
.u
.cl
->length
))
14860 gfc_error ("User operator procedure %qs at %L cannot be assumed "
14861 "character length", sym
->name
, &where
);
14865 formal
= gfc_sym_get_dummy_args (sym
);
14866 if (!formal
|| !formal
->sym
)
14868 gfc_error ("User operator procedure %qs at %L must have at least "
14869 "one argument", sym
->name
, &where
);
14873 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14875 gfc_error ("First argument of operator interface at %L must be "
14876 "INTENT(IN)", &where
);
14880 if (formal
->sym
->attr
.optional
)
14882 gfc_error ("First argument of operator interface at %L cannot be "
14883 "optional", &where
);
14887 formal
= formal
->next
;
14888 if (!formal
|| !formal
->sym
)
14891 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14893 gfc_error ("Second argument of operator interface at %L must be "
14894 "INTENT(IN)", &where
);
14898 if (formal
->sym
->attr
.optional
)
14900 gfc_error ("Second argument of operator interface at %L cannot be "
14901 "optional", &where
);
14907 gfc_error ("Operator interface at %L must have, at most, two "
14908 "arguments", &where
);
14916 gfc_resolve_uops (gfc_symtree
*symtree
)
14918 gfc_interface
*itr
;
14920 if (symtree
== NULL
)
14923 gfc_resolve_uops (symtree
->left
);
14924 gfc_resolve_uops (symtree
->right
);
14926 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14927 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14931 /* Examine all of the expressions associated with a program unit,
14932 assign types to all intermediate expressions, make sure that all
14933 assignments are to compatible types and figure out which names
14934 refer to which functions or subroutines. It doesn't check code
14935 block, which is handled by gfc_resolve_code. */
14938 resolve_types (gfc_namespace
*ns
)
14944 gfc_namespace
* old_ns
= gfc_current_ns
;
14946 if (ns
->types_resolved
)
14949 /* Check that all IMPLICIT types are ok. */
14950 if (!ns
->seen_implicit_none
)
14953 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14954 if (ns
->set_flag
[letter
]
14955 && !resolve_typespec_used (&ns
->default_type
[letter
],
14956 &ns
->implicit_loc
[letter
], NULL
))
14960 gfc_current_ns
= ns
;
14962 resolve_entries (ns
);
14964 resolve_common_vars (ns
->blank_common
.head
, false);
14965 resolve_common_blocks (ns
->common_root
);
14967 resolve_contained_functions (ns
);
14969 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14970 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14971 resolve_formal_arglist (ns
->proc_name
);
14973 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14975 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14976 resolve_charlen (cl
);
14978 gfc_traverse_ns (ns
, resolve_symbol
);
14980 resolve_fntype (ns
);
14982 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14984 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14985 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
14986 "also be PURE", n
->proc_name
->name
,
14987 &n
->proc_name
->declared_at
);
14993 gfc_do_concurrent_flag
= 0;
14994 gfc_check_interfaces (ns
);
14996 gfc_traverse_ns (ns
, resolve_values
);
15002 for (d
= ns
->data
; d
; d
= d
->next
)
15006 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
15008 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
15010 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
15011 resolve_equivalence (eq
);
15013 /* Warn about unused labels. */
15014 if (warn_unused_label
)
15015 warn_unused_fortran_label (ns
->st_labels
);
15017 gfc_resolve_uops (ns
->uop_root
);
15019 gfc_resolve_omp_declare_simd (ns
);
15021 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
15023 ns
->types_resolved
= 1;
15025 gfc_current_ns
= old_ns
;
15029 /* Call gfc_resolve_code recursively. */
15032 resolve_codes (gfc_namespace
*ns
)
15035 bitmap_obstack old_obstack
;
15037 if (ns
->resolved
== 1)
15040 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15043 gfc_current_ns
= ns
;
15045 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15046 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
15049 /* Set to an out of range value. */
15050 current_entry_id
= -1;
15052 old_obstack
= labels_obstack
;
15053 bitmap_obstack_initialize (&labels_obstack
);
15055 gfc_resolve_oacc_declare (ns
);
15056 gfc_resolve_code (ns
->code
, ns
);
15058 bitmap_obstack_release (&labels_obstack
);
15059 labels_obstack
= old_obstack
;
15063 /* This function is called after a complete program unit has been compiled.
15064 Its purpose is to examine all of the expressions associated with a program
15065 unit, assign types to all intermediate expressions, make sure that all
15066 assignments are to compatible types and figure out which names refer to
15067 which functions or subroutines. */
15070 gfc_resolve (gfc_namespace
*ns
)
15072 gfc_namespace
*old_ns
;
15073 code_stack
*old_cs_base
;
15079 old_ns
= gfc_current_ns
;
15080 old_cs_base
= cs_base
;
15082 resolve_types (ns
);
15083 component_assignment_level
= 0;
15084 resolve_codes (ns
);
15086 gfc_current_ns
= old_ns
;
15087 cs_base
= old_cs_base
;
15090 gfc_run_passes (ns
);