1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and gfc_resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 int gfc_do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type %qs used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface %qs at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface %qs at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface %qs at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure %qs not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "%qs at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "%qs at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "%qs at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
394 " of pure function %qs at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument %qs of pure function %qs at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
407 " of pure subroutine %qs at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument %qs of pure subroutine %qs at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
421 gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L"
422 " may not be polymorphic", sym
->name
, proc
->name
,
428 if (proc
->attr
.implicit_pure
)
430 if (sym
->attr
.flavor
== FL_PROCEDURE
)
433 proc
->attr
.implicit_pure
= 0;
435 else if (!sym
->attr
.pointer
)
437 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
439 proc
->attr
.implicit_pure
= 0;
441 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
443 proc
->attr
.implicit_pure
= 0;
447 if (gfc_elemental (proc
))
450 if (sym
->attr
.codimension
451 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
452 && CLASS_DATA (sym
)->attr
.codimension
))
454 gfc_error ("Coarray dummy argument %qs at %L to elemental "
455 "procedure", sym
->name
, &sym
->declared_at
);
459 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->as
))
462 gfc_error ("Argument %qs of elemental procedure at %L must "
463 "be scalar", sym
->name
, &sym
->declared_at
);
467 if (sym
->attr
.allocatable
468 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
469 && CLASS_DATA (sym
)->attr
.allocatable
))
471 gfc_error ("Argument %qs of elemental procedure at %L cannot "
472 "have the ALLOCATABLE attribute", sym
->name
,
477 if (sym
->attr
.pointer
478 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
479 && CLASS_DATA (sym
)->attr
.class_pointer
))
481 gfc_error ("Argument %qs of elemental procedure at %L cannot "
482 "have the POINTER attribute", sym
->name
,
487 if (sym
->attr
.flavor
== FL_PROCEDURE
)
489 gfc_error ("Dummy procedure %qs not allowed in elemental "
490 "procedure %qs at %L", sym
->name
, proc
->name
,
495 /* Fortran 2008 Corrigendum 1, C1290a. */
496 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
498 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
499 "have its INTENT specified or have the VALUE "
500 "attribute", sym
->name
, proc
->name
,
506 /* Each dummy shall be specified to be scalar. */
507 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
511 gfc_error ("Argument %qs of statement function at %L must "
512 "be scalar", sym
->name
, &sym
->declared_at
);
516 if (sym
->ts
.type
== BT_CHARACTER
)
518 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
519 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
521 gfc_error ("Character-valued argument %qs of statement "
522 "function at %L must have constant length",
523 sym
->name
, &sym
->declared_at
);
533 /* Work function called when searching for symbols that have argument lists
534 associated with them. */
537 find_arglists (gfc_symbol
*sym
)
539 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
540 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
543 resolve_formal_arglist (sym
);
547 /* Given a namespace, resolve all formal argument lists within the namespace.
551 resolve_formal_arglists (gfc_namespace
*ns
)
556 gfc_traverse_ns (ns
, find_arglists
);
561 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
565 /* If this namespace is not a function or an entry master function,
567 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
568 || sym
->attr
.entry_master
)
571 /* Try to find out of what the return type is. */
572 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
574 t
= gfc_set_default_type (sym
->result
, 0, ns
);
576 if (!t
&& !sym
->result
->attr
.untyped
)
578 if (sym
->result
== sym
)
579 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
580 sym
->name
, &sym
->declared_at
);
581 else if (!sym
->result
->attr
.proc_pointer
)
582 gfc_error ("Result %qs of contained function %qs at %L has "
583 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
584 &sym
->result
->declared_at
);
585 sym
->result
->attr
.untyped
= 1;
589 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
590 type, lists the only ways a character length value of * can be used:
591 dummy arguments of procedures, named constants, and function results
592 in external functions. Internal function results and results of module
593 procedures are not on this list, ergo, not permitted. */
595 if (sym
->result
->ts
.type
== BT_CHARACTER
)
597 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
598 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
600 /* See if this is a module-procedure and adapt error message
603 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
604 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
606 gfc_error ("Character-valued %s %qs at %L must not be"
608 module_proc
? _("module procedure")
609 : _("internal function"),
610 sym
->name
, &sym
->declared_at
);
616 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
617 introduce duplicates. */
620 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
622 gfc_formal_arglist
*f
, *new_arglist
;
625 for (; new_args
!= NULL
; new_args
= new_args
->next
)
627 new_sym
= new_args
->sym
;
628 /* See if this arg is already in the formal argument list. */
629 for (f
= proc
->formal
; f
; f
= f
->next
)
631 if (new_sym
== f
->sym
)
638 /* Add a new argument. Argument order is not important. */
639 new_arglist
= gfc_get_formal_arglist ();
640 new_arglist
->sym
= new_sym
;
641 new_arglist
->next
= proc
->formal
;
642 proc
->formal
= new_arglist
;
647 /* Flag the arguments that are not present in all entries. */
650 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
652 gfc_formal_arglist
*f
, *head
;
655 for (f
= proc
->formal
; f
; f
= f
->next
)
660 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
662 if (new_args
->sym
== f
->sym
)
669 f
->sym
->attr
.not_always_present
= 1;
674 /* Resolve alternate entry points. If a symbol has multiple entry points we
675 create a new master symbol for the main routine, and turn the existing
676 symbol into an entry point. */
679 resolve_entries (gfc_namespace
*ns
)
681 gfc_namespace
*old_ns
;
685 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
686 static int master_count
= 0;
688 if (ns
->proc_name
== NULL
)
691 /* No need to do anything if this procedure doesn't have alternate entry
696 /* We may already have resolved alternate entry points. */
697 if (ns
->proc_name
->attr
.entry_master
)
700 /* If this isn't a procedure something has gone horribly wrong. */
701 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
703 /* Remember the current namespace. */
704 old_ns
= gfc_current_ns
;
708 /* Add the main entry point to the list of entry points. */
709 el
= gfc_get_entry_list ();
710 el
->sym
= ns
->proc_name
;
712 el
->next
= ns
->entries
;
714 ns
->proc_name
->attr
.entry
= 1;
716 /* If it is a module function, it needs to be in the right namespace
717 so that gfc_get_fake_result_decl can gather up the results. The
718 need for this arose in get_proc_name, where these beasts were
719 left in their own namespace, to keep prior references linked to
720 the entry declaration.*/
721 if (ns
->proc_name
->attr
.function
722 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
725 /* Do the same for entries where the master is not a module
726 procedure. These are retained in the module namespace because
727 of the module procedure declaration. */
728 for (el
= el
->next
; el
; el
= el
->next
)
729 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
730 && el
->sym
->attr
.mod_proc
)
734 /* Add an entry statement for it. */
735 c
= gfc_get_code (EXEC_ENTRY
);
740 /* Create a new symbol for the master function. */
741 /* Give the internal function a unique name (within this file).
742 Also include the function name so the user has some hope of figuring
743 out what is going on. */
744 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
745 master_count
++, ns
->proc_name
->name
);
746 gfc_get_ha_symbol (name
, &proc
);
747 gcc_assert (proc
!= NULL
);
749 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
750 if (ns
->proc_name
->attr
.subroutine
)
751 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
755 gfc_typespec
*ts
, *fts
;
756 gfc_array_spec
*as
, *fas
;
757 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
759 fas
= ns
->entries
->sym
->as
;
760 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
761 fts
= &ns
->entries
->sym
->result
->ts
;
762 if (fts
->type
== BT_UNKNOWN
)
763 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
764 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
766 ts
= &el
->sym
->result
->ts
;
768 as
= as
? as
: el
->sym
->result
->as
;
769 if (ts
->type
== BT_UNKNOWN
)
770 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
772 if (! gfc_compare_types (ts
, fts
)
773 || (el
->sym
->result
->attr
.dimension
774 != ns
->entries
->sym
->result
->attr
.dimension
)
775 || (el
->sym
->result
->attr
.pointer
776 != ns
->entries
->sym
->result
->attr
.pointer
))
778 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
779 && gfc_compare_array_spec (as
, fas
) == 0)
780 gfc_error ("Function %s at %L has entries with mismatched "
781 "array specifications", ns
->entries
->sym
->name
,
782 &ns
->entries
->sym
->declared_at
);
783 /* The characteristics need to match and thus both need to have
784 the same string length, i.e. both len=*, or both len=4.
785 Having both len=<variable> is also possible, but difficult to
786 check at compile time. */
787 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
788 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
789 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
791 && ts
->u
.cl
->length
->expr_type
792 != fts
->u
.cl
->length
->expr_type
)
794 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
795 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
796 fts
->u
.cl
->length
->value
.integer
) != 0)))
797 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
798 "entries returning variables of different "
799 "string lengths", ns
->entries
->sym
->name
,
800 &ns
->entries
->sym
->declared_at
);
805 sym
= ns
->entries
->sym
->result
;
806 /* All result types the same. */
808 if (sym
->attr
.dimension
)
809 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
810 if (sym
->attr
.pointer
)
811 gfc_add_pointer (&proc
->attr
, NULL
);
815 /* Otherwise the result will be passed through a union by
817 proc
->attr
.mixed_entry_master
= 1;
818 for (el
= ns
->entries
; el
; el
= el
->next
)
820 sym
= el
->sym
->result
;
821 if (sym
->attr
.dimension
)
823 if (el
== ns
->entries
)
824 gfc_error ("FUNCTION result %s can't be an array in "
825 "FUNCTION %s at %L", sym
->name
,
826 ns
->entries
->sym
->name
, &sym
->declared_at
);
828 gfc_error ("ENTRY result %s can't be an array in "
829 "FUNCTION %s at %L", sym
->name
,
830 ns
->entries
->sym
->name
, &sym
->declared_at
);
832 else if (sym
->attr
.pointer
)
834 if (el
== ns
->entries
)
835 gfc_error ("FUNCTION result %s can't be a POINTER in "
836 "FUNCTION %s at %L", sym
->name
,
837 ns
->entries
->sym
->name
, &sym
->declared_at
);
839 gfc_error ("ENTRY result %s can't be a POINTER in "
840 "FUNCTION %s at %L", sym
->name
,
841 ns
->entries
->sym
->name
, &sym
->declared_at
);
846 if (ts
->type
== BT_UNKNOWN
)
847 ts
= gfc_get_default_type (sym
->name
, NULL
);
851 if (ts
->kind
== gfc_default_integer_kind
)
855 if (ts
->kind
== gfc_default_real_kind
856 || ts
->kind
== gfc_default_double_kind
)
860 if (ts
->kind
== gfc_default_complex_kind
)
864 if (ts
->kind
== gfc_default_logical_kind
)
868 /* We will issue error elsewhere. */
876 if (el
== ns
->entries
)
877 gfc_error ("FUNCTION result %s can't be of type %s "
878 "in FUNCTION %s at %L", sym
->name
,
879 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 gfc_error ("ENTRY result %s can't be of type %s "
883 "in FUNCTION %s at %L", sym
->name
,
884 gfc_typename (ts
), ns
->entries
->sym
->name
,
891 proc
->attr
.access
= ACCESS_PRIVATE
;
892 proc
->attr
.entry_master
= 1;
894 /* Merge all the entry point arguments. */
895 for (el
= ns
->entries
; el
; el
= el
->next
)
896 merge_argument_lists (proc
, el
->sym
->formal
);
898 /* Check the master formal arguments for any that are not
899 present in all entry points. */
900 for (el
= ns
->entries
; el
; el
= el
->next
)
901 check_argument_lists (proc
, el
->sym
->formal
);
903 /* Use the master function for the function body. */
904 ns
->proc_name
= proc
;
906 /* Finalize the new symbols. */
907 gfc_commit_symbols ();
909 /* Restore the original namespace. */
910 gfc_current_ns
= old_ns
;
914 /* Resolve common variables. */
916 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
918 gfc_symbol
*csym
= sym
;
920 for (; csym
; csym
= csym
->common_next
)
922 if (csym
->value
|| csym
->attr
.data
)
924 if (!csym
->ns
->is_block_data
)
925 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
926 "but only in BLOCK DATA initialization is "
927 "allowed", csym
->name
, &csym
->declared_at
);
928 else if (!named_common
)
929 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
930 "in a blank COMMON but initialization is only "
931 "allowed in named common blocks", csym
->name
,
935 if (UNLIMITED_POLY (csym
))
936 gfc_error_now ("%qs in cannot appear in COMMON at %L "
937 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
939 if (csym
->ts
.type
!= BT_DERIVED
)
942 if (!(csym
->ts
.u
.derived
->attr
.sequence
943 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
944 gfc_error_now ("Derived type variable %qs in COMMON at %L "
945 "has neither the SEQUENCE nor the BIND(C) "
946 "attribute", csym
->name
, &csym
->declared_at
);
947 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
948 gfc_error_now ("Derived type variable %qs in COMMON at %L "
949 "has an ultimate component that is "
950 "allocatable", csym
->name
, &csym
->declared_at
);
951 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
952 gfc_error_now ("Derived type variable %qs in COMMON at %L "
953 "may not have default initializer", csym
->name
,
956 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
957 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
961 /* Resolve common blocks. */
963 resolve_common_blocks (gfc_symtree
*common_root
)
968 if (common_root
== NULL
)
971 if (common_root
->left
)
972 resolve_common_blocks (common_root
->left
);
973 if (common_root
->right
)
974 resolve_common_blocks (common_root
->right
);
976 resolve_common_vars (common_root
->n
.common
->head
, true);
978 /* The common name is a global name - in Fortran 2003 also if it has a
979 C binding name, since Fortran 2008 only the C binding name is a global
981 if (!common_root
->n
.common
->binding_label
982 || gfc_notification_std (GFC_STD_F2008
))
984 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
985 common_root
->n
.common
->name
);
987 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
988 && gsym
->type
== GSYM_COMMON
989 && ((common_root
->n
.common
->binding_label
990 && (!gsym
->binding_label
991 || strcmp (common_root
->n
.common
->binding_label
,
992 gsym
->binding_label
) != 0))
993 || (!common_root
->n
.common
->binding_label
994 && gsym
->binding_label
)))
996 gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global "
997 "identifier and must thus have the same binding name "
998 "as the same-named COMMON block at %L: %s vs %s",
999 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1001 common_root
->n
.common
->binding_label
1002 ? common_root
->n
.common
->binding_label
: "(blank)",
1003 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
1008 && !common_root
->n
.common
->binding_label
)
1010 gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier "
1012 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1016 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1018 gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at "
1019 "%L sharing the identifier with global non-COMMON-block "
1020 "entity at %L", common_root
->n
.common
->name
,
1021 &common_root
->n
.common
->where
, &gsym
->where
);
1026 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1027 gsym
->type
= GSYM_COMMON
;
1028 gsym
->where
= common_root
->n
.common
->where
;
1034 if (common_root
->n
.common
->binding_label
)
1036 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1037 common_root
->n
.common
->binding_label
);
1038 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1040 gfc_error_1 ("COMMON block at %L with binding label %s uses the same "
1041 "global identifier as entity at %L",
1042 &common_root
->n
.common
->where
,
1043 common_root
->n
.common
->binding_label
, &gsym
->where
);
1048 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1049 gsym
->type
= GSYM_COMMON
;
1050 gsym
->where
= common_root
->n
.common
->where
;
1056 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1060 if (sym
->attr
.flavor
== FL_PARAMETER
)
1061 gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L",
1062 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1064 if (sym
->attr
.external
)
1065 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1066 sym
->name
, &common_root
->n
.common
->where
);
1068 if (sym
->attr
.intrinsic
)
1069 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1070 sym
->name
, &common_root
->n
.common
->where
);
1071 else if (sym
->attr
.result
1072 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1073 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1074 "that is also a function result", sym
->name
,
1075 &common_root
->n
.common
->where
);
1076 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1077 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1078 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1079 "that is also a global procedure", sym
->name
,
1080 &common_root
->n
.common
->where
);
1084 /* Resolve contained function types. Because contained functions can call one
1085 another, they have to be worked out before any of the contained procedures
1088 The good news is that if a function doesn't already have a type, the only
1089 way it can get one is through an IMPLICIT type or a RESULT variable, because
1090 by definition contained functions are contained namespace they're contained
1091 in, not in a sibling or parent namespace. */
1094 resolve_contained_functions (gfc_namespace
*ns
)
1096 gfc_namespace
*child
;
1099 resolve_formal_arglists (ns
);
1101 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1103 /* Resolve alternate entry points first. */
1104 resolve_entries (child
);
1106 /* Then check function return types. */
1107 resolve_contained_fntype (child
->proc_name
, child
);
1108 for (el
= child
->entries
; el
; el
= el
->next
)
1109 resolve_contained_fntype (el
->sym
, child
);
1114 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1117 /* Resolve all of the elements of a structure constructor and make sure that
1118 the types are correct. The 'init' flag indicates that the given
1119 constructor is an initializer. */
1122 resolve_structure_cons (gfc_expr
*expr
, int init
)
1124 gfc_constructor
*cons
;
1125 gfc_component
*comp
;
1131 if (expr
->ts
.type
== BT_DERIVED
)
1132 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1134 cons
= gfc_constructor_first (expr
->value
.constructor
);
1136 /* A constructor may have references if it is the result of substituting a
1137 parameter variable. In this case we just pull out the component we
1140 comp
= expr
->ref
->u
.c
.sym
->components
;
1142 comp
= expr
->ts
.u
.derived
->components
;
1144 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1151 if (!gfc_resolve_expr (cons
->expr
))
1157 rank
= comp
->as
? comp
->as
->rank
: 0;
1158 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1159 rank
= CLASS_DATA (comp
)->as
->rank
;
1161 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1162 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1164 gfc_error ("The rank of the element in the structure "
1165 "constructor at %L does not match that of the "
1166 "component (%d/%d)", &cons
->expr
->where
,
1167 cons
->expr
->rank
, rank
);
1171 /* If we don't have the right type, try to convert it. */
1173 if (!comp
->attr
.proc_pointer
&&
1174 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1176 if (strcmp (comp
->name
, "_extends") == 0)
1178 /* Can afford to be brutal with the _extends initializer.
1179 The derived type can get lost because it is PRIVATE
1180 but it is not usage constrained by the standard. */
1181 cons
->expr
->ts
= comp
->ts
;
1183 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1185 gfc_error ("The element in the structure constructor at %L, "
1186 "for pointer component %qs, is %s but should be %s",
1187 &cons
->expr
->where
, comp
->name
,
1188 gfc_basic_typename (cons
->expr
->ts
.type
),
1189 gfc_basic_typename (comp
->ts
.type
));
1194 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1200 /* For strings, the length of the constructor should be the same as
1201 the one of the structure, ensure this if the lengths are known at
1202 compile time and when we are dealing with PARAMETER or structure
1204 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1205 && comp
->ts
.u
.cl
->length
1206 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1207 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1208 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1209 && cons
->expr
->rank
!= 0
1210 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1211 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1213 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1214 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1216 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1217 to make use of the gfc_resolve_character_array_constructor
1218 machinery. The expression is later simplified away to
1219 an array of string literals. */
1220 gfc_expr
*para
= cons
->expr
;
1221 cons
->expr
= gfc_get_expr ();
1222 cons
->expr
->ts
= para
->ts
;
1223 cons
->expr
->where
= para
->where
;
1224 cons
->expr
->expr_type
= EXPR_ARRAY
;
1225 cons
->expr
->rank
= para
->rank
;
1226 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1227 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1228 para
, &cons
->expr
->where
);
1230 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1233 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1234 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1236 gfc_charlen
*cl
, *cl2
;
1239 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1241 if (cl
== cons
->expr
->ts
.u
.cl
)
1249 cl2
->next
= cl
->next
;
1251 gfc_free_expr (cl
->length
);
1255 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1256 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1257 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1258 gfc_resolve_character_array_constructor (cons
->expr
);
1262 if (cons
->expr
->expr_type
== EXPR_NULL
1263 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1264 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1265 || (comp
->ts
.type
== BT_CLASS
1266 && (CLASS_DATA (comp
)->attr
.class_pointer
1267 || CLASS_DATA (comp
)->attr
.allocatable
))))
1270 gfc_error ("The NULL in the structure constructor at %L is "
1271 "being applied to component %qs, which is neither "
1272 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1276 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1278 /* Check procedure pointer interface. */
1279 gfc_symbol
*s2
= NULL
;
1284 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1287 s2
= c2
->ts
.interface
;
1290 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1292 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1293 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1295 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1297 s2
= cons
->expr
->symtree
->n
.sym
;
1298 name
= cons
->expr
->symtree
->n
.sym
->name
;
1301 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1302 err
, sizeof (err
), NULL
, NULL
))
1304 gfc_error ("Interface mismatch for procedure-pointer component "
1305 "%qs in structure constructor at %L: %s",
1306 comp
->name
, &cons
->expr
->where
, err
);
1311 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1312 || cons
->expr
->expr_type
== EXPR_NULL
)
1315 a
= gfc_expr_attr (cons
->expr
);
1317 if (!a
.pointer
&& !a
.target
)
1320 gfc_error ("The element in the structure constructor at %L, "
1321 "for pointer component %qs should be a POINTER or "
1322 "a TARGET", &cons
->expr
->where
, comp
->name
);
1327 /* F08:C461. Additional checks for pointer initialization. */
1331 gfc_error ("Pointer initialization target at %L "
1332 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1337 gfc_error ("Pointer initialization target at %L "
1338 "must have the SAVE attribute", &cons
->expr
->where
);
1342 /* F2003, C1272 (3). */
1343 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1344 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1345 || gfc_is_coindexed (cons
->expr
));
1346 if (impure
&& gfc_pure (NULL
))
1349 gfc_error ("Invalid expression in the structure constructor for "
1350 "pointer component %qs at %L in PURE procedure",
1351 comp
->name
, &cons
->expr
->where
);
1355 gfc_unset_implicit_pure (NULL
);
1362 /****************** Expression name resolution ******************/
1364 /* Returns 0 if a symbol was not declared with a type or
1365 attribute declaration statement, nonzero otherwise. */
1368 was_declared (gfc_symbol
*sym
)
1374 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1377 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1378 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1379 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1380 || a
.asynchronous
|| a
.codimension
)
1387 /* Determine if a symbol is generic or not. */
1390 generic_sym (gfc_symbol
*sym
)
1394 if (sym
->attr
.generic
||
1395 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1398 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1401 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1408 return generic_sym (s
);
1415 /* Determine if a symbol is specific or not. */
1418 specific_sym (gfc_symbol
*sym
)
1422 if (sym
->attr
.if_source
== IFSRC_IFBODY
1423 || sym
->attr
.proc
== PROC_MODULE
1424 || sym
->attr
.proc
== PROC_INTERNAL
1425 || sym
->attr
.proc
== PROC_ST_FUNCTION
1426 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1427 || sym
->attr
.external
)
1430 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1433 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1435 return (s
== NULL
) ? 0 : specific_sym (s
);
1439 /* Figure out if the procedure is specific, generic or unknown. */
1442 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1446 procedure_kind (gfc_symbol
*sym
)
1448 if (generic_sym (sym
))
1449 return PTYPE_GENERIC
;
1451 if (specific_sym (sym
))
1452 return PTYPE_SPECIFIC
;
1454 return PTYPE_UNKNOWN
;
1457 /* Check references to assumed size arrays. The flag need_full_assumed_size
1458 is nonzero when matching actual arguments. */
1460 static int need_full_assumed_size
= 0;
1463 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1465 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1468 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1469 What should it be? */
1470 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1471 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1472 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1474 gfc_error ("The upper bound in the last dimension must "
1475 "appear in the reference to the assumed size "
1476 "array %qs at %L", sym
->name
, &e
->where
);
1483 /* Look for bad assumed size array references in argument expressions
1484 of elemental and array valued intrinsic procedures. Since this is
1485 called from procedure resolution functions, it only recurses at
1489 resolve_assumed_size_actual (gfc_expr
*e
)
1494 switch (e
->expr_type
)
1497 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1502 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1503 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1514 /* Check a generic procedure, passed as an actual argument, to see if
1515 there is a matching specific name. If none, it is an error, and if
1516 more than one, the reference is ambiguous. */
1518 count_specific_procs (gfc_expr
*e
)
1525 sym
= e
->symtree
->n
.sym
;
1527 for (p
= sym
->generic
; p
; p
= p
->next
)
1528 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1530 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1536 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1540 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1541 "argument at %L", sym
->name
, &e
->where
);
1547 /* See if a call to sym could possibly be a not allowed RECURSION because of
1548 a missing RECURSIVE declaration. This means that either sym is the current
1549 context itself, or sym is the parent of a contained procedure calling its
1550 non-RECURSIVE containing procedure.
1551 This also works if sym is an ENTRY. */
1554 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1556 gfc_symbol
* proc_sym
;
1557 gfc_symbol
* context_proc
;
1558 gfc_namespace
* real_context
;
1560 if (sym
->attr
.flavor
== FL_PROGRAM
1561 || sym
->attr
.flavor
== FL_DERIVED
)
1564 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1566 /* If we've got an ENTRY, find real procedure. */
1567 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1568 proc_sym
= sym
->ns
->entries
->sym
;
1572 /* If sym is RECURSIVE, all is well of course. */
1573 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1576 /* Find the context procedure's "real" symbol if it has entries.
1577 We look for a procedure symbol, so recurse on the parents if we don't
1578 find one (like in case of a BLOCK construct). */
1579 for (real_context
= context
; ; real_context
= real_context
->parent
)
1581 /* We should find something, eventually! */
1582 gcc_assert (real_context
);
1584 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1585 : real_context
->proc_name
);
1587 /* In some special cases, there may not be a proc_name, like for this
1589 real(bad_kind()) function foo () ...
1590 when checking the call to bad_kind ().
1591 In these cases, we simply return here and assume that the
1596 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1600 /* A call from sym's body to itself is recursion, of course. */
1601 if (context_proc
== proc_sym
)
1604 /* The same is true if context is a contained procedure and sym the
1606 if (context_proc
->attr
.contained
)
1608 gfc_symbol
* parent_proc
;
1610 gcc_assert (context
->parent
);
1611 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1612 : context
->parent
->proc_name
);
1614 if (parent_proc
== proc_sym
)
1622 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1623 its typespec and formal argument list. */
1626 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1628 gfc_intrinsic_sym
* isym
= NULL
;
1634 /* Already resolved. */
1635 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1638 /* We already know this one is an intrinsic, so we don't call
1639 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1640 gfc_find_subroutine directly to check whether it is a function or
1643 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1645 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1646 isym
= gfc_intrinsic_subroutine_by_id (id
);
1648 else if (sym
->intmod_sym_id
)
1650 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1651 isym
= gfc_intrinsic_function_by_id (id
);
1653 else if (!sym
->attr
.subroutine
)
1654 isym
= gfc_find_function (sym
->name
);
1656 if (isym
&& !sym
->attr
.subroutine
)
1658 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1659 && !sym
->attr
.implicit_type
)
1660 gfc_warning (OPT_Wsurprising
,
1661 "Type specified for intrinsic function %qs at %L is"
1662 " ignored", sym
->name
, &sym
->declared_at
);
1664 if (!sym
->attr
.function
&&
1665 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1670 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1672 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1674 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1675 " specifier", sym
->name
, &sym
->declared_at
);
1679 if (!sym
->attr
.subroutine
&&
1680 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1685 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1690 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1692 sym
->attr
.pure
= isym
->pure
;
1693 sym
->attr
.elemental
= isym
->elemental
;
1695 /* Check it is actually available in the standard settings. */
1696 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1698 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1699 "available in the current standard settings but %s. Use "
1700 "an appropriate %<-std=*%> option or enable "
1701 "%<-fall-intrinsics%> in order to use it.",
1702 sym
->name
, &sym
->declared_at
, symstd
);
1710 /* Resolve a procedure expression, like passing it to a called procedure or as
1711 RHS for a procedure pointer assignment. */
1714 resolve_procedure_expression (gfc_expr
* expr
)
1718 if (expr
->expr_type
!= EXPR_VARIABLE
)
1720 gcc_assert (expr
->symtree
);
1722 sym
= expr
->symtree
->n
.sym
;
1724 if (sym
->attr
.intrinsic
)
1725 gfc_resolve_intrinsic (sym
, &expr
->where
);
1727 if (sym
->attr
.flavor
!= FL_PROCEDURE
1728 || (sym
->attr
.function
&& sym
->result
== sym
))
1731 /* A non-RECURSIVE procedure that is used as procedure expression within its
1732 own body is in danger of being called recursively. */
1733 if (is_illegal_recursion (sym
, gfc_current_ns
))
1734 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1735 " itself recursively. Declare it RECURSIVE or use"
1736 " %<-frecursive%>", sym
->name
, &expr
->where
);
1742 /* Resolve an actual argument list. Most of the time, this is just
1743 resolving the expressions in the list.
1744 The exception is that we sometimes have to decide whether arguments
1745 that look like procedure arguments are really simple variable
1749 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1750 bool no_formal_args
)
1753 gfc_symtree
*parent_st
;
1755 gfc_component
*comp
;
1756 int save_need_full_assumed_size
;
1757 bool return_value
= false;
1758 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1761 first_actual_arg
= true;
1763 for (; arg
; arg
= arg
->next
)
1768 /* Check the label is a valid branching target. */
1771 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1773 gfc_error ("Label %d referenced at %L is never defined",
1774 arg
->label
->value
, &arg
->label
->where
);
1778 first_actual_arg
= false;
1782 if (e
->expr_type
== EXPR_VARIABLE
1783 && e
->symtree
->n
.sym
->attr
.generic
1785 && count_specific_procs (e
) != 1)
1788 if (e
->ts
.type
!= BT_PROCEDURE
)
1790 save_need_full_assumed_size
= need_full_assumed_size
;
1791 if (e
->expr_type
!= EXPR_VARIABLE
)
1792 need_full_assumed_size
= 0;
1793 if (!gfc_resolve_expr (e
))
1795 need_full_assumed_size
= save_need_full_assumed_size
;
1799 /* See if the expression node should really be a variable reference. */
1801 sym
= e
->symtree
->n
.sym
;
1803 if (sym
->attr
.flavor
== FL_PROCEDURE
1804 || sym
->attr
.intrinsic
1805 || sym
->attr
.external
)
1809 /* If a procedure is not already determined to be something else
1810 check if it is intrinsic. */
1811 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1812 sym
->attr
.intrinsic
= 1;
1814 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1816 gfc_error ("Statement function %qs at %L is not allowed as an "
1817 "actual argument", sym
->name
, &e
->where
);
1820 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1821 sym
->attr
.subroutine
);
1822 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1824 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1825 "actual argument", sym
->name
, &e
->where
);
1828 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1829 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1831 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1832 " used as actual argument at %L",
1833 sym
->name
, &e
->where
))
1837 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1839 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1840 "allowed as an actual argument at %L", sym
->name
,
1844 /* Check if a generic interface has a specific procedure
1845 with the same name before emitting an error. */
1846 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1849 /* Just in case a specific was found for the expression. */
1850 sym
= e
->symtree
->n
.sym
;
1852 /* If the symbol is the function that names the current (or
1853 parent) scope, then we really have a variable reference. */
1855 if (gfc_is_function_return_value (sym
, sym
->ns
))
1858 /* If all else fails, see if we have a specific intrinsic. */
1859 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1861 gfc_intrinsic_sym
*isym
;
1863 isym
= gfc_find_function (sym
->name
);
1864 if (isym
== NULL
|| !isym
->specific
)
1866 gfc_error ("Unable to find a specific INTRINSIC procedure "
1867 "for the reference %qs at %L", sym
->name
,
1872 sym
->attr
.intrinsic
= 1;
1873 sym
->attr
.function
= 1;
1876 if (!gfc_resolve_expr (e
))
1881 /* See if the name is a module procedure in a parent unit. */
1883 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1886 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1888 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1892 if (parent_st
== NULL
)
1895 sym
= parent_st
->n
.sym
;
1896 e
->symtree
= parent_st
; /* Point to the right thing. */
1898 if (sym
->attr
.flavor
== FL_PROCEDURE
1899 || sym
->attr
.intrinsic
1900 || sym
->attr
.external
)
1902 if (!gfc_resolve_expr (e
))
1908 e
->expr_type
= EXPR_VARIABLE
;
1910 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1911 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1912 && CLASS_DATA (sym
)->as
))
1914 e
->rank
= sym
->ts
.type
== BT_CLASS
1915 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1916 e
->ref
= gfc_get_ref ();
1917 e
->ref
->type
= REF_ARRAY
;
1918 e
->ref
->u
.ar
.type
= AR_FULL
;
1919 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1920 ? CLASS_DATA (sym
)->as
: sym
->as
;
1923 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1924 primary.c (match_actual_arg). If above code determines that it
1925 is a variable instead, it needs to be resolved as it was not
1926 done at the beginning of this function. */
1927 save_need_full_assumed_size
= need_full_assumed_size
;
1928 if (e
->expr_type
!= EXPR_VARIABLE
)
1929 need_full_assumed_size
= 0;
1930 if (!gfc_resolve_expr (e
))
1932 need_full_assumed_size
= save_need_full_assumed_size
;
1935 /* Check argument list functions %VAL, %LOC and %REF. There is
1936 nothing to do for %REF. */
1937 if (arg
->name
&& arg
->name
[0] == '%')
1939 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1941 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1943 gfc_error ("By-value argument at %L is not of numeric "
1950 gfc_error ("By-value argument at %L cannot be an array or "
1951 "an array section", &e
->where
);
1955 /* Intrinsics are still PROC_UNKNOWN here. However,
1956 since same file external procedures are not resolvable
1957 in gfortran, it is a good deal easier to leave them to
1959 if (ptype
!= PROC_UNKNOWN
1960 && ptype
!= PROC_DUMMY
1961 && ptype
!= PROC_EXTERNAL
1962 && ptype
!= PROC_MODULE
)
1964 gfc_error ("By-value argument at %L is not allowed "
1965 "in this context", &e
->where
);
1970 /* Statement functions have already been excluded above. */
1971 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1972 && e
->ts
.type
== BT_PROCEDURE
)
1974 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1976 gfc_error ("Passing internal procedure at %L by location "
1977 "not allowed", &e
->where
);
1983 comp
= gfc_get_proc_ptr_comp(e
);
1984 if (comp
&& comp
->attr
.elemental
)
1986 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1987 "allowed as an actual argument at %L", comp
->name
,
1991 /* Fortran 2008, C1237. */
1992 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1993 && gfc_has_ultimate_pointer (e
))
1995 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1996 "component", &e
->where
);
2000 first_actual_arg
= false;
2003 return_value
= true;
2006 actual_arg
= actual_arg_sav
;
2007 first_actual_arg
= first_actual_arg_sav
;
2009 return return_value
;
2013 /* Do the checks of the actual argument list that are specific to elemental
2014 procedures. If called with c == NULL, we have a function, otherwise if
2015 expr == NULL, we have a subroutine. */
2018 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2020 gfc_actual_arglist
*arg0
;
2021 gfc_actual_arglist
*arg
;
2022 gfc_symbol
*esym
= NULL
;
2023 gfc_intrinsic_sym
*isym
= NULL
;
2025 gfc_intrinsic_arg
*iformal
= NULL
;
2026 gfc_formal_arglist
*eformal
= NULL
;
2027 bool formal_optional
= false;
2028 bool set_by_optional
= false;
2032 /* Is this an elemental procedure? */
2033 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2035 if (expr
->value
.function
.esym
!= NULL
2036 && expr
->value
.function
.esym
->attr
.elemental
)
2038 arg0
= expr
->value
.function
.actual
;
2039 esym
= expr
->value
.function
.esym
;
2041 else if (expr
->value
.function
.isym
!= NULL
2042 && expr
->value
.function
.isym
->elemental
)
2044 arg0
= expr
->value
.function
.actual
;
2045 isym
= expr
->value
.function
.isym
;
2050 else if (c
&& c
->ext
.actual
!= NULL
)
2052 arg0
= c
->ext
.actual
;
2054 if (c
->resolved_sym
)
2055 esym
= c
->resolved_sym
;
2057 esym
= c
->symtree
->n
.sym
;
2060 if (!esym
->attr
.elemental
)
2066 /* The rank of an elemental is the rank of its array argument(s). */
2067 for (arg
= arg0
; arg
; arg
= arg
->next
)
2069 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2071 rank
= arg
->expr
->rank
;
2072 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2073 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2074 set_by_optional
= true;
2076 /* Function specific; set the result rank and shape. */
2080 if (!expr
->shape
&& arg
->expr
->shape
)
2082 expr
->shape
= gfc_get_shape (rank
);
2083 for (i
= 0; i
< rank
; i
++)
2084 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2091 /* If it is an array, it shall not be supplied as an actual argument
2092 to an elemental procedure unless an array of the same rank is supplied
2093 as an actual argument corresponding to a nonoptional dummy argument of
2094 that elemental procedure(12.4.1.5). */
2095 formal_optional
= false;
2097 iformal
= isym
->formal
;
2099 eformal
= esym
->formal
;
2101 for (arg
= arg0
; arg
; arg
= arg
->next
)
2105 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2106 formal_optional
= true;
2107 eformal
= eformal
->next
;
2109 else if (isym
&& iformal
)
2111 if (iformal
->optional
)
2112 formal_optional
= true;
2113 iformal
= iformal
->next
;
2116 formal_optional
= true;
2118 if (pedantic
&& arg
->expr
!= NULL
2119 && arg
->expr
->expr_type
== EXPR_VARIABLE
2120 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2123 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2124 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2126 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2127 "MISSING, it cannot be the actual argument of an "
2128 "ELEMENTAL procedure unless there is a non-optional "
2129 "argument with the same rank (12.4.1.5)",
2130 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2134 for (arg
= arg0
; arg
; arg
= arg
->next
)
2136 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2139 /* Being elemental, the last upper bound of an assumed size array
2140 argument must be present. */
2141 if (resolve_assumed_size_actual (arg
->expr
))
2144 /* Elemental procedure's array actual arguments must conform. */
2147 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2154 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2155 is an array, the intent inout/out variable needs to be also an array. */
2156 if (rank
> 0 && esym
&& expr
== NULL
)
2157 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2158 arg
= arg
->next
, eformal
= eformal
->next
)
2159 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2160 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2161 && arg
->expr
&& arg
->expr
->rank
== 0)
2163 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2164 "ELEMENTAL subroutine %qs is a scalar, but another "
2165 "actual argument is an array", &arg
->expr
->where
,
2166 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2167 : "INOUT", eformal
->sym
->name
, esym
->name
);
2174 /* This function does the checking of references to global procedures
2175 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2176 77 and 95 standards. It checks for a gsymbol for the name, making
2177 one if it does not already exist. If it already exists, then the
2178 reference being resolved must correspond to the type of gsymbol.
2179 Otherwise, the new symbol is equipped with the attributes of the
2180 reference. The corresponding code that is called in creating
2181 global entities is parse.c.
2183 In addition, for all but -std=legacy, the gsymbols are used to
2184 check the interfaces of external procedures from the same file.
2185 The namespace of the gsymbol is resolved and then, once this is
2186 done the interface is checked. */
2190 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2192 if (!gsym_ns
->proc_name
->attr
.recursive
)
2195 if (sym
->ns
== gsym_ns
)
2198 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2205 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2207 if (gsym_ns
->entries
)
2209 gfc_entry_list
*entry
= gsym_ns
->entries
;
2211 for (; entry
; entry
= entry
->next
)
2213 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2215 if (strcmp (gsym_ns
->proc_name
->name
,
2216 sym
->ns
->proc_name
->name
) == 0)
2220 && strcmp (gsym_ns
->proc_name
->name
,
2221 sym
->ns
->parent
->proc_name
->name
) == 0)
2230 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2233 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2235 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2237 for ( ; arg
; arg
= arg
->next
)
2242 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2244 strncpy (errmsg
, _("allocatable argument"), err_len
);
2247 else if (arg
->sym
->attr
.asynchronous
)
2249 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2252 else if (arg
->sym
->attr
.optional
)
2254 strncpy (errmsg
, _("optional argument"), err_len
);
2257 else if (arg
->sym
->attr
.pointer
)
2259 strncpy (errmsg
, _("pointer argument"), err_len
);
2262 else if (arg
->sym
->attr
.target
)
2264 strncpy (errmsg
, _("target argument"), err_len
);
2267 else if (arg
->sym
->attr
.value
)
2269 strncpy (errmsg
, _("value argument"), err_len
);
2272 else if (arg
->sym
->attr
.volatile_
)
2274 strncpy (errmsg
, _("volatile argument"), err_len
);
2277 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2279 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2282 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2284 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2287 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2289 strncpy (errmsg
, _("coarray argument"), err_len
);
2292 else if (false) /* (2d) TODO: parametrized derived type */
2294 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2297 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2299 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2302 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2304 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2307 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2309 /* As assumed-type is unlimited polymorphic (cf. above).
2310 See also TS 29113, Note 6.1. */
2311 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2316 if (sym
->attr
.function
)
2318 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2320 if (res
->attr
.dimension
) /* (3a) */
2322 strncpy (errmsg
, _("array result"), err_len
);
2325 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2327 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2330 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2331 && res
->ts
.u
.cl
->length
2332 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2334 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2339 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2341 strncpy (errmsg
, _("elemental procedure"), err_len
);
2344 else if (sym
->attr
.is_bind_c
) /* (5) */
2346 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2355 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2356 gfc_actual_arglist
**actual
, int sub
)
2360 enum gfc_symbol_type type
;
2363 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2365 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2367 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2368 gfc_global_used (gsym
, where
);
2370 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2371 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2372 && gsym
->type
!= GSYM_UNKNOWN
2373 && !gsym
->binding_label
2375 && gsym
->ns
->resolved
!= -1
2376 && gsym
->ns
->proc_name
2377 && not_in_recursive (sym
, gsym
->ns
)
2378 && not_entry_self_reference (sym
, gsym
->ns
))
2380 gfc_symbol
*def_sym
;
2382 /* Resolve the gsymbol namespace if needed. */
2383 if (!gsym
->ns
->resolved
)
2385 gfc_dt_list
*old_dt_list
;
2386 struct gfc_omp_saved_state old_omp_state
;
2388 /* Stash away derived types so that the backend_decls do not
2390 old_dt_list
= gfc_derived_types
;
2391 gfc_derived_types
= NULL
;
2392 /* And stash away openmp state. */
2393 gfc_omp_save_and_clear_state (&old_omp_state
);
2395 gfc_resolve (gsym
->ns
);
2397 /* Store the new derived types with the global namespace. */
2398 if (gfc_derived_types
)
2399 gsym
->ns
->derived_types
= gfc_derived_types
;
2401 /* Restore the derived types of this namespace. */
2402 gfc_derived_types
= old_dt_list
;
2403 /* And openmp state. */
2404 gfc_omp_restore_state (&old_omp_state
);
2407 /* Make sure that translation for the gsymbol occurs before
2408 the procedure currently being resolved. */
2409 ns
= gfc_global_ns_list
;
2410 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2412 if (ns
->sibling
== gsym
->ns
)
2414 ns
->sibling
= gsym
->ns
->sibling
;
2415 gsym
->ns
->sibling
= gfc_global_ns_list
;
2416 gfc_global_ns_list
= gsym
->ns
;
2421 def_sym
= gsym
->ns
->proc_name
;
2423 /* This can happen if a binding name has been specified. */
2424 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2425 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2427 if (def_sym
->attr
.entry_master
)
2429 gfc_entry_list
*entry
;
2430 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2431 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2433 def_sym
= entry
->sym
;
2438 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2440 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2441 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2442 gfc_typename (&def_sym
->ts
));
2446 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2447 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2449 gfc_error ("Explicit interface required for %qs at %L: %s",
2450 sym
->name
, &sym
->declared_at
, reason
);
2454 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2455 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2456 gfc_errors_to_warnings (true);
2458 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2459 reason
, sizeof(reason
), NULL
, NULL
))
2461 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2462 sym
->name
, &sym
->declared_at
, reason
);
2467 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2468 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2469 gfc_errors_to_warnings (true);
2471 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2472 gfc_procedure_use (def_sym
, actual
, where
);
2476 gfc_errors_to_warnings (false);
2478 if (gsym
->type
== GSYM_UNKNOWN
)
2481 gsym
->where
= *where
;
2488 /************* Function resolution *************/
2490 /* Resolve a function call known to be generic.
2491 Section 14.1.2.4.1. */
2494 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2498 if (sym
->attr
.generic
)
2500 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2503 expr
->value
.function
.name
= s
->name
;
2504 expr
->value
.function
.esym
= s
;
2506 if (s
->ts
.type
!= BT_UNKNOWN
)
2508 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2509 expr
->ts
= s
->result
->ts
;
2512 expr
->rank
= s
->as
->rank
;
2513 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2514 expr
->rank
= s
->result
->as
->rank
;
2516 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2521 /* TODO: Need to search for elemental references in generic
2525 if (sym
->attr
.intrinsic
)
2526 return gfc_intrinsic_func_interface (expr
, 0);
2533 resolve_generic_f (gfc_expr
*expr
)
2537 gfc_interface
*intr
= NULL
;
2539 sym
= expr
->symtree
->n
.sym
;
2543 m
= resolve_generic_f0 (expr
, sym
);
2546 else if (m
== MATCH_ERROR
)
2551 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2552 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2555 if (sym
->ns
->parent
== NULL
)
2557 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2561 if (!generic_sym (sym
))
2565 /* Last ditch attempt. See if the reference is to an intrinsic
2566 that possesses a matching interface. 14.1.2.4 */
2567 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2569 gfc_error ("There is no specific function for the generic %qs "
2570 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2576 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2579 return resolve_structure_cons (expr
, 0);
2582 m
= gfc_intrinsic_func_interface (expr
, 0);
2587 gfc_error ("Generic function %qs at %L is not consistent with a "
2588 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2595 /* Resolve a function call known to be specific. */
2598 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2602 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2604 if (sym
->attr
.dummy
)
2606 sym
->attr
.proc
= PROC_DUMMY
;
2610 sym
->attr
.proc
= PROC_EXTERNAL
;
2614 if (sym
->attr
.proc
== PROC_MODULE
2615 || sym
->attr
.proc
== PROC_ST_FUNCTION
2616 || sym
->attr
.proc
== PROC_INTERNAL
)
2619 if (sym
->attr
.intrinsic
)
2621 m
= gfc_intrinsic_func_interface (expr
, 1);
2625 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2626 "with an intrinsic", sym
->name
, &expr
->where
);
2634 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2637 expr
->ts
= sym
->result
->ts
;
2640 expr
->value
.function
.name
= sym
->name
;
2641 expr
->value
.function
.esym
= sym
;
2642 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2643 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2644 else if (sym
->as
!= NULL
)
2645 expr
->rank
= sym
->as
->rank
;
2652 resolve_specific_f (gfc_expr
*expr
)
2657 sym
= expr
->symtree
->n
.sym
;
2661 m
= resolve_specific_f0 (sym
, expr
);
2664 if (m
== MATCH_ERROR
)
2667 if (sym
->ns
->parent
== NULL
)
2670 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2676 gfc_error ("Unable to resolve the specific function %qs at %L",
2677 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2683 /* Resolve a procedure call not known to be generic nor specific. */
2686 resolve_unknown_f (gfc_expr
*expr
)
2691 sym
= expr
->symtree
->n
.sym
;
2693 if (sym
->attr
.dummy
)
2695 sym
->attr
.proc
= PROC_DUMMY
;
2696 expr
->value
.function
.name
= sym
->name
;
2700 /* See if we have an intrinsic function reference. */
2702 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2704 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2709 /* The reference is to an external name. */
2711 sym
->attr
.proc
= PROC_EXTERNAL
;
2712 expr
->value
.function
.name
= sym
->name
;
2713 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2715 if (sym
->as
!= NULL
)
2716 expr
->rank
= sym
->as
->rank
;
2718 /* Type of the expression is either the type of the symbol or the
2719 default type of the symbol. */
2722 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2724 if (sym
->ts
.type
!= BT_UNKNOWN
)
2728 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2730 if (ts
->type
== BT_UNKNOWN
)
2732 gfc_error ("Function %qs at %L has no IMPLICIT type",
2733 sym
->name
, &expr
->where
);
2744 /* Return true, if the symbol is an external procedure. */
2746 is_external_proc (gfc_symbol
*sym
)
2748 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2749 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2750 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2751 && !sym
->attr
.proc_pointer
2752 && !sym
->attr
.use_assoc
2760 /* Figure out if a function reference is pure or not. Also set the name
2761 of the function for a potential error message. Return nonzero if the
2762 function is PURE, zero if not. */
2764 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2767 pure_function (gfc_expr
*e
, const char **name
)
2770 gfc_component
*comp
;
2774 if (e
->symtree
!= NULL
2775 && e
->symtree
->n
.sym
!= NULL
2776 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2777 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2779 comp
= gfc_get_proc_ptr_comp (e
);
2782 pure
= gfc_pure (comp
->ts
.interface
);
2785 else if (e
->value
.function
.esym
)
2787 pure
= gfc_pure (e
->value
.function
.esym
);
2788 *name
= e
->value
.function
.esym
->name
;
2790 else if (e
->value
.function
.isym
)
2792 pure
= e
->value
.function
.isym
->pure
2793 || e
->value
.function
.isym
->elemental
;
2794 *name
= e
->value
.function
.isym
->name
;
2798 /* Implicit functions are not pure. */
2800 *name
= e
->value
.function
.name
;
2808 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2809 int *f ATTRIBUTE_UNUSED
)
2813 /* Don't bother recursing into other statement functions
2814 since they will be checked individually for purity. */
2815 if (e
->expr_type
!= EXPR_FUNCTION
2817 || e
->symtree
->n
.sym
== sym
2818 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2821 return pure_function (e
, &name
) ? false : true;
2826 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2828 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2832 /* Check if an impure function is allowed in the current context. */
2834 static bool check_pure_function (gfc_expr
*e
)
2836 const char *name
= NULL
;
2837 if (!pure_function (e
, &name
) && name
)
2841 gfc_error ("Reference to impure function %qs at %L inside a "
2842 "FORALL %s", name
, &e
->where
,
2843 forall_flag
== 2 ? "mask" : "block");
2846 else if (gfc_do_concurrent_flag
)
2848 gfc_error ("Reference to impure function %qs at %L inside a "
2849 "DO CONCURRENT %s", name
, &e
->where
,
2850 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2853 else if (gfc_pure (NULL
))
2855 gfc_error ("Reference to impure function %qs at %L "
2856 "within a PURE procedure", name
, &e
->where
);
2859 gfc_unset_implicit_pure (NULL
);
2865 /* Resolve a function call, which means resolving the arguments, then figuring
2866 out which entity the name refers to. */
2869 resolve_function (gfc_expr
*expr
)
2871 gfc_actual_arglist
*arg
;
2875 procedure_type p
= PROC_INTRINSIC
;
2876 bool no_formal_args
;
2880 sym
= expr
->symtree
->n
.sym
;
2882 /* If this is a procedure pointer component, it has already been resolved. */
2883 if (gfc_is_proc_ptr_comp (expr
))
2886 if (sym
&& sym
->attr
.intrinsic
2887 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2890 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2892 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2896 /* If this ia a deferred TBP with an abstract interface (which may
2897 of course be referenced), expr->value.function.esym will be set. */
2898 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2900 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2901 sym
->name
, &expr
->where
);
2905 /* Switch off assumed size checking and do this again for certain kinds
2906 of procedure, once the procedure itself is resolved. */
2907 need_full_assumed_size
++;
2909 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2910 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2912 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2913 inquiry_argument
= true;
2914 no_formal_args
= sym
&& is_external_proc (sym
)
2915 && gfc_sym_get_dummy_args (sym
) == NULL
;
2917 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2920 inquiry_argument
= false;
2924 inquiry_argument
= false;
2926 /* Resume assumed_size checking. */
2927 need_full_assumed_size
--;
2929 /* If the procedure is external, check for usage. */
2930 if (sym
&& is_external_proc (sym
))
2931 resolve_global_procedure (sym
, &expr
->where
,
2932 &expr
->value
.function
.actual
, 0);
2934 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2936 && sym
->ts
.u
.cl
->length
== NULL
2938 && !sym
->ts
.deferred
2939 && expr
->value
.function
.esym
== NULL
2940 && !sym
->attr
.contained
)
2942 /* Internal procedures are taken care of in resolve_contained_fntype. */
2943 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2944 "be used at %L since it is not a dummy argument",
2945 sym
->name
, &expr
->where
);
2949 /* See if function is already resolved. */
2951 if (expr
->value
.function
.name
!= NULL
2952 || expr
->value
.function
.isym
!= NULL
)
2954 if (expr
->ts
.type
== BT_UNKNOWN
)
2960 /* Apply the rules of section 14.1.2. */
2962 switch (procedure_kind (sym
))
2965 t
= resolve_generic_f (expr
);
2968 case PTYPE_SPECIFIC
:
2969 t
= resolve_specific_f (expr
);
2973 t
= resolve_unknown_f (expr
);
2977 gfc_internal_error ("resolve_function(): bad function type");
2981 /* If the expression is still a function (it might have simplified),
2982 then we check to see if we are calling an elemental function. */
2984 if (expr
->expr_type
!= EXPR_FUNCTION
)
2987 temp
= need_full_assumed_size
;
2988 need_full_assumed_size
= 0;
2990 if (!resolve_elemental_actual (expr
, NULL
))
2993 if (omp_workshare_flag
2994 && expr
->value
.function
.esym
2995 && ! gfc_elemental (expr
->value
.function
.esym
))
2997 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
2998 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3003 #define GENERIC_ID expr->value.function.isym->id
3004 else if (expr
->value
.function
.actual
!= NULL
3005 && expr
->value
.function
.isym
!= NULL
3006 && GENERIC_ID
!= GFC_ISYM_LBOUND
3007 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3008 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3009 && GENERIC_ID
!= GFC_ISYM_LEN
3010 && GENERIC_ID
!= GFC_ISYM_LOC
3011 && GENERIC_ID
!= GFC_ISYM_C_LOC
3012 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3014 /* Array intrinsics must also have the last upper bound of an
3015 assumed size array argument. UBOUND and SIZE have to be
3016 excluded from the check if the second argument is anything
3019 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3021 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3022 && arg
== expr
->value
.function
.actual
3023 && arg
->next
!= NULL
&& arg
->next
->expr
)
3025 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3028 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3031 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3036 if (arg
->expr
!= NULL
3037 && arg
->expr
->rank
> 0
3038 && resolve_assumed_size_actual (arg
->expr
))
3044 need_full_assumed_size
= temp
;
3046 if (!check_pure_function(expr
))
3049 /* Functions without the RECURSIVE attribution are not allowed to
3050 * call themselves. */
3051 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3054 esym
= expr
->value
.function
.esym
;
3056 if (is_illegal_recursion (esym
, gfc_current_ns
))
3058 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3059 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3060 " function %qs is not RECURSIVE",
3061 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3063 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3064 " is not RECURSIVE", esym
->name
, &expr
->where
);
3070 /* Character lengths of use associated functions may contains references to
3071 symbols not referenced from the current program unit otherwise. Make sure
3072 those symbols are marked as referenced. */
3074 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3075 && expr
->value
.function
.esym
->attr
.use_assoc
)
3077 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3080 /* Make sure that the expression has a typespec that works. */
3081 if (expr
->ts
.type
== BT_UNKNOWN
)
3083 if (expr
->symtree
->n
.sym
->result
3084 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3085 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3086 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3093 /************* Subroutine resolution *************/
3096 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3103 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3107 else if (gfc_do_concurrent_flag
)
3109 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3113 else if (gfc_pure (NULL
))
3115 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3119 gfc_unset_implicit_pure (NULL
);
3125 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3129 if (sym
->attr
.generic
)
3131 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3134 c
->resolved_sym
= s
;
3135 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3140 /* TODO: Need to search for elemental references in generic interface. */
3143 if (sym
->attr
.intrinsic
)
3144 return gfc_intrinsic_sub_interface (c
, 0);
3151 resolve_generic_s (gfc_code
*c
)
3156 sym
= c
->symtree
->n
.sym
;
3160 m
= resolve_generic_s0 (c
, sym
);
3163 else if (m
== MATCH_ERROR
)
3167 if (sym
->ns
->parent
== NULL
)
3169 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3173 if (!generic_sym (sym
))
3177 /* Last ditch attempt. See if the reference is to an intrinsic
3178 that possesses a matching interface. 14.1.2.4 */
3179 sym
= c
->symtree
->n
.sym
;
3181 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3183 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3184 sym
->name
, &c
->loc
);
3188 m
= gfc_intrinsic_sub_interface (c
, 0);
3192 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3193 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3199 /* Resolve a subroutine call known to be specific. */
3202 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3206 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3208 if (sym
->attr
.dummy
)
3210 sym
->attr
.proc
= PROC_DUMMY
;
3214 sym
->attr
.proc
= PROC_EXTERNAL
;
3218 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3221 if (sym
->attr
.intrinsic
)
3223 m
= gfc_intrinsic_sub_interface (c
, 1);
3227 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3228 "with an intrinsic", sym
->name
, &c
->loc
);
3236 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3238 c
->resolved_sym
= sym
;
3239 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3247 resolve_specific_s (gfc_code
*c
)
3252 sym
= c
->symtree
->n
.sym
;
3256 m
= resolve_specific_s0 (c
, sym
);
3259 if (m
== MATCH_ERROR
)
3262 if (sym
->ns
->parent
== NULL
)
3265 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3271 sym
= c
->symtree
->n
.sym
;
3272 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3273 sym
->name
, &c
->loc
);
3279 /* Resolve a subroutine call not known to be generic nor specific. */
3282 resolve_unknown_s (gfc_code
*c
)
3286 sym
= c
->symtree
->n
.sym
;
3288 if (sym
->attr
.dummy
)
3290 sym
->attr
.proc
= PROC_DUMMY
;
3294 /* See if we have an intrinsic function reference. */
3296 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3298 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3303 /* The reference is to an external name. */
3306 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3308 c
->resolved_sym
= sym
;
3310 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3314 /* Resolve a subroutine call. Although it was tempting to use the same code
3315 for functions, subroutines and functions are stored differently and this
3316 makes things awkward. */
3319 resolve_call (gfc_code
*c
)
3322 procedure_type ptype
= PROC_INTRINSIC
;
3323 gfc_symbol
*csym
, *sym
;
3324 bool no_formal_args
;
3326 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3328 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3330 gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
3331 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3335 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3338 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3339 sym
= st
? st
->n
.sym
: NULL
;
3340 if (sym
&& csym
!= sym
3341 && sym
->ns
== gfc_current_ns
3342 && sym
->attr
.flavor
== FL_PROCEDURE
3343 && sym
->attr
.contained
)
3346 if (csym
->attr
.generic
)
3347 c
->symtree
->n
.sym
= sym
;
3350 csym
= c
->symtree
->n
.sym
;
3354 /* If this ia a deferred TBP, c->expr1 will be set. */
3355 if (!c
->expr1
&& csym
)
3357 if (csym
->attr
.abstract
)
3359 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3360 csym
->name
, &c
->loc
);
3364 /* Subroutines without the RECURSIVE attribution are not allowed to
3366 if (is_illegal_recursion (csym
, gfc_current_ns
))
3368 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3369 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3370 "as subroutine %qs is not RECURSIVE",
3371 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3373 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3374 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3380 /* Switch off assumed size checking and do this again for certain kinds
3381 of procedure, once the procedure itself is resolved. */
3382 need_full_assumed_size
++;
3385 ptype
= csym
->attr
.proc
;
3387 no_formal_args
= csym
&& is_external_proc (csym
)
3388 && gfc_sym_get_dummy_args (csym
) == NULL
;
3389 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3392 /* Resume assumed_size checking. */
3393 need_full_assumed_size
--;
3395 /* If external, check for usage. */
3396 if (csym
&& is_external_proc (csym
))
3397 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3400 if (c
->resolved_sym
== NULL
)
3402 c
->resolved_isym
= NULL
;
3403 switch (procedure_kind (csym
))
3406 t
= resolve_generic_s (c
);
3409 case PTYPE_SPECIFIC
:
3410 t
= resolve_specific_s (c
);
3414 t
= resolve_unknown_s (c
);
3418 gfc_internal_error ("resolve_subroutine(): bad function type");
3422 /* Some checks of elemental subroutine actual arguments. */
3423 if (!resolve_elemental_actual (NULL
, c
))
3430 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3431 op1->shape and op2->shape are non-NULL return true if their shapes
3432 match. If both op1->shape and op2->shape are non-NULL return false
3433 if their shapes do not match. If either op1->shape or op2->shape is
3434 NULL, return true. */
3437 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3444 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3446 for (i
= 0; i
< op1
->rank
; i
++)
3448 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3450 gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
3451 &op1
->where
, &op2
->where
);
3462 /* Resolve an operator expression node. This can involve replacing the
3463 operation with a user defined function call. */
3466 resolve_operator (gfc_expr
*e
)
3468 gfc_expr
*op1
, *op2
;
3470 bool dual_locus_error
;
3473 /* Resolve all subnodes-- give them types. */
3475 switch (e
->value
.op
.op
)
3478 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3481 /* Fall through... */
3484 case INTRINSIC_UPLUS
:
3485 case INTRINSIC_UMINUS
:
3486 case INTRINSIC_PARENTHESES
:
3487 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3492 /* Typecheck the new node. */
3494 op1
= e
->value
.op
.op1
;
3495 op2
= e
->value
.op
.op2
;
3496 dual_locus_error
= false;
3498 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3499 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3501 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3505 switch (e
->value
.op
.op
)
3507 case INTRINSIC_UPLUS
:
3508 case INTRINSIC_UMINUS
:
3509 if (op1
->ts
.type
== BT_INTEGER
3510 || op1
->ts
.type
== BT_REAL
3511 || op1
->ts
.type
== BT_COMPLEX
)
3517 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3518 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3521 case INTRINSIC_PLUS
:
3522 case INTRINSIC_MINUS
:
3523 case INTRINSIC_TIMES
:
3524 case INTRINSIC_DIVIDE
:
3525 case INTRINSIC_POWER
:
3526 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3528 gfc_type_convert_binary (e
, 1);
3533 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3534 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3535 gfc_typename (&op2
->ts
));
3538 case INTRINSIC_CONCAT
:
3539 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3540 && op1
->ts
.kind
== op2
->ts
.kind
)
3542 e
->ts
.type
= BT_CHARACTER
;
3543 e
->ts
.kind
= op1
->ts
.kind
;
3548 _("Operands of string concatenation operator at %%L are %s/%s"),
3549 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3555 case INTRINSIC_NEQV
:
3556 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3558 e
->ts
.type
= BT_LOGICAL
;
3559 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3560 if (op1
->ts
.kind
< e
->ts
.kind
)
3561 gfc_convert_type (op1
, &e
->ts
, 2);
3562 else if (op2
->ts
.kind
< e
->ts
.kind
)
3563 gfc_convert_type (op2
, &e
->ts
, 2);
3567 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3568 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3569 gfc_typename (&op2
->ts
));
3574 if (op1
->ts
.type
== BT_LOGICAL
)
3576 e
->ts
.type
= BT_LOGICAL
;
3577 e
->ts
.kind
= op1
->ts
.kind
;
3581 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3582 gfc_typename (&op1
->ts
));
3586 case INTRINSIC_GT_OS
:
3588 case INTRINSIC_GE_OS
:
3590 case INTRINSIC_LT_OS
:
3592 case INTRINSIC_LE_OS
:
3593 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3595 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3599 /* Fall through... */
3602 case INTRINSIC_EQ_OS
:
3604 case INTRINSIC_NE_OS
:
3605 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3606 && op1
->ts
.kind
== op2
->ts
.kind
)
3608 e
->ts
.type
= BT_LOGICAL
;
3609 e
->ts
.kind
= gfc_default_logical_kind
;
3613 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3615 gfc_type_convert_binary (e
, 1);
3617 e
->ts
.type
= BT_LOGICAL
;
3618 e
->ts
.kind
= gfc_default_logical_kind
;
3620 if (warn_compare_reals
)
3622 gfc_intrinsic_op op
= e
->value
.op
.op
;
3624 /* Type conversion has made sure that the types of op1 and op2
3625 agree, so it is only necessary to check the first one. */
3626 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3627 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3628 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3632 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3633 msg
= "Equality comparison for %s at %L";
3635 msg
= "Inequality comparison for %s at %L";
3637 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3644 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3646 _("Logicals at %%L must be compared with %s instead of %s"),
3647 (e
->value
.op
.op
== INTRINSIC_EQ
3648 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3649 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3652 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3653 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3654 gfc_typename (&op2
->ts
));
3658 case INTRINSIC_USER
:
3659 if (e
->value
.op
.uop
->op
== NULL
)
3660 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3661 else if (op2
== NULL
)
3662 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3663 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3666 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3667 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3668 gfc_typename (&op2
->ts
));
3669 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3674 case INTRINSIC_PARENTHESES
:
3676 if (e
->ts
.type
== BT_CHARACTER
)
3677 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3681 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3684 /* Deal with arrayness of an operand through an operator. */
3688 switch (e
->value
.op
.op
)
3690 case INTRINSIC_PLUS
:
3691 case INTRINSIC_MINUS
:
3692 case INTRINSIC_TIMES
:
3693 case INTRINSIC_DIVIDE
:
3694 case INTRINSIC_POWER
:
3695 case INTRINSIC_CONCAT
:
3699 case INTRINSIC_NEQV
:
3701 case INTRINSIC_EQ_OS
:
3703 case INTRINSIC_NE_OS
:
3705 case INTRINSIC_GT_OS
:
3707 case INTRINSIC_GE_OS
:
3709 case INTRINSIC_LT_OS
:
3711 case INTRINSIC_LE_OS
:
3713 if (op1
->rank
== 0 && op2
->rank
== 0)
3716 if (op1
->rank
== 0 && op2
->rank
!= 0)
3718 e
->rank
= op2
->rank
;
3720 if (e
->shape
== NULL
)
3721 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3724 if (op1
->rank
!= 0 && op2
->rank
== 0)
3726 e
->rank
= op1
->rank
;
3728 if (e
->shape
== NULL
)
3729 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3732 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3734 if (op1
->rank
== op2
->rank
)
3736 e
->rank
= op1
->rank
;
3737 if (e
->shape
== NULL
)
3739 t
= compare_shapes (op1
, op2
);
3743 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3748 /* Allow higher level expressions to work. */
3751 /* Try user-defined operators, and otherwise throw an error. */
3752 dual_locus_error
= true;
3754 _("Inconsistent ranks for operator at %%L and %%L"));
3761 case INTRINSIC_PARENTHESES
:
3763 case INTRINSIC_UPLUS
:
3764 case INTRINSIC_UMINUS
:
3765 /* Simply copy arrayness attribute */
3766 e
->rank
= op1
->rank
;
3768 if (e
->shape
== NULL
)
3769 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3777 /* Attempt to simplify the expression. */
3780 t
= gfc_simplify_expr (e
, 0);
3781 /* Some calls do not succeed in simplification and return false
3782 even though there is no error; e.g. variable references to
3783 PARAMETER arrays. */
3784 if (!gfc_is_constant_expr (e
))
3792 match m
= gfc_extend_expr (e
);
3795 if (m
== MATCH_ERROR
)
3799 if (dual_locus_error
)
3800 gfc_error (msg
, &op1
->where
, &op2
->where
);
3802 gfc_error (msg
, &e
->where
);
3808 /************** Array resolution subroutines **************/
3811 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3814 /* Compare two integer expressions. */
3817 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3821 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3822 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3825 /* If either of the types isn't INTEGER, we must have
3826 raised an error earlier. */
3828 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3831 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3841 /* Compare an integer expression with an integer. */
3844 compare_bound_int (gfc_expr
*a
, int b
)
3848 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3851 if (a
->ts
.type
!= BT_INTEGER
)
3852 gfc_internal_error ("compare_bound_int(): Bad expression");
3854 i
= mpz_cmp_si (a
->value
.integer
, b
);
3864 /* Compare an integer expression with a mpz_t. */
3867 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3871 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3874 if (a
->ts
.type
!= BT_INTEGER
)
3875 gfc_internal_error ("compare_bound_int(): Bad expression");
3877 i
= mpz_cmp (a
->value
.integer
, b
);
3887 /* Compute the last value of a sequence given by a triplet.
3888 Return 0 if it wasn't able to compute the last value, or if the
3889 sequence if empty, and 1 otherwise. */
3892 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3893 gfc_expr
*stride
, mpz_t last
)
3897 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3898 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3899 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3902 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3903 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3906 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3908 if (compare_bound (start
, end
) == CMP_GT
)
3910 mpz_set (last
, end
->value
.integer
);
3914 if (compare_bound_int (stride
, 0) == CMP_GT
)
3916 /* Stride is positive */
3917 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3922 /* Stride is negative */
3923 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3928 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3929 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3930 mpz_sub (last
, end
->value
.integer
, rem
);
3937 /* Compare a single dimension of an array reference to the array
3941 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3945 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3947 gcc_assert (ar
->stride
[i
] == NULL
);
3948 /* This implies [*] as [*:] and [*:3] are not possible. */
3949 if (ar
->start
[i
] == NULL
)
3951 gcc_assert (ar
->end
[i
] == NULL
);
3956 /* Given start, end and stride values, calculate the minimum and
3957 maximum referenced indexes. */
3959 switch (ar
->dimen_type
[i
])
3962 case DIMEN_THIS_IMAGE
:
3967 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3970 gfc_warning (0, "Array reference at %L is out of bounds "
3971 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3972 mpz_get_si (ar
->start
[i
]->value
.integer
),
3973 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3975 gfc_warning (0, "Array reference at %L is out of bounds "
3976 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3977 mpz_get_si (ar
->start
[i
]->value
.integer
),
3978 mpz_get_si (as
->lower
[i
]->value
.integer
),
3982 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3985 gfc_warning (0, "Array reference at %L is out of bounds "
3986 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3987 mpz_get_si (ar
->start
[i
]->value
.integer
),
3988 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3990 gfc_warning (0, "Array reference at %L is out of bounds "
3991 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3992 mpz_get_si (ar
->start
[i
]->value
.integer
),
3993 mpz_get_si (as
->upper
[i
]->value
.integer
),
4002 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4003 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4005 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4007 /* Check for zero stride, which is not allowed. */
4008 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4010 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4014 /* if start == len || (stride > 0 && start < len)
4015 || (stride < 0 && start > len),
4016 then the array section contains at least one element. In this
4017 case, there is an out-of-bounds access if
4018 (start < lower || start > upper). */
4019 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4020 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4021 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4022 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4023 && comp_start_end
== CMP_GT
))
4025 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4027 gfc_warning (0, "Lower array reference at %L is out of bounds "
4028 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4029 mpz_get_si (AR_START
->value
.integer
),
4030 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4033 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4035 gfc_warning (0, "Lower array reference at %L is out of bounds "
4036 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4037 mpz_get_si (AR_START
->value
.integer
),
4038 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4043 /* If we can compute the highest index of the array section,
4044 then it also has to be between lower and upper. */
4045 mpz_init (last_value
);
4046 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4049 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4051 gfc_warning (0, "Upper array reference at %L is out of bounds "
4052 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4053 mpz_get_si (last_value
),
4054 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4055 mpz_clear (last_value
);
4058 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4060 gfc_warning (0, "Upper array reference at %L is out of bounds "
4061 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4062 mpz_get_si (last_value
),
4063 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4064 mpz_clear (last_value
);
4068 mpz_clear (last_value
);
4076 gfc_internal_error ("check_dimension(): Bad array reference");
4083 /* Compare an array reference with an array specification. */
4086 compare_spec_to_ref (gfc_array_ref
*ar
)
4093 /* TODO: Full array sections are only allowed as actual parameters. */
4094 if (as
->type
== AS_ASSUMED_SIZE
4095 && (/*ar->type == AR_FULL
4096 ||*/ (ar
->type
== AR_SECTION
4097 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4099 gfc_error ("Rightmost upper bound of assumed size array section "
4100 "not specified at %L", &ar
->where
);
4104 if (ar
->type
== AR_FULL
)
4107 if (as
->rank
!= ar
->dimen
)
4109 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4110 &ar
->where
, ar
->dimen
, as
->rank
);
4114 /* ar->codimen == 0 is a local array. */
4115 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4117 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4118 &ar
->where
, ar
->codimen
, as
->corank
);
4122 for (i
= 0; i
< as
->rank
; i
++)
4123 if (!check_dimension (i
, ar
, as
))
4126 /* Local access has no coarray spec. */
4127 if (ar
->codimen
!= 0)
4128 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4130 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4131 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4133 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4134 i
+ 1 - as
->rank
, &ar
->where
);
4137 if (!check_dimension (i
, ar
, as
))
4145 /* Resolve one part of an array index. */
4148 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4149 int force_index_integer_kind
)
4156 if (!gfc_resolve_expr (index
))
4159 if (check_scalar
&& index
->rank
!= 0)
4161 gfc_error ("Array index at %L must be scalar", &index
->where
);
4165 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4167 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4168 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4172 if (index
->ts
.type
== BT_REAL
)
4173 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4177 if ((index
->ts
.kind
!= gfc_index_integer_kind
4178 && force_index_integer_kind
)
4179 || index
->ts
.type
!= BT_INTEGER
)
4182 ts
.type
= BT_INTEGER
;
4183 ts
.kind
= gfc_index_integer_kind
;
4185 gfc_convert_type_warn (index
, &ts
, 2, 0);
4191 /* Resolve one part of an array index. */
4194 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4196 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4199 /* Resolve a dim argument to an intrinsic function. */
4202 gfc_resolve_dim_arg (gfc_expr
*dim
)
4207 if (!gfc_resolve_expr (dim
))
4212 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4217 if (dim
->ts
.type
!= BT_INTEGER
)
4219 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4223 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4228 ts
.type
= BT_INTEGER
;
4229 ts
.kind
= gfc_index_integer_kind
;
4231 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4237 /* Given an expression that contains array references, update those array
4238 references to point to the right array specifications. While this is
4239 filled in during matching, this information is difficult to save and load
4240 in a module, so we take care of it here.
4242 The idea here is that the original array reference comes from the
4243 base symbol. We traverse the list of reference structures, setting
4244 the stored reference to references. Component references can
4245 provide an additional array specification. */
4248 find_array_spec (gfc_expr
*e
)
4254 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4255 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4257 as
= e
->symtree
->n
.sym
->as
;
4259 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4264 gfc_internal_error ("find_array_spec(): Missing spec");
4271 c
= ref
->u
.c
.component
;
4272 if (c
->attr
.dimension
)
4275 gfc_internal_error ("find_array_spec(): unused as(1)");
4286 gfc_internal_error ("find_array_spec(): unused as(2)");
4290 /* Resolve an array reference. */
4293 resolve_array_ref (gfc_array_ref
*ar
)
4295 int i
, check_scalar
;
4298 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4300 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4302 /* Do not force gfc_index_integer_kind for the start. We can
4303 do fine with any integer kind. This avoids temporary arrays
4304 created for indexing with a vector. */
4305 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4307 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4309 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4314 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4318 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4322 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4323 if (e
->expr_type
== EXPR_VARIABLE
4324 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4325 ar
->start
[i
] = gfc_get_parentheses (e
);
4329 gfc_error ("Array index at %L is an array of rank %d",
4330 &ar
->c_where
[i
], e
->rank
);
4334 /* Fill in the upper bound, which may be lower than the
4335 specified one for something like a(2:10:5), which is
4336 identical to a(2:7:5). Only relevant for strides not equal
4337 to one. Don't try a division by zero. */
4338 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4339 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4340 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4341 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4345 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4347 if (ar
->end
[i
] == NULL
)
4350 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4352 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4354 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4355 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4357 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4368 if (ar
->type
== AR_FULL
)
4370 if (ar
->as
->rank
== 0)
4371 ar
->type
= AR_ELEMENT
;
4373 /* Make sure array is the same as array(:,:), this way
4374 we don't need to special case all the time. */
4375 ar
->dimen
= ar
->as
->rank
;
4376 for (i
= 0; i
< ar
->dimen
; i
++)
4378 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4380 gcc_assert (ar
->start
[i
] == NULL
);
4381 gcc_assert (ar
->end
[i
] == NULL
);
4382 gcc_assert (ar
->stride
[i
] == NULL
);
4386 /* If the reference type is unknown, figure out what kind it is. */
4388 if (ar
->type
== AR_UNKNOWN
)
4390 ar
->type
= AR_ELEMENT
;
4391 for (i
= 0; i
< ar
->dimen
; i
++)
4392 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4393 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4395 ar
->type
= AR_SECTION
;
4400 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4403 if (ar
->as
->corank
&& ar
->codimen
== 0)
4406 ar
->codimen
= ar
->as
->corank
;
4407 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4408 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4416 resolve_substring (gfc_ref
*ref
)
4418 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4420 if (ref
->u
.ss
.start
!= NULL
)
4422 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4425 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4427 gfc_error ("Substring start index at %L must be of type INTEGER",
4428 &ref
->u
.ss
.start
->where
);
4432 if (ref
->u
.ss
.start
->rank
!= 0)
4434 gfc_error ("Substring start index at %L must be scalar",
4435 &ref
->u
.ss
.start
->where
);
4439 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4440 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4441 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4443 gfc_error ("Substring start index at %L is less than one",
4444 &ref
->u
.ss
.start
->where
);
4449 if (ref
->u
.ss
.end
!= NULL
)
4451 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4454 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4456 gfc_error ("Substring end index at %L must be of type INTEGER",
4457 &ref
->u
.ss
.end
->where
);
4461 if (ref
->u
.ss
.end
->rank
!= 0)
4463 gfc_error ("Substring end index at %L must be scalar",
4464 &ref
->u
.ss
.end
->where
);
4468 if (ref
->u
.ss
.length
!= NULL
4469 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4470 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4471 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4473 gfc_error ("Substring end index at %L exceeds the string length",
4474 &ref
->u
.ss
.start
->where
);
4478 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4479 gfc_integer_kinds
[k
].huge
) == CMP_GT
4480 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4481 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4483 gfc_error ("Substring end index at %L is too large",
4484 &ref
->u
.ss
.end
->where
);
4493 /* This function supplies missing substring charlens. */
4496 gfc_resolve_substring_charlen (gfc_expr
*e
)
4499 gfc_expr
*start
, *end
;
4501 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4502 if (char_ref
->type
== REF_SUBSTRING
)
4508 gcc_assert (char_ref
->next
== NULL
);
4512 if (e
->ts
.u
.cl
->length
)
4513 gfc_free_expr (e
->ts
.u
.cl
->length
);
4514 else if (e
->expr_type
== EXPR_VARIABLE
4515 && e
->symtree
->n
.sym
->attr
.dummy
)
4519 e
->ts
.type
= BT_CHARACTER
;
4520 e
->ts
.kind
= gfc_default_character_kind
;
4523 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4525 if (char_ref
->u
.ss
.start
)
4526 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4528 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4530 if (char_ref
->u
.ss
.end
)
4531 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4532 else if (e
->expr_type
== EXPR_VARIABLE
)
4533 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4539 gfc_free_expr (start
);
4540 gfc_free_expr (end
);
4544 /* Length = (end - start +1). */
4545 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4546 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4547 gfc_get_int_expr (gfc_default_integer_kind
,
4550 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4551 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4553 /* Make sure that the length is simplified. */
4554 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4555 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4559 /* Resolve subtype references. */
4562 resolve_ref (gfc_expr
*expr
)
4564 int current_part_dimension
, n_components
, seen_part_dimension
;
4567 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4568 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4570 find_array_spec (expr
);
4574 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4578 if (!resolve_array_ref (&ref
->u
.ar
))
4586 if (!resolve_substring (ref
))
4591 /* Check constraints on part references. */
4593 current_part_dimension
= 0;
4594 seen_part_dimension
= 0;
4597 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4602 switch (ref
->u
.ar
.type
)
4605 /* Coarray scalar. */
4606 if (ref
->u
.ar
.as
->rank
== 0)
4608 current_part_dimension
= 0;
4613 current_part_dimension
= 1;
4617 current_part_dimension
= 0;
4621 gfc_internal_error ("resolve_ref(): Bad array reference");
4627 if (current_part_dimension
|| seen_part_dimension
)
4630 if (ref
->u
.c
.component
->attr
.pointer
4631 || ref
->u
.c
.component
->attr
.proc_pointer
4632 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4633 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4635 gfc_error ("Component to the right of a part reference "
4636 "with nonzero rank must not have the POINTER "
4637 "attribute at %L", &expr
->where
);
4640 else if (ref
->u
.c
.component
->attr
.allocatable
4641 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4642 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4645 gfc_error ("Component to the right of a part reference "
4646 "with nonzero rank must not have the ALLOCATABLE "
4647 "attribute at %L", &expr
->where
);
4659 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4660 || ref
->next
== NULL
)
4661 && current_part_dimension
4662 && seen_part_dimension
)
4664 gfc_error ("Two or more part references with nonzero rank must "
4665 "not be specified at %L", &expr
->where
);
4669 if (ref
->type
== REF_COMPONENT
)
4671 if (current_part_dimension
)
4672 seen_part_dimension
= 1;
4674 /* reset to make sure */
4675 current_part_dimension
= 0;
4683 /* Given an expression, determine its shape. This is easier than it sounds.
4684 Leaves the shape array NULL if it is not possible to determine the shape. */
4687 expression_shape (gfc_expr
*e
)
4689 mpz_t array
[GFC_MAX_DIMENSIONS
];
4692 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4695 for (i
= 0; i
< e
->rank
; i
++)
4696 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4699 e
->shape
= gfc_get_shape (e
->rank
);
4701 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4706 for (i
--; i
>= 0; i
--)
4707 mpz_clear (array
[i
]);
4711 /* Given a variable expression node, compute the rank of the expression by
4712 examining the base symbol and any reference structures it may have. */
4715 expression_rank (gfc_expr
*e
)
4720 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4721 could lead to serious confusion... */
4722 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4726 if (e
->expr_type
== EXPR_ARRAY
)
4728 /* Constructors can have a rank different from one via RESHAPE(). */
4730 if (e
->symtree
== NULL
)
4736 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4737 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4743 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4745 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4746 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4747 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4749 if (ref
->type
!= REF_ARRAY
)
4752 if (ref
->u
.ar
.type
== AR_FULL
)
4754 rank
= ref
->u
.ar
.as
->rank
;
4758 if (ref
->u
.ar
.type
== AR_SECTION
)
4760 /* Figure out the rank of the section. */
4762 gfc_internal_error ("expression_rank(): Two array specs");
4764 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4765 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4766 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4776 expression_shape (e
);
4781 add_caf_get_intrinsic (gfc_expr
*e
)
4783 gfc_expr
*wrapper
, *tmp_expr
;
4787 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4788 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4793 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4794 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4797 tmp_expr
= XCNEW (gfc_expr
);
4799 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4800 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4801 wrapper
->ts
= e
->ts
;
4802 wrapper
->rank
= e
->rank
;
4804 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4811 remove_caf_get_intrinsic (gfc_expr
*e
)
4813 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4814 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4815 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4816 e
->value
.function
.actual
->expr
= NULL
;
4817 gfc_free_actual_arglist (e
->value
.function
.actual
);
4818 gfc_free_shape (&e
->shape
, e
->rank
);
4824 /* Resolve a variable expression. */
4827 resolve_variable (gfc_expr
*e
)
4834 if (e
->symtree
== NULL
)
4836 sym
= e
->symtree
->n
.sym
;
4838 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4839 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4840 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4842 if (!actual_arg
|| inquiry_argument
)
4844 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4845 "be used as actual argument", sym
->name
, &e
->where
);
4849 /* TS 29113, 407b. */
4850 else if (e
->ts
.type
== BT_ASSUMED
)
4854 gfc_error ("Assumed-type variable %s at %L may only be used "
4855 "as actual argument", sym
->name
, &e
->where
);
4858 else if (inquiry_argument
&& !first_actual_arg
)
4860 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4861 for all inquiry functions in resolve_function; the reason is
4862 that the function-name resolution happens too late in that
4864 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4865 "an inquiry function shall be the first argument",
4866 sym
->name
, &e
->where
);
4870 /* TS 29113, C535b. */
4871 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4872 && CLASS_DATA (sym
)->as
4873 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4874 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4875 && sym
->as
->type
== AS_ASSUMED_RANK
))
4879 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4880 "actual argument", sym
->name
, &e
->where
);
4883 else if (inquiry_argument
&& !first_actual_arg
)
4885 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4886 for all inquiry functions in resolve_function; the reason is
4887 that the function-name resolution happens too late in that
4889 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4890 "to an inquiry function shall be the first argument",
4891 sym
->name
, &e
->where
);
4896 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4897 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4898 && e
->ref
->next
== NULL
))
4900 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4901 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4904 /* TS 29113, 407b. */
4905 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4906 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4907 && e
->ref
->next
== NULL
))
4909 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4910 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4914 /* TS 29113, C535b. */
4915 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4916 && CLASS_DATA (sym
)->as
4917 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4918 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4919 && sym
->as
->type
== AS_ASSUMED_RANK
))
4921 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4922 && e
->ref
->next
== NULL
))
4924 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4925 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4930 /* If this is an associate-name, it may be parsed with an array reference
4931 in error even though the target is scalar. Fail directly in this case.
4932 TODO Understand why class scalar expressions must be excluded. */
4933 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4935 if (sym
->ts
.type
== BT_CLASS
)
4936 gfc_fix_class_refs (e
);
4937 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4941 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4942 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4944 /* On the other hand, the parser may not have known this is an array;
4945 in this case, we have to add a FULL reference. */
4946 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4948 e
->ref
= gfc_get_ref ();
4949 e
->ref
->type
= REF_ARRAY
;
4950 e
->ref
->u
.ar
.type
= AR_FULL
;
4951 e
->ref
->u
.ar
.dimen
= 0;
4954 if (e
->ref
&& !resolve_ref (e
))
4957 if (sym
->attr
.flavor
== FL_PROCEDURE
4958 && (!sym
->attr
.function
4959 || (sym
->attr
.function
&& sym
->result
4960 && sym
->result
->attr
.proc_pointer
4961 && !sym
->result
->attr
.function
)))
4963 e
->ts
.type
= BT_PROCEDURE
;
4964 goto resolve_procedure
;
4967 if (sym
->ts
.type
!= BT_UNKNOWN
)
4968 gfc_variable_attr (e
, &e
->ts
);
4971 /* Must be a simple variable reference. */
4972 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4977 if (check_assumed_size_reference (sym
, e
))
4980 /* Deal with forward references to entries during gfc_resolve_code, to
4981 satisfy, at least partially, 12.5.2.5. */
4982 if (gfc_current_ns
->entries
4983 && current_entry_id
== sym
->entry_id
4986 && cs_base
->current
->op
!= EXEC_ENTRY
)
4988 gfc_entry_list
*entry
;
4989 gfc_formal_arglist
*formal
;
4991 bool seen
, saved_specification_expr
;
4993 /* If the symbol is a dummy... */
4994 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4996 entry
= gfc_current_ns
->entries
;
4999 /* ...test if the symbol is a parameter of previous entries. */
5000 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5001 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5003 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5010 /* If it has not been seen as a dummy, this is an error. */
5013 if (specification_expr
)
5014 gfc_error ("Variable %qs, used in a specification expression"
5015 ", is referenced at %L before the ENTRY statement "
5016 "in which it is a parameter",
5017 sym
->name
, &cs_base
->current
->loc
);
5019 gfc_error ("Variable %qs is used at %L before the ENTRY "
5020 "statement in which it is a parameter",
5021 sym
->name
, &cs_base
->current
->loc
);
5026 /* Now do the same check on the specification expressions. */
5027 saved_specification_expr
= specification_expr
;
5028 specification_expr
= true;
5029 if (sym
->ts
.type
== BT_CHARACTER
5030 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5034 for (n
= 0; n
< sym
->as
->rank
; n
++)
5036 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5038 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5041 specification_expr
= saved_specification_expr
;
5044 /* Update the symbol's entry level. */
5045 sym
->entry_id
= current_entry_id
+ 1;
5048 /* If a symbol has been host_associated mark it. This is used latter,
5049 to identify if aliasing is possible via host association. */
5050 if (sym
->attr
.flavor
== FL_VARIABLE
5051 && gfc_current_ns
->parent
5052 && (gfc_current_ns
->parent
== sym
->ns
5053 || (gfc_current_ns
->parent
->parent
5054 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5055 sym
->attr
.host_assoc
= 1;
5058 if (t
&& !resolve_procedure_expression (e
))
5061 /* F2008, C617 and C1229. */
5062 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5063 && gfc_is_coindexed (e
))
5065 gfc_ref
*ref
, *ref2
= NULL
;
5067 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5069 if (ref
->type
== REF_COMPONENT
)
5071 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5075 for ( ; ref
; ref
= ref
->next
)
5076 if (ref
->type
== REF_COMPONENT
)
5079 /* Expression itself is not coindexed object. */
5080 if (ref
&& e
->ts
.type
== BT_CLASS
)
5082 gfc_error ("Polymorphic subobject of coindexed object at %L",
5087 /* Expression itself is coindexed object. */
5091 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5092 for ( ; c
; c
= c
->next
)
5093 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5095 gfc_error ("Coindexed object with polymorphic allocatable "
5096 "subcomponent at %L", &e
->where
);
5104 expression_rank (e
);
5106 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5107 add_caf_get_intrinsic (e
);
5113 /* Checks to see that the correct symbol has been host associated.
5114 The only situation where this arises is that in which a twice
5115 contained function is parsed after the host association is made.
5116 Therefore, on detecting this, change the symbol in the expression
5117 and convert the array reference into an actual arglist if the old
5118 symbol is a variable. */
5120 check_host_association (gfc_expr
*e
)
5122 gfc_symbol
*sym
, *old_sym
;
5126 gfc_actual_arglist
*arg
, *tail
= NULL
;
5127 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5129 /* If the expression is the result of substitution in
5130 interface.c(gfc_extend_expr) because there is no way in
5131 which the host association can be wrong. */
5132 if (e
->symtree
== NULL
5133 || e
->symtree
->n
.sym
== NULL
5134 || e
->user_operator
)
5137 old_sym
= e
->symtree
->n
.sym
;
5139 if (gfc_current_ns
->parent
5140 && old_sym
->ns
!= gfc_current_ns
)
5142 /* Use the 'USE' name so that renamed module symbols are
5143 correctly handled. */
5144 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5146 if (sym
&& old_sym
!= sym
5147 && sym
->ts
.type
== old_sym
->ts
.type
5148 && sym
->attr
.flavor
== FL_PROCEDURE
5149 && sym
->attr
.contained
)
5151 /* Clear the shape, since it might not be valid. */
5152 gfc_free_shape (&e
->shape
, e
->rank
);
5154 /* Give the expression the right symtree! */
5155 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5156 gcc_assert (st
!= NULL
);
5158 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5159 || e
->expr_type
== EXPR_FUNCTION
)
5161 /* Original was function so point to the new symbol, since
5162 the actual argument list is already attached to the
5164 e
->value
.function
.esym
= NULL
;
5169 /* Original was variable so convert array references into
5170 an actual arglist. This does not need any checking now
5171 since resolve_function will take care of it. */
5172 e
->value
.function
.actual
= NULL
;
5173 e
->expr_type
= EXPR_FUNCTION
;
5176 /* Ambiguity will not arise if the array reference is not
5177 the last reference. */
5178 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5179 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5182 gcc_assert (ref
->type
== REF_ARRAY
);
5184 /* Grab the start expressions from the array ref and
5185 copy them into actual arguments. */
5186 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5188 arg
= gfc_get_actual_arglist ();
5189 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5190 if (e
->value
.function
.actual
== NULL
)
5191 tail
= e
->value
.function
.actual
= arg
;
5199 /* Dump the reference list and set the rank. */
5200 gfc_free_ref_list (e
->ref
);
5202 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5205 gfc_resolve_expr (e
);
5209 /* This might have changed! */
5210 return e
->expr_type
== EXPR_FUNCTION
;
5215 gfc_resolve_character_operator (gfc_expr
*e
)
5217 gfc_expr
*op1
= e
->value
.op
.op1
;
5218 gfc_expr
*op2
= e
->value
.op
.op2
;
5219 gfc_expr
*e1
= NULL
;
5220 gfc_expr
*e2
= NULL
;
5222 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5224 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5225 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5226 else if (op1
->expr_type
== EXPR_CONSTANT
)
5227 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5228 op1
->value
.character
.length
);
5230 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5231 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5232 else if (op2
->expr_type
== EXPR_CONSTANT
)
5233 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5234 op2
->value
.character
.length
);
5236 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5246 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5247 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5248 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5249 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5250 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5256 /* Ensure that an character expression has a charlen and, if possible, a
5257 length expression. */
5260 fixup_charlen (gfc_expr
*e
)
5262 /* The cases fall through so that changes in expression type and the need
5263 for multiple fixes are picked up. In all circumstances, a charlen should
5264 be available for the middle end to hang a backend_decl on. */
5265 switch (e
->expr_type
)
5268 gfc_resolve_character_operator (e
);
5271 if (e
->expr_type
== EXPR_ARRAY
)
5272 gfc_resolve_character_array_constructor (e
);
5274 case EXPR_SUBSTRING
:
5275 if (!e
->ts
.u
.cl
&& e
->ref
)
5276 gfc_resolve_substring_charlen (e
);
5280 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5287 /* Update an actual argument to include the passed-object for type-bound
5288 procedures at the right position. */
5290 static gfc_actual_arglist
*
5291 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5294 gcc_assert (argpos
> 0);
5298 gfc_actual_arglist
* result
;
5300 result
= gfc_get_actual_arglist ();
5304 result
->name
= name
;
5310 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5312 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5317 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5320 extract_compcall_passed_object (gfc_expr
* e
)
5324 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5326 if (e
->value
.compcall
.base_object
)
5327 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5330 po
= gfc_get_expr ();
5331 po
->expr_type
= EXPR_VARIABLE
;
5332 po
->symtree
= e
->symtree
;
5333 po
->ref
= gfc_copy_ref (e
->ref
);
5334 po
->where
= e
->where
;
5337 if (!gfc_resolve_expr (po
))
5344 /* Update the arglist of an EXPR_COMPCALL expression to include the
5348 update_compcall_arglist (gfc_expr
* e
)
5351 gfc_typebound_proc
* tbp
;
5353 tbp
= e
->value
.compcall
.tbp
;
5358 po
= extract_compcall_passed_object (e
);
5362 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5368 gcc_assert (tbp
->pass_arg_num
> 0);
5369 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5377 /* Extract the passed object from a PPC call (a copy of it). */
5380 extract_ppc_passed_object (gfc_expr
*e
)
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
;
5391 /* Remove PPC reference. */
5393 while ((*ref
)->next
)
5394 ref
= &(*ref
)->next
;
5395 gfc_free_ref_list (*ref
);
5398 if (!gfc_resolve_expr (po
))
5405 /* Update the actual arglist of a procedure pointer component to include the
5409 update_ppc_arglist (gfc_expr
* e
)
5413 gfc_typebound_proc
* tb
;
5415 ppc
= gfc_get_proc_ptr_comp (e
);
5423 else if (tb
->nopass
)
5426 po
= extract_ppc_passed_object (e
);
5433 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5438 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5440 gfc_error ("Base object for procedure-pointer component call at %L is of"
5441 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5445 gcc_assert (tb
->pass_arg_num
> 0);
5446 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5454 /* Check that the object a TBP is called on is valid, i.e. it must not be
5455 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5458 check_typebound_baseobject (gfc_expr
* e
)
5461 bool return_value
= false;
5463 base
= extract_compcall_passed_object (e
);
5467 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5469 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5473 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5475 gfc_error ("Base object for type-bound procedure call at %L is of"
5476 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5480 /* F08:C1230. If the procedure called is NOPASS,
5481 the base object must be scalar. */
5482 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5484 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5485 " be scalar", &e
->where
);
5489 return_value
= true;
5492 gfc_free_expr (base
);
5493 return return_value
;
5497 /* Resolve a call to a type-bound procedure, either function or subroutine,
5498 statically from the data in an EXPR_COMPCALL expression. The adapted
5499 arglist and the target-procedure symtree are returned. */
5502 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5503 gfc_actual_arglist
** actual
)
5505 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5506 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5508 /* Update the actual arglist for PASS. */
5509 if (!update_compcall_arglist (e
))
5512 *actual
= e
->value
.compcall
.actual
;
5513 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5515 gfc_free_ref_list (e
->ref
);
5517 e
->value
.compcall
.actual
= NULL
;
5519 /* If we find a deferred typebound procedure, check for derived types
5520 that an overriding typebound procedure has not been missed. */
5521 if (e
->value
.compcall
.name
5522 && !e
->value
.compcall
.tbp
->non_overridable
5523 && e
->value
.compcall
.base_object
5524 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5527 gfc_symbol
*derived
;
5529 /* Use the derived type of the base_object. */
5530 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5533 /* If necessary, go through the inheritance chain. */
5534 while (!st
&& derived
)
5536 /* Look for the typebound procedure 'name'. */
5537 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5538 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5539 e
->value
.compcall
.name
);
5541 derived
= gfc_get_derived_super_type (derived
);
5544 /* Now find the specific name in the derived type namespace. */
5545 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5546 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5547 derived
->ns
, 1, &st
);
5555 /* Get the ultimate declared type from an expression. In addition,
5556 return the last class/derived type reference and the copy of the
5557 reference list. If check_types is set true, derived types are
5558 identified as well as class references. */
5560 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5561 gfc_expr
*e
, bool check_types
)
5563 gfc_symbol
*declared
;
5570 *new_ref
= gfc_copy_ref (e
->ref
);
5572 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5574 if (ref
->type
!= REF_COMPONENT
)
5577 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5578 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5579 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5581 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5587 if (declared
== NULL
)
5588 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5594 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5595 which of the specific bindings (if any) matches the arglist and transform
5596 the expression into a call of that binding. */
5599 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5601 gfc_typebound_proc
* genproc
;
5602 const char* genname
;
5604 gfc_symbol
*derived
;
5606 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5607 genname
= e
->value
.compcall
.name
;
5608 genproc
= e
->value
.compcall
.tbp
;
5610 if (!genproc
->is_generic
)
5613 /* Try the bindings on this type and in the inheritance hierarchy. */
5614 for (; genproc
; genproc
= genproc
->overridden
)
5618 gcc_assert (genproc
->is_generic
);
5619 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5622 gfc_actual_arglist
* args
;
5625 gcc_assert (g
->specific
);
5627 if (g
->specific
->error
)
5630 target
= g
->specific
->u
.specific
->n
.sym
;
5632 /* Get the right arglist by handling PASS/NOPASS. */
5633 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5634 if (!g
->specific
->nopass
)
5637 po
= extract_compcall_passed_object (e
);
5640 gfc_free_actual_arglist (args
);
5644 gcc_assert (g
->specific
->pass_arg_num
> 0);
5645 gcc_assert (!g
->specific
->error
);
5646 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5647 g
->specific
->pass_arg
);
5649 resolve_actual_arglist (args
, target
->attr
.proc
,
5650 is_external_proc (target
)
5651 && gfc_sym_get_dummy_args (target
) == NULL
);
5653 /* Check if this arglist matches the formal. */
5654 matches
= gfc_arglist_matches_symbol (&args
, target
);
5656 /* Clean up and break out of the loop if we've found it. */
5657 gfc_free_actual_arglist (args
);
5660 e
->value
.compcall
.tbp
= g
->specific
;
5661 genname
= g
->specific_st
->name
;
5662 /* Pass along the name for CLASS methods, where the vtab
5663 procedure pointer component has to be referenced. */
5671 /* Nothing matching found! */
5672 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5673 " %qs at %L", genname
, &e
->where
);
5677 /* Make sure that we have the right specific instance for the name. */
5678 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5680 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5682 e
->value
.compcall
.tbp
= st
->n
.tb
;
5688 /* Resolve a call to a type-bound subroutine. */
5691 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5693 gfc_actual_arglist
* newactual
;
5694 gfc_symtree
* target
;
5696 /* Check that's really a SUBROUTINE. */
5697 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5699 gfc_error ("%qs at %L should be a SUBROUTINE",
5700 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5704 if (!check_typebound_baseobject (c
->expr1
))
5707 /* Pass along the name for CLASS methods, where the vtab
5708 procedure pointer component has to be referenced. */
5710 *name
= c
->expr1
->value
.compcall
.name
;
5712 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5715 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5717 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5719 /* Transform into an ordinary EXEC_CALL for now. */
5721 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5724 c
->ext
.actual
= newactual
;
5725 c
->symtree
= target
;
5726 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5728 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5730 gfc_free_expr (c
->expr1
);
5731 c
->expr1
= gfc_get_expr ();
5732 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5733 c
->expr1
->symtree
= target
;
5734 c
->expr1
->where
= c
->loc
;
5736 return resolve_call (c
);
5740 /* Resolve a component-call expression. */
5742 resolve_compcall (gfc_expr
* e
, const char **name
)
5744 gfc_actual_arglist
* newactual
;
5745 gfc_symtree
* target
;
5747 /* Check that's really a FUNCTION. */
5748 if (!e
->value
.compcall
.tbp
->function
)
5750 gfc_error ("%qs at %L should be a FUNCTION",
5751 e
->value
.compcall
.name
, &e
->where
);
5755 /* These must not be assign-calls! */
5756 gcc_assert (!e
->value
.compcall
.assign
);
5758 if (!check_typebound_baseobject (e
))
5761 /* Pass along the name for CLASS methods, where the vtab
5762 procedure pointer component has to be referenced. */
5764 *name
= e
->value
.compcall
.name
;
5766 if (!resolve_typebound_generic_call (e
, name
))
5768 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5770 /* Take the rank from the function's symbol. */
5771 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5772 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5774 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5775 arglist to the TBP's binding target. */
5777 if (!resolve_typebound_static (e
, &target
, &newactual
))
5780 e
->value
.function
.actual
= newactual
;
5781 e
->value
.function
.name
= NULL
;
5782 e
->value
.function
.esym
= target
->n
.sym
;
5783 e
->value
.function
.isym
= NULL
;
5784 e
->symtree
= target
;
5785 e
->ts
= target
->n
.sym
->ts
;
5786 e
->expr_type
= EXPR_FUNCTION
;
5788 /* Resolution is not necessary if this is a class subroutine; this
5789 function only has to identify the specific proc. Resolution of
5790 the call will be done next in resolve_typebound_call. */
5791 return gfc_resolve_expr (e
);
5795 static bool resolve_fl_derived (gfc_symbol
*sym
);
5798 /* Resolve a typebound function, or 'method'. First separate all
5799 the non-CLASS references by calling resolve_compcall directly. */
5802 resolve_typebound_function (gfc_expr
* e
)
5804 gfc_symbol
*declared
;
5816 /* Deal with typebound operators for CLASS objects. */
5817 expr
= e
->value
.compcall
.base_object
;
5818 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5819 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5821 /* If the base_object is not a variable, the corresponding actual
5822 argument expression must be stored in e->base_expression so
5823 that the corresponding tree temporary can be used as the base
5824 object in gfc_conv_procedure_call. */
5825 if (expr
->expr_type
!= EXPR_VARIABLE
)
5827 gfc_actual_arglist
*args
;
5829 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5831 if (expr
== args
->expr
)
5836 /* Since the typebound operators are generic, we have to ensure
5837 that any delays in resolution are corrected and that the vtab
5840 declared
= ts
.u
.derived
;
5841 c
= gfc_find_component (declared
, "_vptr", true, true);
5842 if (c
->ts
.u
.derived
== NULL
)
5843 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5845 if (!resolve_compcall (e
, &name
))
5848 /* Use the generic name if it is there. */
5849 name
= name
? name
: e
->value
.function
.esym
->name
;
5850 e
->symtree
= expr
->symtree
;
5851 e
->ref
= gfc_copy_ref (expr
->ref
);
5852 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5854 /* Trim away the extraneous references that emerge from nested
5855 use of interface.c (extend_expr). */
5856 if (class_ref
&& class_ref
->next
)
5858 gfc_free_ref_list (class_ref
->next
);
5859 class_ref
->next
= NULL
;
5861 else if (e
->ref
&& !class_ref
)
5863 gfc_free_ref_list (e
->ref
);
5867 gfc_add_vptr_component (e
);
5868 gfc_add_component_ref (e
, name
);
5869 e
->value
.function
.esym
= NULL
;
5870 if (expr
->expr_type
!= EXPR_VARIABLE
)
5871 e
->base_expr
= expr
;
5876 return resolve_compcall (e
, NULL
);
5878 if (!resolve_ref (e
))
5881 /* Get the CLASS declared type. */
5882 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5884 if (!resolve_fl_derived (declared
))
5887 /* Weed out cases of the ultimate component being a derived type. */
5888 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5889 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5891 gfc_free_ref_list (new_ref
);
5892 return resolve_compcall (e
, NULL
);
5895 c
= gfc_find_component (declared
, "_data", true, true);
5896 declared
= c
->ts
.u
.derived
;
5898 /* Treat the call as if it is a typebound procedure, in order to roll
5899 out the correct name for the specific function. */
5900 if (!resolve_compcall (e
, &name
))
5902 gfc_free_ref_list (new_ref
);
5909 /* Convert the expression to a procedure pointer component call. */
5910 e
->value
.function
.esym
= NULL
;
5916 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5917 gfc_add_vptr_component (e
);
5918 gfc_add_component_ref (e
, name
);
5920 /* Recover the typespec for the expression. This is really only
5921 necessary for generic procedures, where the additional call
5922 to gfc_add_component_ref seems to throw the collection of the
5923 correct typespec. */
5927 gfc_free_ref_list (new_ref
);
5932 /* Resolve a typebound subroutine, or 'method'. First separate all
5933 the non-CLASS references by calling resolve_typebound_call
5937 resolve_typebound_subroutine (gfc_code
*code
)
5939 gfc_symbol
*declared
;
5949 st
= code
->expr1
->symtree
;
5951 /* Deal with typebound operators for CLASS objects. */
5952 expr
= code
->expr1
->value
.compcall
.base_object
;
5953 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5954 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5956 /* If the base_object is not a variable, the corresponding actual
5957 argument expression must be stored in e->base_expression so
5958 that the corresponding tree temporary can be used as the base
5959 object in gfc_conv_procedure_call. */
5960 if (expr
->expr_type
!= EXPR_VARIABLE
)
5962 gfc_actual_arglist
*args
;
5964 args
= code
->expr1
->value
.function
.actual
;
5965 for (; args
; args
= args
->next
)
5966 if (expr
== args
->expr
)
5970 /* Since the typebound operators are generic, we have to ensure
5971 that any delays in resolution are corrected and that the vtab
5973 declared
= expr
->ts
.u
.derived
;
5974 c
= gfc_find_component (declared
, "_vptr", true, true);
5975 if (c
->ts
.u
.derived
== NULL
)
5976 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5978 if (!resolve_typebound_call (code
, &name
, NULL
))
5981 /* Use the generic name if it is there. */
5982 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5983 code
->expr1
->symtree
= expr
->symtree
;
5984 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5986 /* Trim away the extraneous references that emerge from nested
5987 use of interface.c (extend_expr). */
5988 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5989 if (class_ref
&& class_ref
->next
)
5991 gfc_free_ref_list (class_ref
->next
);
5992 class_ref
->next
= NULL
;
5994 else if (code
->expr1
->ref
&& !class_ref
)
5996 gfc_free_ref_list (code
->expr1
->ref
);
5997 code
->expr1
->ref
= NULL
;
6000 /* Now use the procedure in the vtable. */
6001 gfc_add_vptr_component (code
->expr1
);
6002 gfc_add_component_ref (code
->expr1
, name
);
6003 code
->expr1
->value
.function
.esym
= NULL
;
6004 if (expr
->expr_type
!= EXPR_VARIABLE
)
6005 code
->expr1
->base_expr
= expr
;
6010 return resolve_typebound_call (code
, NULL
, NULL
);
6012 if (!resolve_ref (code
->expr1
))
6015 /* Get the CLASS declared type. */
6016 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6018 /* Weed out cases of the ultimate component being a derived type. */
6019 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6020 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6022 gfc_free_ref_list (new_ref
);
6023 return resolve_typebound_call (code
, NULL
, NULL
);
6026 if (!resolve_typebound_call (code
, &name
, &overridable
))
6028 gfc_free_ref_list (new_ref
);
6031 ts
= code
->expr1
->ts
;
6035 /* Convert the expression to a procedure pointer component call. */
6036 code
->expr1
->value
.function
.esym
= NULL
;
6037 code
->expr1
->symtree
= st
;
6040 code
->expr1
->ref
= new_ref
;
6042 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6043 gfc_add_vptr_component (code
->expr1
);
6044 gfc_add_component_ref (code
->expr1
, name
);
6046 /* Recover the typespec for the expression. This is really only
6047 necessary for generic procedures, where the additional call
6048 to gfc_add_component_ref seems to throw the collection of the
6049 correct typespec. */
6050 code
->expr1
->ts
= ts
;
6053 gfc_free_ref_list (new_ref
);
6059 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6062 resolve_ppc_call (gfc_code
* c
)
6064 gfc_component
*comp
;
6066 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6067 gcc_assert (comp
!= NULL
);
6069 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6070 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6072 if (!comp
->attr
.subroutine
)
6073 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6075 if (!resolve_ref (c
->expr1
))
6078 if (!update_ppc_arglist (c
->expr1
))
6081 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6083 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6084 !(comp
->ts
.interface
6085 && comp
->ts
.interface
->formal
)))
6088 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6091 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6097 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6100 resolve_expr_ppc (gfc_expr
* e
)
6102 gfc_component
*comp
;
6104 comp
= gfc_get_proc_ptr_comp (e
);
6105 gcc_assert (comp
!= NULL
);
6107 /* Convert to EXPR_FUNCTION. */
6108 e
->expr_type
= EXPR_FUNCTION
;
6109 e
->value
.function
.isym
= NULL
;
6110 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6112 if (comp
->as
!= NULL
)
6113 e
->rank
= comp
->as
->rank
;
6115 if (!comp
->attr
.function
)
6116 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6118 if (!resolve_ref (e
))
6121 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6122 !(comp
->ts
.interface
6123 && comp
->ts
.interface
->formal
)))
6126 if (!update_ppc_arglist (e
))
6129 if (!check_pure_function(e
))
6132 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6139 gfc_is_expandable_expr (gfc_expr
*e
)
6141 gfc_constructor
*con
;
6143 if (e
->expr_type
== EXPR_ARRAY
)
6145 /* Traverse the constructor looking for variables that are flavor
6146 parameter. Parameters must be expanded since they are fully used at
6148 con
= gfc_constructor_first (e
->value
.constructor
);
6149 for (; con
; con
= gfc_constructor_next (con
))
6151 if (con
->expr
->expr_type
== EXPR_VARIABLE
6152 && con
->expr
->symtree
6153 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6154 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6156 if (con
->expr
->expr_type
== EXPR_ARRAY
6157 && gfc_is_expandable_expr (con
->expr
))
6165 /* Resolve an expression. That is, make sure that types of operands agree
6166 with their operators, intrinsic operators are converted to function calls
6167 for overloaded types and unresolved function references are resolved. */
6170 gfc_resolve_expr (gfc_expr
*e
)
6173 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6178 /* inquiry_argument only applies to variables. */
6179 inquiry_save
= inquiry_argument
;
6180 actual_arg_save
= actual_arg
;
6181 first_actual_arg_save
= first_actual_arg
;
6183 if (e
->expr_type
!= EXPR_VARIABLE
)
6185 inquiry_argument
= false;
6187 first_actual_arg
= false;
6190 switch (e
->expr_type
)
6193 t
= resolve_operator (e
);
6199 if (check_host_association (e
))
6200 t
= resolve_function (e
);
6202 t
= resolve_variable (e
);
6204 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6205 && e
->ref
->type
!= REF_SUBSTRING
)
6206 gfc_resolve_substring_charlen (e
);
6211 t
= resolve_typebound_function (e
);
6214 case EXPR_SUBSTRING
:
6215 t
= resolve_ref (e
);
6224 t
= resolve_expr_ppc (e
);
6229 if (!resolve_ref (e
))
6232 t
= gfc_resolve_array_constructor (e
);
6233 /* Also try to expand a constructor. */
6236 expression_rank (e
);
6237 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6238 gfc_expand_constructor (e
, false);
6241 /* This provides the opportunity for the length of constructors with
6242 character valued function elements to propagate the string length
6243 to the expression. */
6244 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6246 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6247 here rather then add a duplicate test for it above. */
6248 gfc_expand_constructor (e
, false);
6249 t
= gfc_resolve_character_array_constructor (e
);
6254 case EXPR_STRUCTURE
:
6255 t
= resolve_ref (e
);
6259 t
= resolve_structure_cons (e
, 0);
6263 t
= gfc_simplify_expr (e
, 0);
6267 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6270 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6273 inquiry_argument
= inquiry_save
;
6274 actual_arg
= actual_arg_save
;
6275 first_actual_arg
= first_actual_arg_save
;
6281 /* Resolve an expression from an iterator. They must be scalar and have
6282 INTEGER or (optionally) REAL type. */
6285 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6286 const char *name_msgid
)
6288 if (!gfc_resolve_expr (expr
))
6291 if (expr
->rank
!= 0)
6293 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6297 if (expr
->ts
.type
!= BT_INTEGER
)
6299 if (expr
->ts
.type
== BT_REAL
)
6302 return gfc_notify_std (GFC_STD_F95_DEL
,
6303 "%s at %L must be integer",
6304 _(name_msgid
), &expr
->where
);
6307 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6314 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6322 /* Resolve the expressions in an iterator structure. If REAL_OK is
6323 false allow only INTEGER type iterators, otherwise allow REAL types.
6324 Set own_scope to true for ac-implied-do and data-implied-do as those
6325 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6328 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6330 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6333 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6334 _("iterator variable")))
6337 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6338 "Start expression in DO loop"))
6341 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6342 "End expression in DO loop"))
6345 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6346 "Step expression in DO loop"))
6349 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6351 if ((iter
->step
->ts
.type
== BT_INTEGER
6352 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6353 || (iter
->step
->ts
.type
== BT_REAL
6354 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6356 gfc_error ("Step expression in DO loop at %L cannot be zero",
6357 &iter
->step
->where
);
6362 /* Convert start, end, and step to the same type as var. */
6363 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6364 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6365 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6367 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6368 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6369 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6371 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6372 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6373 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6375 if (iter
->start
->expr_type
== EXPR_CONSTANT
6376 && iter
->end
->expr_type
== EXPR_CONSTANT
6377 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6380 if (iter
->start
->ts
.type
== BT_INTEGER
)
6382 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6383 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6387 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6388 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6390 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6391 gfc_warning (OPT_Wzerotrip
,
6392 "DO loop at %L will be executed zero times",
6393 &iter
->step
->where
);
6400 /* Traversal function for find_forall_index. f == 2 signals that
6401 that variable itself is not to be checked - only the references. */
6404 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6406 if (expr
->expr_type
!= EXPR_VARIABLE
)
6409 /* A scalar assignment */
6410 if (!expr
->ref
|| *f
== 1)
6412 if (expr
->symtree
->n
.sym
== sym
)
6424 /* Check whether the FORALL index appears in the expression or not.
6425 Returns true if SYM is found in EXPR. */
6428 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6430 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6437 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6438 to be a scalar INTEGER variable. The subscripts and stride are scalar
6439 INTEGERs, and if stride is a constant it must be nonzero.
6440 Furthermore "A subscript or stride in a forall-triplet-spec shall
6441 not contain a reference to any index-name in the
6442 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6445 resolve_forall_iterators (gfc_forall_iterator
*it
)
6447 gfc_forall_iterator
*iter
, *iter2
;
6449 for (iter
= it
; iter
; iter
= iter
->next
)
6451 if (gfc_resolve_expr (iter
->var
)
6452 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6453 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6456 if (gfc_resolve_expr (iter
->start
)
6457 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6458 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6459 &iter
->start
->where
);
6460 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6461 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6463 if (gfc_resolve_expr (iter
->end
)
6464 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6465 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6467 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6468 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6470 if (gfc_resolve_expr (iter
->stride
))
6472 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6473 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6474 &iter
->stride
->where
, "INTEGER");
6476 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6477 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6478 gfc_error ("FORALL stride expression at %L cannot be zero",
6479 &iter
->stride
->where
);
6481 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6482 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6485 for (iter
= it
; iter
; iter
= iter
->next
)
6486 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6488 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6489 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6490 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6491 gfc_error ("FORALL index %qs may not appear in triplet "
6492 "specification at %L", iter
->var
->symtree
->name
,
6493 &iter2
->start
->where
);
6498 /* Given a pointer to a symbol that is a derived type, see if it's
6499 inaccessible, i.e. if it's defined in another module and the components are
6500 PRIVATE. The search is recursive if necessary. Returns zero if no
6501 inaccessible components are found, nonzero otherwise. */
6504 derived_inaccessible (gfc_symbol
*sym
)
6508 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6511 for (c
= sym
->components
; c
; c
= c
->next
)
6513 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6521 /* Resolve the argument of a deallocate expression. The expression must be
6522 a pointer or a full array. */
6525 resolve_deallocate_expr (gfc_expr
*e
)
6527 symbol_attribute attr
;
6528 int allocatable
, pointer
;
6534 if (!gfc_resolve_expr (e
))
6537 if (e
->expr_type
!= EXPR_VARIABLE
)
6540 sym
= e
->symtree
->n
.sym
;
6541 unlimited
= UNLIMITED_POLY(sym
);
6543 if (sym
->ts
.type
== BT_CLASS
)
6545 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6546 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6550 allocatable
= sym
->attr
.allocatable
;
6551 pointer
= sym
->attr
.pointer
;
6553 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6558 if (ref
->u
.ar
.type
!= AR_FULL
6559 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6560 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6565 c
= ref
->u
.c
.component
;
6566 if (c
->ts
.type
== BT_CLASS
)
6568 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6569 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6573 allocatable
= c
->attr
.allocatable
;
6574 pointer
= c
->attr
.pointer
;
6584 attr
= gfc_expr_attr (e
);
6586 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6589 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6595 if (gfc_is_coindexed (e
))
6597 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6602 && !gfc_check_vardef_context (e
, true, true, false,
6603 _("DEALLOCATE object")))
6605 if (!gfc_check_vardef_context (e
, false, true, false,
6606 _("DEALLOCATE object")))
6613 /* Returns true if the expression e contains a reference to the symbol sym. */
6615 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6617 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6624 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6626 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6630 /* Given the expression node e for an allocatable/pointer of derived type to be
6631 allocated, get the expression node to be initialized afterwards (needed for
6632 derived types with default initializers, and derived types with allocatable
6633 components that need nullification.) */
6636 gfc_expr_to_initialize (gfc_expr
*e
)
6642 result
= gfc_copy_expr (e
);
6644 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6645 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6646 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6648 ref
->u
.ar
.type
= AR_FULL
;
6650 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6651 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6656 gfc_free_shape (&result
->shape
, result
->rank
);
6658 /* Recalculate rank, shape, etc. */
6659 gfc_resolve_expr (result
);
6664 /* If the last ref of an expression is an array ref, return a copy of the
6665 expression with that one removed. Otherwise, a copy of the original
6666 expression. This is used for allocate-expressions and pointer assignment
6667 LHS, where there may be an array specification that needs to be stripped
6668 off when using gfc_check_vardef_context. */
6671 remove_last_array_ref (gfc_expr
* e
)
6676 e2
= gfc_copy_expr (e
);
6677 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6678 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6680 gfc_free_ref_list (*r
);
6689 /* Used in resolve_allocate_expr to check that a allocation-object and
6690 a source-expr are conformable. This does not catch all possible
6691 cases; in particular a runtime checking is needed. */
6694 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6697 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6699 /* First compare rank. */
6700 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6701 || (!tail
&& e1
->rank
!= e2
->rank
))
6703 gfc_error ("Source-expr at %L must be scalar or have the "
6704 "same rank as the allocate-object at %L",
6705 &e1
->where
, &e2
->where
);
6716 for (i
= 0; i
< e1
->rank
; i
++)
6718 if (tail
->u
.ar
.start
[i
] == NULL
)
6721 if (tail
->u
.ar
.end
[i
])
6723 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6724 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6725 mpz_add_ui (s
, s
, 1);
6729 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6732 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6734 gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
6735 "have the same shape", &e1
->where
, &e2
->where
);
6748 /* Resolve the expression in an ALLOCATE statement, doing the additional
6749 checks to see whether the expression is OK or not. The expression must
6750 have a trailing array reference that gives the size of the array. */
6753 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6755 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6759 symbol_attribute attr
;
6760 gfc_ref
*ref
, *ref2
;
6763 gfc_symbol
*sym
= NULL
;
6768 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6769 checking of coarrays. */
6770 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6771 if (ref
->next
== NULL
)
6774 if (ref
&& ref
->type
== REF_ARRAY
)
6775 ref
->u
.ar
.in_allocate
= true;
6777 if (!gfc_resolve_expr (e
))
6780 /* Make sure the expression is allocatable or a pointer. If it is
6781 pointer, the next-to-last reference must be a pointer. */
6785 sym
= e
->symtree
->n
.sym
;
6787 /* Check whether ultimate component is abstract and CLASS. */
6790 /* Is the allocate-object unlimited polymorphic? */
6791 unlimited
= UNLIMITED_POLY(e
);
6793 if (e
->expr_type
!= EXPR_VARIABLE
)
6796 attr
= gfc_expr_attr (e
);
6797 pointer
= attr
.pointer
;
6798 dimension
= attr
.dimension
;
6799 codimension
= attr
.codimension
;
6803 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6805 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6806 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6807 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6808 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6809 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6813 allocatable
= sym
->attr
.allocatable
;
6814 pointer
= sym
->attr
.pointer
;
6815 dimension
= sym
->attr
.dimension
;
6816 codimension
= sym
->attr
.codimension
;
6821 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6826 if (ref
->u
.ar
.codimen
> 0)
6829 for (n
= ref
->u
.ar
.dimen
;
6830 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6831 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6838 if (ref
->next
!= NULL
)
6846 gfc_error ("Coindexed allocatable object at %L",
6851 c
= ref
->u
.c
.component
;
6852 if (c
->ts
.type
== BT_CLASS
)
6854 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6855 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6856 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6857 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6858 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6862 allocatable
= c
->attr
.allocatable
;
6863 pointer
= c
->attr
.pointer
;
6864 dimension
= c
->attr
.dimension
;
6865 codimension
= c
->attr
.codimension
;
6866 is_abstract
= c
->attr
.abstract
;
6878 /* Check for F08:C628. */
6879 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6881 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6886 /* Some checks for the SOURCE tag. */
6889 /* Check F03:C631. */
6890 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6892 gfc_error_1 ("Type of entity at %L is type incompatible with "
6893 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6897 /* Check F03:C632 and restriction following Note 6.18. */
6898 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6901 /* Check F03:C633. */
6902 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6904 gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
6905 "shall have the same kind type parameter",
6906 &e
->where
, &code
->expr3
->where
);
6910 /* Check F2008, C642. */
6911 if (code
->expr3
->ts
.type
== BT_DERIVED
6912 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6913 || (code
->expr3
->ts
.u
.derived
->from_intmod
6914 == INTMOD_ISO_FORTRAN_ENV
6915 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6916 == ISOFORTRAN_LOCK_TYPE
)))
6918 gfc_error_1 ("The source-expr at %L shall neither be of type "
6919 "LOCK_TYPE nor have a LOCK_TYPE component if "
6920 "allocate-object at %L is a coarray",
6921 &code
->expr3
->where
, &e
->where
);
6926 /* Check F08:C629. */
6927 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6930 gcc_assert (e
->ts
.type
== BT_CLASS
);
6931 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6932 "type-spec or source-expr", sym
->name
, &e
->where
);
6936 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6938 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6939 code
->ext
.alloc
.ts
.u
.cl
->length
);
6940 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6942 gfc_error ("Allocating %s at %L with type-spec requires the same "
6943 "character-length parameter as in the declaration",
6944 sym
->name
, &e
->where
);
6949 /* In the variable definition context checks, gfc_expr_attr is used
6950 on the expression. This is fooled by the array specification
6951 present in e, thus we have to eliminate that one temporarily. */
6952 e2
= remove_last_array_ref (e
);
6955 t
= gfc_check_vardef_context (e2
, true, true, false,
6956 _("ALLOCATE object"));
6958 t
= gfc_check_vardef_context (e2
, false, true, false,
6959 _("ALLOCATE object"));
6964 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6965 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6967 /* For class arrays, the initialization with SOURCE is done
6968 using _copy and trans_call. It is convenient to exploit that
6969 when the allocated type is different from the declared type but
6970 no SOURCE exists by setting expr3. */
6971 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6973 else if (!code
->expr3
)
6975 /* Set up default initializer if needed. */
6979 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6980 ts
= code
->ext
.alloc
.ts
;
6984 if (ts
.type
== BT_CLASS
)
6985 ts
= ts
.u
.derived
->components
->ts
;
6987 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6989 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6990 init_st
->loc
= code
->loc
;
6991 init_st
->expr1
= gfc_expr_to_initialize (e
);
6992 init_st
->expr2
= init_e
;
6993 init_st
->next
= code
->next
;
6994 code
->next
= init_st
;
6997 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6999 /* Default initialization via MOLD (non-polymorphic). */
7000 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7003 gfc_resolve_expr (rhs
);
7004 gfc_free_expr (code
->expr3
);
7009 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7011 /* Make sure the vtab symbol is present when
7012 the module variables are generated. */
7013 gfc_typespec ts
= e
->ts
;
7015 ts
= code
->expr3
->ts
;
7016 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7017 ts
= code
->ext
.alloc
.ts
;
7019 gfc_find_derived_vtab (ts
.u
.derived
);
7022 e
= gfc_expr_to_initialize (e
);
7024 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7026 /* Again, make sure the vtab symbol is present when
7027 the module variables are generated. */
7028 gfc_typespec
*ts
= NULL
;
7030 ts
= &code
->expr3
->ts
;
7032 ts
= &code
->ext
.alloc
.ts
;
7039 e
= gfc_expr_to_initialize (e
);
7042 if (dimension
== 0 && codimension
== 0)
7045 /* Make sure the last reference node is an array specification. */
7047 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7048 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7050 gfc_error ("Array specification required in ALLOCATE statement "
7051 "at %L", &e
->where
);
7055 /* Make sure that the array section reference makes sense in the
7056 context of an ALLOCATE specification. */
7061 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7062 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7064 gfc_error ("Coarray specification required in ALLOCATE statement "
7065 "at %L", &e
->where
);
7069 for (i
= 0; i
< ar
->dimen
; i
++)
7071 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7074 switch (ar
->dimen_type
[i
])
7080 if (ar
->start
[i
] != NULL
7081 && ar
->end
[i
] != NULL
7082 && ar
->stride
[i
] == NULL
)
7085 /* Fall Through... */
7090 case DIMEN_THIS_IMAGE
:
7091 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7097 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7099 sym
= a
->expr
->symtree
->n
.sym
;
7101 /* TODO - check derived type components. */
7102 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7105 if ((ar
->start
[i
] != NULL
7106 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7107 || (ar
->end
[i
] != NULL
7108 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7110 gfc_error ("%qs must not appear in the array specification at "
7111 "%L in the same ALLOCATE statement where it is "
7112 "itself allocated", sym
->name
, &ar
->where
);
7118 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7120 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7121 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7123 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7125 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7126 "statement at %L", &e
->where
);
7132 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7133 && ar
->stride
[i
] == NULL
)
7136 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7149 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7151 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7152 gfc_alloc
*a
, *p
, *q
;
7155 errmsg
= code
->expr2
;
7157 /* Check the stat variable. */
7160 gfc_check_vardef_context (stat
, false, false, false,
7161 _("STAT variable"));
7163 if ((stat
->ts
.type
!= BT_INTEGER
7164 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7165 || stat
->ref
->type
== REF_COMPONENT
)))
7167 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7168 "variable", &stat
->where
);
7170 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7171 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7173 gfc_ref
*ref1
, *ref2
;
7176 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7177 ref1
= ref1
->next
, ref2
= ref2
->next
)
7179 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7181 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7190 gfc_error ("Stat-variable at %L shall not be %sd within "
7191 "the same %s statement", &stat
->where
, fcn
, fcn
);
7197 /* Check the errmsg variable. */
7201 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7204 gfc_check_vardef_context (errmsg
, false, false, false,
7205 _("ERRMSG variable"));
7207 if ((errmsg
->ts
.type
!= BT_CHARACTER
7209 && (errmsg
->ref
->type
== REF_ARRAY
7210 || errmsg
->ref
->type
== REF_COMPONENT
)))
7211 || errmsg
->rank
> 0 )
7212 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7213 "variable", &errmsg
->where
);
7215 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7216 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7218 gfc_ref
*ref1
, *ref2
;
7221 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7222 ref1
= ref1
->next
, ref2
= ref2
->next
)
7224 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7226 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7235 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7236 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7242 /* Check that an allocate-object appears only once in the statement. */
7244 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7247 for (q
= p
->next
; q
; q
= q
->next
)
7250 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7252 /* This is a potential collision. */
7253 gfc_ref
*pr
= pe
->ref
;
7254 gfc_ref
*qr
= qe
->ref
;
7256 /* Follow the references until
7257 a) They start to differ, in which case there is no error;
7258 you can deallocate a%b and a%c in a single statement
7259 b) Both of them stop, which is an error
7260 c) One of them stops, which is also an error. */
7263 if (pr
== NULL
&& qr
== NULL
)
7265 gfc_error_1 ("Allocate-object at %L also appears at %L",
7266 &pe
->where
, &qe
->where
);
7269 else if (pr
!= NULL
&& qr
== NULL
)
7271 gfc_error_1 ("Allocate-object at %L is subobject of"
7272 " object at %L", &pe
->where
, &qe
->where
);
7275 else if (pr
== NULL
&& qr
!= NULL
)
7277 gfc_error_1 ("Allocate-object at %L is subobject of"
7278 " object at %L", &qe
->where
, &pe
->where
);
7281 /* Here, pr != NULL && qr != NULL */
7282 gcc_assert(pr
->type
== qr
->type
);
7283 if (pr
->type
== REF_ARRAY
)
7285 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7287 gcc_assert (qr
->type
== REF_ARRAY
);
7289 if (pr
->next
&& qr
->next
)
7292 gfc_array_ref
*par
= &(pr
->u
.ar
);
7293 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7295 for (i
=0; i
<par
->dimen
; i
++)
7297 if ((par
->start
[i
] != NULL
7298 || qar
->start
[i
] != NULL
)
7299 && gfc_dep_compare_expr (par
->start
[i
],
7300 qar
->start
[i
]) != 0)
7307 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7320 if (strcmp (fcn
, "ALLOCATE") == 0)
7322 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7323 resolve_allocate_expr (a
->expr
, code
);
7327 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7328 resolve_deallocate_expr (a
->expr
);
7333 /************ SELECT CASE resolution subroutines ************/
7335 /* Callback function for our mergesort variant. Determines interval
7336 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7337 op1 > op2. Assumes we're not dealing with the default case.
7338 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7339 There are nine situations to check. */
7342 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7346 if (op1
->low
== NULL
) /* op1 = (:L) */
7348 /* op2 = (:N), so overlap. */
7350 /* op2 = (M:) or (M:N), L < M */
7351 if (op2
->low
!= NULL
7352 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7355 else if (op1
->high
== NULL
) /* op1 = (K:) */
7357 /* op2 = (M:), so overlap. */
7359 /* op2 = (:N) or (M:N), K > N */
7360 if (op2
->high
!= NULL
7361 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7364 else /* op1 = (K:L) */
7366 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7367 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7369 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7370 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7372 else /* op2 = (M:N) */
7376 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7379 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7388 /* Merge-sort a double linked case list, detecting overlap in the
7389 process. LIST is the head of the double linked case list before it
7390 is sorted. Returns the head of the sorted list if we don't see any
7391 overlap, or NULL otherwise. */
7394 check_case_overlap (gfc_case
*list
)
7396 gfc_case
*p
, *q
, *e
, *tail
;
7397 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7399 /* If the passed list was empty, return immediately. */
7406 /* Loop unconditionally. The only exit from this loop is a return
7407 statement, when we've finished sorting the case list. */
7414 /* Count the number of merges we do in this pass. */
7417 /* Loop while there exists a merge to be done. */
7422 /* Count this merge. */
7425 /* Cut the list in two pieces by stepping INSIZE places
7426 forward in the list, starting from P. */
7429 for (i
= 0; i
< insize
; i
++)
7438 /* Now we have two lists. Merge them! */
7439 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7441 /* See from which the next case to merge comes from. */
7444 /* P is empty so the next case must come from Q. */
7449 else if (qsize
== 0 || q
== NULL
)
7458 cmp
= compare_cases (p
, q
);
7461 /* The whole case range for P is less than the
7469 /* The whole case range for Q is greater than
7470 the case range for P. */
7477 /* The cases overlap, or they are the same
7478 element in the list. Either way, we must
7479 issue an error and get the next case from P. */
7480 /* FIXME: Sort P and Q by line number. */
7481 gfc_error_1 ("CASE label at %L overlaps with CASE "
7482 "label at %L", &p
->where
, &q
->where
);
7490 /* Add the next element to the merged list. */
7499 /* P has now stepped INSIZE places along, and so has Q. So
7500 they're the same. */
7505 /* If we have done only one merge or none at all, we've
7506 finished sorting the cases. */
7515 /* Otherwise repeat, merging lists twice the size. */
7521 /* Check to see if an expression is suitable for use in a CASE statement.
7522 Makes sure that all case expressions are scalar constants of the same
7523 type. Return false if anything is wrong. */
7526 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7528 if (e
== NULL
) return true;
7530 if (e
->ts
.type
!= case_expr
->ts
.type
)
7532 gfc_error ("Expression in CASE statement at %L must be of type %s",
7533 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7537 /* C805 (R808) For a given case-construct, each case-value shall be of
7538 the same type as case-expr. For character type, length differences
7539 are allowed, but the kind type parameters shall be the same. */
7541 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7543 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7544 &e
->where
, case_expr
->ts
.kind
);
7548 /* Convert the case value kind to that of case expression kind,
7551 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7552 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7556 gfc_error ("Expression in CASE statement at %L must be scalar",
7565 /* Given a completely parsed select statement, we:
7567 - Validate all expressions and code within the SELECT.
7568 - Make sure that the selection expression is not of the wrong type.
7569 - Make sure that no case ranges overlap.
7570 - Eliminate unreachable cases and unreachable code resulting from
7571 removing case labels.
7573 The standard does allow unreachable cases, e.g. CASE (5:3). But
7574 they are a hassle for code generation, and to prevent that, we just
7575 cut them out here. This is not necessary for overlapping cases
7576 because they are illegal and we never even try to generate code.
7578 We have the additional caveat that a SELECT construct could have
7579 been a computed GOTO in the source code. Fortunately we can fairly
7580 easily work around that here: The case_expr for a "real" SELECT CASE
7581 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7582 we have to do is make sure that the case_expr is a scalar integer
7586 resolve_select (gfc_code
*code
, bool select_type
)
7589 gfc_expr
*case_expr
;
7590 gfc_case
*cp
, *default_case
, *tail
, *head
;
7591 int seen_unreachable
;
7597 if (code
->expr1
== NULL
)
7599 /* This was actually a computed GOTO statement. */
7600 case_expr
= code
->expr2
;
7601 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7602 gfc_error ("Selection expression in computed GOTO statement "
7603 "at %L must be a scalar integer expression",
7606 /* Further checking is not necessary because this SELECT was built
7607 by the compiler, so it should always be OK. Just move the
7608 case_expr from expr2 to expr so that we can handle computed
7609 GOTOs as normal SELECTs from here on. */
7610 code
->expr1
= code
->expr2
;
7615 case_expr
= code
->expr1
;
7616 type
= case_expr
->ts
.type
;
7619 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7621 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7622 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7624 /* Punt. Going on here just produce more garbage error messages. */
7629 if (!select_type
&& case_expr
->rank
!= 0)
7631 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7632 "expression", &case_expr
->where
);
7638 /* Raise a warning if an INTEGER case value exceeds the range of
7639 the case-expr. Later, all expressions will be promoted to the
7640 largest kind of all case-labels. */
7642 if (type
== BT_INTEGER
)
7643 for (body
= code
->block
; body
; body
= body
->block
)
7644 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7647 && gfc_check_integer_range (cp
->low
->value
.integer
,
7648 case_expr
->ts
.kind
) != ARITH_OK
)
7649 gfc_warning (0, "Expression in CASE statement at %L is "
7650 "not in the range of %s", &cp
->low
->where
,
7651 gfc_typename (&case_expr
->ts
));
7654 && cp
->low
!= cp
->high
7655 && gfc_check_integer_range (cp
->high
->value
.integer
,
7656 case_expr
->ts
.kind
) != ARITH_OK
)
7657 gfc_warning (0, "Expression in CASE statement at %L is "
7658 "not in the range of %s", &cp
->high
->where
,
7659 gfc_typename (&case_expr
->ts
));
7662 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7663 of the SELECT CASE expression and its CASE values. Walk the lists
7664 of case values, and if we find a mismatch, promote case_expr to
7665 the appropriate kind. */
7667 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7669 for (body
= code
->block
; body
; body
= body
->block
)
7671 /* Walk the case label list. */
7672 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7674 /* Intercept the DEFAULT case. It does not have a kind. */
7675 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7678 /* Unreachable case ranges are discarded, so ignore. */
7679 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7680 && cp
->low
!= cp
->high
7681 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7685 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7686 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7688 if (cp
->high
!= NULL
7689 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7690 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7695 /* Assume there is no DEFAULT case. */
7696 default_case
= NULL
;
7701 for (body
= code
->block
; body
; body
= body
->block
)
7703 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7705 seen_unreachable
= 0;
7707 /* Walk the case label list, making sure that all case labels
7709 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7711 /* Count the number of cases in the whole construct. */
7714 /* Intercept the DEFAULT case. */
7715 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7717 if (default_case
!= NULL
)
7719 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
7720 "by a second DEFAULT CASE at %L",
7721 &default_case
->where
, &cp
->where
);
7732 /* Deal with single value cases and case ranges. Errors are
7733 issued from the validation function. */
7734 if (!validate_case_label_expr (cp
->low
, case_expr
)
7735 || !validate_case_label_expr (cp
->high
, case_expr
))
7741 if (type
== BT_LOGICAL
7742 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7743 || cp
->low
!= cp
->high
))
7745 gfc_error ("Logical range in CASE statement at %L is not "
7746 "allowed", &cp
->low
->where
);
7751 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7754 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7755 if (value
& seen_logical
)
7757 gfc_error ("Constant logical value in CASE statement "
7758 "is repeated at %L",
7763 seen_logical
|= value
;
7766 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7767 && cp
->low
!= cp
->high
7768 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7770 if (warn_surprising
)
7771 gfc_warning (OPT_Wsurprising
,
7772 "Range specification at %L can never be matched",
7775 cp
->unreachable
= 1;
7776 seen_unreachable
= 1;
7780 /* If the case range can be matched, it can also overlap with
7781 other cases. To make sure it does not, we put it in a
7782 double linked list here. We sort that with a merge sort
7783 later on to detect any overlapping cases. */
7787 head
->right
= head
->left
= NULL
;
7792 tail
->right
->left
= tail
;
7799 /* It there was a failure in the previous case label, give up
7800 for this case label list. Continue with the next block. */
7804 /* See if any case labels that are unreachable have been seen.
7805 If so, we eliminate them. This is a bit of a kludge because
7806 the case lists for a single case statement (label) is a
7807 single forward linked lists. */
7808 if (seen_unreachable
)
7810 /* Advance until the first case in the list is reachable. */
7811 while (body
->ext
.block
.case_list
!= NULL
7812 && body
->ext
.block
.case_list
->unreachable
)
7814 gfc_case
*n
= body
->ext
.block
.case_list
;
7815 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7817 gfc_free_case_list (n
);
7820 /* Strip all other unreachable cases. */
7821 if (body
->ext
.block
.case_list
)
7823 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7825 if (cp
->next
->unreachable
)
7827 gfc_case
*n
= cp
->next
;
7828 cp
->next
= cp
->next
->next
;
7830 gfc_free_case_list (n
);
7837 /* See if there were overlapping cases. If the check returns NULL,
7838 there was overlap. In that case we don't do anything. If head
7839 is non-NULL, we prepend the DEFAULT case. The sorted list can
7840 then used during code generation for SELECT CASE constructs with
7841 a case expression of a CHARACTER type. */
7844 head
= check_case_overlap (head
);
7846 /* Prepend the default_case if it is there. */
7847 if (head
!= NULL
&& default_case
)
7849 default_case
->left
= NULL
;
7850 default_case
->right
= head
;
7851 head
->left
= default_case
;
7855 /* Eliminate dead blocks that may be the result if we've seen
7856 unreachable case labels for a block. */
7857 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7859 if (body
->block
->ext
.block
.case_list
== NULL
)
7861 /* Cut the unreachable block from the code chain. */
7862 gfc_code
*c
= body
->block
;
7863 body
->block
= c
->block
;
7865 /* Kill the dead block, but not the blocks below it. */
7867 gfc_free_statements (c
);
7871 /* More than two cases is legal but insane for logical selects.
7872 Issue a warning for it. */
7873 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
7874 gfc_warning (OPT_Wsurprising
,
7875 "Logical SELECT CASE block at %L has more that two cases",
7880 /* Check if a derived type is extensible. */
7883 gfc_type_is_extensible (gfc_symbol
*sym
)
7885 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7886 || (sym
->attr
.is_class
7887 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7891 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7892 correct as well as possibly the array-spec. */
7895 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7899 gcc_assert (sym
->assoc
);
7900 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7902 /* If this is for SELECT TYPE, the target may not yet be set. In that
7903 case, return. Resolution will be called later manually again when
7905 target
= sym
->assoc
->target
;
7908 gcc_assert (!sym
->assoc
->dangling
);
7910 if (resolve_target
&& !gfc_resolve_expr (target
))
7913 /* For variable targets, we get some attributes from the target. */
7914 if (target
->expr_type
== EXPR_VARIABLE
)
7918 gcc_assert (target
->symtree
);
7919 tsym
= target
->symtree
->n
.sym
;
7921 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7922 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7924 sym
->attr
.target
= tsym
->attr
.target
7925 || gfc_expr_attr (target
).pointer
;
7926 if (is_subref_array (target
))
7927 sym
->attr
.subref_array_pointer
= 1;
7930 /* Get type if this was not already set. Note that it can be
7931 some other type than the target in case this is a SELECT TYPE
7932 selector! So we must not update when the type is already there. */
7933 if (sym
->ts
.type
== BT_UNKNOWN
)
7934 sym
->ts
= target
->ts
;
7935 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7937 /* See if this is a valid association-to-variable. */
7938 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7939 && !gfc_has_vector_subscript (target
));
7941 /* Finally resolve if this is an array or not. */
7942 if (sym
->attr
.dimension
&& target
->rank
== 0)
7944 /* primary.c makes the assumption that a reference to an associate
7945 name followed by a left parenthesis is an array reference. */
7946 if (sym
->ts
.type
!= BT_CHARACTER
)
7947 gfc_error ("Associate-name %qs at %L is used as array",
7948 sym
->name
, &sym
->declared_at
);
7949 sym
->attr
.dimension
= 0;
7953 /* We cannot deal with class selectors that need temporaries. */
7954 if (target
->ts
.type
== BT_CLASS
7955 && gfc_ref_needs_temporary_p (target
->ref
))
7957 gfc_error ("CLASS selector at %L needs a temporary which is not "
7958 "yet implemented", &target
->where
);
7962 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7963 sym
->attr
.dimension
= 1;
7964 else if (target
->ts
.type
== BT_CLASS
)
7965 gfc_fix_class_refs (target
);
7967 /* The associate-name will have a correct type by now. Make absolutely
7968 sure that it has not picked up a dimension attribute. */
7969 if (sym
->ts
.type
== BT_CLASS
)
7970 sym
->attr
.dimension
= 0;
7972 if (sym
->attr
.dimension
)
7974 sym
->as
= gfc_get_array_spec ();
7975 sym
->as
->rank
= target
->rank
;
7976 sym
->as
->type
= AS_DEFERRED
;
7977 sym
->as
->corank
= gfc_get_corank (target
);
7980 /* Mark this as an associate variable. */
7981 sym
->attr
.associate_var
= 1;
7983 /* If the target is a good class object, so is the associate variable. */
7984 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7985 sym
->attr
.class_ok
= 1;
7989 /* Resolve a SELECT TYPE statement. */
7992 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7994 gfc_symbol
*selector_type
;
7995 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7996 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7999 char name
[GFC_MAX_SYMBOL_LEN
];
8004 ns
= code
->ext
.block
.ns
;
8007 /* Check for F03:C813. */
8008 if (code
->expr1
->ts
.type
!= BT_CLASS
8009 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8011 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8012 "at %L", &code
->loc
);
8016 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8021 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8022 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8023 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8025 /* F2008: C803 The selector expression must not be coindexed. */
8026 if (gfc_is_coindexed (code
->expr2
))
8028 gfc_error ("Selector at %L must not be coindexed",
8029 &code
->expr2
->where
);
8036 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8038 if (gfc_is_coindexed (code
->expr1
))
8040 gfc_error ("Selector at %L must not be coindexed",
8041 &code
->expr1
->where
);
8046 /* Loop over TYPE IS / CLASS IS cases. */
8047 for (body
= code
->block
; body
; body
= body
->block
)
8049 c
= body
->ext
.block
.case_list
;
8051 /* Check F03:C815. */
8052 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8053 && !selector_type
->attr
.unlimited_polymorphic
8054 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8056 gfc_error ("Derived type %qs at %L must be extensible",
8057 c
->ts
.u
.derived
->name
, &c
->where
);
8062 /* Check F03:C816. */
8063 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8064 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8065 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8067 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8068 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8069 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8071 gfc_error ("Unexpected intrinsic type %qs at %L",
8072 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8077 /* Check F03:C814. */
8078 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8080 gfc_error ("The type-spec at %L shall specify that each length "
8081 "type parameter is assumed", &c
->where
);
8086 /* Intercept the DEFAULT case. */
8087 if (c
->ts
.type
== BT_UNKNOWN
)
8089 /* Check F03:C818. */
8092 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
8093 "by a second DEFAULT CASE at %L",
8094 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8099 default_case
= body
;
8106 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8107 target if present. If there are any EXIT statements referring to the
8108 SELECT TYPE construct, this is no problem because the gfc_code
8109 reference stays the same and EXIT is equally possible from the BLOCK
8110 it is changed to. */
8111 code
->op
= EXEC_BLOCK
;
8114 gfc_association_list
* assoc
;
8116 assoc
= gfc_get_association_list ();
8117 assoc
->st
= code
->expr1
->symtree
;
8118 assoc
->target
= gfc_copy_expr (code
->expr2
);
8119 assoc
->target
->where
= code
->expr2
->where
;
8120 /* assoc->variable will be set by resolve_assoc_var. */
8122 code
->ext
.block
.assoc
= assoc
;
8123 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8125 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8128 code
->ext
.block
.assoc
= NULL
;
8130 /* Add EXEC_SELECT to switch on type. */
8131 new_st
= gfc_get_code (code
->op
);
8132 new_st
->expr1
= code
->expr1
;
8133 new_st
->expr2
= code
->expr2
;
8134 new_st
->block
= code
->block
;
8135 code
->expr1
= code
->expr2
= NULL
;
8140 ns
->code
->next
= new_st
;
8142 code
->op
= EXEC_SELECT
;
8144 gfc_add_vptr_component (code
->expr1
);
8145 gfc_add_hash_component (code
->expr1
);
8147 /* Loop over TYPE IS / CLASS IS cases. */
8148 for (body
= code
->block
; body
; body
= body
->block
)
8150 c
= body
->ext
.block
.case_list
;
8152 if (c
->ts
.type
== BT_DERIVED
)
8153 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8154 c
->ts
.u
.derived
->hash_value
);
8155 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8160 ivtab
= gfc_find_vtab (&c
->ts
);
8161 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8162 e
= CLASS_DATA (ivtab
)->initializer
;
8163 c
->low
= c
->high
= gfc_copy_expr (e
);
8166 else if (c
->ts
.type
== BT_UNKNOWN
)
8169 /* Associate temporary to selector. This should only be done
8170 when this case is actually true, so build a new ASSOCIATE
8171 that does precisely this here (instead of using the
8174 if (c
->ts
.type
== BT_CLASS
)
8175 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8176 else if (c
->ts
.type
== BT_DERIVED
)
8177 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8178 else if (c
->ts
.type
== BT_CHARACTER
)
8180 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8181 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8182 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8183 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8184 charlen
, c
->ts
.kind
);
8187 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8190 st
= gfc_find_symtree (ns
->sym_root
, name
);
8191 gcc_assert (st
->n
.sym
->assoc
);
8192 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8193 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8194 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8195 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8197 new_st
= gfc_get_code (EXEC_BLOCK
);
8198 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8199 new_st
->ext
.block
.ns
->code
= body
->next
;
8200 body
->next
= new_st
;
8202 /* Chain in the new list only if it is marked as dangling. Otherwise
8203 there is a CASE label overlap and this is already used. Just ignore,
8204 the error is diagnosed elsewhere. */
8205 if (st
->n
.sym
->assoc
->dangling
)
8207 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8208 st
->n
.sym
->assoc
->dangling
= 0;
8211 resolve_assoc_var (st
->n
.sym
, false);
8214 /* Take out CLASS IS cases for separate treatment. */
8216 while (body
&& body
->block
)
8218 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8220 /* Add to class_is list. */
8221 if (class_is
== NULL
)
8223 class_is
= body
->block
;
8228 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8229 tail
->block
= body
->block
;
8232 /* Remove from EXEC_SELECT list. */
8233 body
->block
= body
->block
->block
;
8246 /* Add a default case to hold the CLASS IS cases. */
8247 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8248 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8250 tail
->ext
.block
.case_list
= gfc_get_case ();
8251 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8253 default_case
= tail
;
8256 /* More than one CLASS IS block? */
8257 if (class_is
->block
)
8261 /* Sort CLASS IS blocks by extension level. */
8265 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8268 /* F03:C817 (check for doubles). */
8269 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8270 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8272 gfc_error ("Double CLASS IS block in SELECT TYPE "
8274 &c2
->ext
.block
.case_list
->where
);
8277 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8278 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8281 (*c1
)->block
= c2
->block
;
8291 /* Generate IF chain. */
8292 if_st
= gfc_get_code (EXEC_IF
);
8294 for (body
= class_is
; body
; body
= body
->block
)
8296 new_st
->block
= gfc_get_code (EXEC_IF
);
8297 new_st
= new_st
->block
;
8298 /* Set up IF condition: Call _gfortran_is_extension_of. */
8299 new_st
->expr1
= gfc_get_expr ();
8300 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8301 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8302 new_st
->expr1
->ts
.kind
= 4;
8303 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8304 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8305 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8306 /* Set up arguments. */
8307 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8308 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8309 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8310 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8311 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8312 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8313 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8314 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8315 new_st
->next
= body
->next
;
8317 if (default_case
->next
)
8319 new_st
->block
= gfc_get_code (EXEC_IF
);
8320 new_st
= new_st
->block
;
8321 new_st
->next
= default_case
->next
;
8324 /* Replace CLASS DEFAULT code by the IF chain. */
8325 default_case
->next
= if_st
;
8328 /* Resolve the internal code. This can not be done earlier because
8329 it requires that the sym->assoc of selectors is set already. */
8330 gfc_current_ns
= ns
;
8331 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8332 gfc_current_ns
= old_ns
;
8334 resolve_select (code
, true);
8338 /* Resolve a transfer statement. This is making sure that:
8339 -- a derived type being transferred has only non-pointer components
8340 -- a derived type being transferred doesn't have private components, unless
8341 it's being transferred from the module where the type was defined
8342 -- we're not trying to transfer a whole assumed size array. */
8345 resolve_transfer (gfc_code
*code
)
8354 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8355 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8356 exp
= exp
->value
.op
.op1
;
8358 if (exp
&& exp
->expr_type
== EXPR_NULL
8361 gfc_error ("Invalid context for NULL () intrinsic at %L",
8366 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8367 && exp
->expr_type
!= EXPR_FUNCTION
))
8370 /* If we are reading, the variable will be changed. Note that
8371 code->ext.dt may be NULL if the TRANSFER is related to
8372 an INQUIRE statement -- but in this case, we are not reading, either. */
8373 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8374 && !gfc_check_vardef_context (exp
, false, false, false,
8378 sym
= exp
->symtree
->n
.sym
;
8381 /* Go to actual component transferred. */
8382 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8383 if (ref
->type
== REF_COMPONENT
)
8384 ts
= &ref
->u
.c
.component
->ts
;
8386 if (ts
->type
== BT_CLASS
)
8388 /* FIXME: Test for defined input/output. */
8389 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8390 "it is processed by a defined input/output procedure",
8395 if (ts
->type
== BT_DERIVED
)
8397 /* Check that transferred derived type doesn't contain POINTER
8399 if (ts
->u
.derived
->attr
.pointer_comp
)
8401 gfc_error ("Data transfer element at %L cannot have POINTER "
8402 "components unless it is processed by a defined "
8403 "input/output procedure", &code
->loc
);
8408 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8410 gfc_error ("Data transfer element at %L cannot have "
8411 "procedure pointer components", &code
->loc
);
8415 if (ts
->u
.derived
->attr
.alloc_comp
)
8417 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8418 "components unless it is processed by a defined "
8419 "input/output procedure", &code
->loc
);
8423 /* C_PTR and C_FUNPTR have private components which means they can not
8424 be printed. However, if -std=gnu and not -pedantic, allow
8425 the component to be printed to help debugging. */
8426 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8428 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8429 "cannot have PRIVATE components", &code
->loc
))
8432 else if (derived_inaccessible (ts
->u
.derived
))
8434 gfc_error ("Data transfer element at %L cannot have "
8435 "PRIVATE components",&code
->loc
);
8440 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8441 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8443 gfc_error ("Data transfer element at %L cannot be a full reference to "
8444 "an assumed-size array", &code
->loc
);
8450 /*********** Toplevel code resolution subroutines ***********/
8452 /* Find the set of labels that are reachable from this block. We also
8453 record the last statement in each block. */
8456 find_reachable_labels (gfc_code
*block
)
8463 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8465 /* Collect labels in this block. We don't keep those corresponding
8466 to END {IF|SELECT}, these are checked in resolve_branch by going
8467 up through the code_stack. */
8468 for (c
= block
; c
; c
= c
->next
)
8470 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8471 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8474 /* Merge with labels from parent block. */
8477 gcc_assert (cs_base
->prev
->reachable_labels
);
8478 bitmap_ior_into (cs_base
->reachable_labels
,
8479 cs_base
->prev
->reachable_labels
);
8485 resolve_lock_unlock (gfc_code
*code
)
8487 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8488 && code
->expr1
->value
.function
.isym
8489 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8490 remove_caf_get_intrinsic (code
->expr1
);
8492 if (code
->expr1
->ts
.type
!= BT_DERIVED
8493 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8494 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8495 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8496 || code
->expr1
->rank
!= 0
8497 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8498 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8499 &code
->expr1
->where
);
8503 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8504 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8505 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8506 &code
->expr2
->where
);
8509 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8510 _("STAT variable")))
8515 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8516 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8517 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8518 &code
->expr3
->where
);
8521 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8522 _("ERRMSG variable")))
8525 /* Check ACQUIRED_LOCK. */
8527 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8528 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8529 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8530 "variable", &code
->expr4
->where
);
8533 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8534 _("ACQUIRED_LOCK variable")))
8540 resolve_critical (gfc_code
*code
)
8542 gfc_symtree
*symtree
;
8543 gfc_symbol
*lock_type
;
8544 char name
[GFC_MAX_SYMBOL_LEN
];
8545 static int serial
= 0;
8547 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8550 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8551 GFC_PREFIX ("lock_type"));
8553 lock_type
= symtree
->n
.sym
;
8556 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8559 lock_type
= symtree
->n
.sym
;
8560 lock_type
->attr
.flavor
= FL_DERIVED
;
8561 lock_type
->attr
.zero_comp
= 1;
8562 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8563 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8566 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8567 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8570 code
->resolved_sym
= symtree
->n
.sym
;
8571 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8572 symtree
->n
.sym
->attr
.referenced
= 1;
8573 symtree
->n
.sym
->attr
.artificial
= 1;
8574 symtree
->n
.sym
->attr
.codimension
= 1;
8575 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8576 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8577 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8578 symtree
->n
.sym
->as
->corank
= 1;
8579 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8580 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8581 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8587 resolve_sync (gfc_code
*code
)
8589 /* Check imageset. The * case matches expr1 == NULL. */
8592 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8593 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8594 "INTEGER expression", &code
->expr1
->where
);
8595 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8596 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8597 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8598 &code
->expr1
->where
);
8599 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8600 && gfc_simplify_expr (code
->expr1
, 0))
8602 gfc_constructor
*cons
;
8603 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8604 for (; cons
; cons
= gfc_constructor_next (cons
))
8605 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8606 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8607 gfc_error ("Imageset argument at %L must between 1 and "
8608 "num_images()", &cons
->expr
->where
);
8614 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8615 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8616 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8617 &code
->expr2
->where
);
8621 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8622 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8623 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8624 &code
->expr3
->where
);
8628 /* Given a branch to a label, see if the branch is conforming.
8629 The code node describes where the branch is located. */
8632 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8639 /* Step one: is this a valid branching target? */
8641 if (label
->defined
== ST_LABEL_UNKNOWN
)
8643 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8648 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8650 gfc_error_1 ("Statement at %L is not a valid branch target statement "
8651 "for the branch statement at %L", &label
->where
, &code
->loc
);
8655 /* Step two: make sure this branch is not a branch to itself ;-) */
8657 if (code
->here
== label
)
8660 "Branch at %L may result in an infinite loop", &code
->loc
);
8664 /* Step three: See if the label is in the same block as the
8665 branching statement. The hard work has been done by setting up
8666 the bitmap reachable_labels. */
8668 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8670 /* Check now whether there is a CRITICAL construct; if so, check
8671 whether the label is still visible outside of the CRITICAL block,
8672 which is invalid. */
8673 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8675 if (stack
->current
->op
== EXEC_CRITICAL
8676 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8677 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
8678 "label at %L", &code
->loc
, &label
->where
);
8679 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8680 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8681 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
8682 "for label at %L", &code
->loc
, &label
->where
);
8688 /* Step four: If we haven't found the label in the bitmap, it may
8689 still be the label of the END of the enclosing block, in which
8690 case we find it by going up the code_stack. */
8692 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8694 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8696 if (stack
->current
->op
== EXEC_CRITICAL
)
8698 /* Note: A label at END CRITICAL does not leave the CRITICAL
8699 construct as END CRITICAL is still part of it. */
8700 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
8701 " at %L", &code
->loc
, &label
->where
);
8704 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8706 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
8707 "label at %L", &code
->loc
, &label
->where
);
8714 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8718 /* The label is not in an enclosing block, so illegal. This was
8719 allowed in Fortran 66, so we allow it as extension. No
8720 further checks are necessary in this case. */
8721 gfc_notify_std_1 (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8722 "as the GOTO statement at %L", &label
->where
,
8728 /* Check whether EXPR1 has the same shape as EXPR2. */
8731 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8733 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8734 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8735 bool result
= false;
8738 /* Compare the rank. */
8739 if (expr1
->rank
!= expr2
->rank
)
8742 /* Compare the size of each dimension. */
8743 for (i
=0; i
<expr1
->rank
; i
++)
8745 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8748 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8751 if (mpz_cmp (shape
[i
], shape2
[i
]))
8755 /* When either of the two expression is an assumed size array, we
8756 ignore the comparison of dimension sizes. */
8761 gfc_clear_shape (shape
, i
);
8762 gfc_clear_shape (shape2
, i
);
8767 /* Check whether a WHERE assignment target or a WHERE mask expression
8768 has the same shape as the outmost WHERE mask expression. */
8771 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8777 cblock
= code
->block
;
8779 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8780 In case of nested WHERE, only the outmost one is stored. */
8781 if (mask
== NULL
) /* outmost WHERE */
8783 else /* inner WHERE */
8790 /* Check if the mask-expr has a consistent shape with the
8791 outmost WHERE mask-expr. */
8792 if (!resolve_where_shape (cblock
->expr1
, e
))
8793 gfc_error ("WHERE mask at %L has inconsistent shape",
8794 &cblock
->expr1
->where
);
8797 /* the assignment statement of a WHERE statement, or the first
8798 statement in where-body-construct of a WHERE construct */
8799 cnext
= cblock
->next
;
8804 /* WHERE assignment statement */
8807 /* Check shape consistent for WHERE assignment target. */
8808 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8809 gfc_error ("WHERE assignment target at %L has "
8810 "inconsistent shape", &cnext
->expr1
->where
);
8814 case EXEC_ASSIGN_CALL
:
8815 resolve_call (cnext
);
8816 if (!cnext
->resolved_sym
->attr
.elemental
)
8817 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8818 &cnext
->ext
.actual
->expr
->where
);
8821 /* WHERE or WHERE construct is part of a where-body-construct */
8823 resolve_where (cnext
, e
);
8827 gfc_error ("Unsupported statement inside WHERE at %L",
8830 /* the next statement within the same where-body-construct */
8831 cnext
= cnext
->next
;
8833 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8834 cblock
= cblock
->block
;
8839 /* Resolve assignment in FORALL construct.
8840 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8841 FORALL index variables. */
8844 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8848 for (n
= 0; n
< nvar
; n
++)
8850 gfc_symbol
*forall_index
;
8852 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8854 /* Check whether the assignment target is one of the FORALL index
8856 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8857 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8858 gfc_error ("Assignment to a FORALL index variable at %L",
8859 &code
->expr1
->where
);
8862 /* If one of the FORALL index variables doesn't appear in the
8863 assignment variable, then there could be a many-to-one
8864 assignment. Emit a warning rather than an error because the
8865 mask could be resolving this problem. */
8866 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8867 gfc_warning (0, "The FORALL with index %qs is not used on the "
8868 "left side of the assignment at %L and so might "
8869 "cause multiple assignment to this object",
8870 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8876 /* Resolve WHERE statement in FORALL construct. */
8879 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8880 gfc_expr
**var_expr
)
8885 cblock
= code
->block
;
8888 /* the assignment statement of a WHERE statement, or the first
8889 statement in where-body-construct of a WHERE construct */
8890 cnext
= cblock
->next
;
8895 /* WHERE assignment statement */
8897 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8900 /* WHERE operator assignment statement */
8901 case EXEC_ASSIGN_CALL
:
8902 resolve_call (cnext
);
8903 if (!cnext
->resolved_sym
->attr
.elemental
)
8904 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8905 &cnext
->ext
.actual
->expr
->where
);
8908 /* WHERE or WHERE construct is part of a where-body-construct */
8910 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8914 gfc_error ("Unsupported statement inside WHERE at %L",
8917 /* the next statement within the same where-body-construct */
8918 cnext
= cnext
->next
;
8920 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8921 cblock
= cblock
->block
;
8926 /* Traverse the FORALL body to check whether the following errors exist:
8927 1. For assignment, check if a many-to-one assignment happens.
8928 2. For WHERE statement, check the WHERE body to see if there is any
8929 many-to-one assignment. */
8932 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8936 c
= code
->block
->next
;
8942 case EXEC_POINTER_ASSIGN
:
8943 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8946 case EXEC_ASSIGN_CALL
:
8950 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8951 there is no need to handle it here. */
8955 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8960 /* The next statement in the FORALL body. */
8966 /* Counts the number of iterators needed inside a forall construct, including
8967 nested forall constructs. This is used to allocate the needed memory
8968 in gfc_resolve_forall. */
8971 gfc_count_forall_iterators (gfc_code
*code
)
8973 int max_iters
, sub_iters
, current_iters
;
8974 gfc_forall_iterator
*fa
;
8976 gcc_assert(code
->op
== EXEC_FORALL
);
8980 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8983 code
= code
->block
->next
;
8987 if (code
->op
== EXEC_FORALL
)
8989 sub_iters
= gfc_count_forall_iterators (code
);
8990 if (sub_iters
> max_iters
)
8991 max_iters
= sub_iters
;
8996 return current_iters
+ max_iters
;
9000 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9001 gfc_resolve_forall_body to resolve the FORALL body. */
9004 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9006 static gfc_expr
**var_expr
;
9007 static int total_var
= 0;
9008 static int nvar
= 0;
9010 gfc_forall_iterator
*fa
;
9015 /* Start to resolve a FORALL construct */
9016 if (forall_save
== 0)
9018 /* Count the total number of FORALL index in the nested FORALL
9019 construct in order to allocate the VAR_EXPR with proper size. */
9020 total_var
= gfc_count_forall_iterators (code
);
9022 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9023 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9026 /* The information about FORALL iterator, including FORALL index start, end
9027 and stride. The FORALL index can not appear in start, end or stride. */
9028 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9030 /* Check if any outer FORALL index name is the same as the current
9032 for (i
= 0; i
< nvar
; i
++)
9034 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9036 gfc_error ("An outer FORALL construct already has an index "
9037 "with this name %L", &fa
->var
->where
);
9041 /* Record the current FORALL index. */
9042 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9046 /* No memory leak. */
9047 gcc_assert (nvar
<= total_var
);
9050 /* Resolve the FORALL body. */
9051 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9053 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9054 gfc_resolve_blocks (code
->block
, ns
);
9058 /* Free only the VAR_EXPRs allocated in this frame. */
9059 for (i
= nvar
; i
< tmp
; i
++)
9060 gfc_free_expr (var_expr
[i
]);
9064 /* We are in the outermost FORALL construct. */
9065 gcc_assert (forall_save
== 0);
9067 /* VAR_EXPR is not needed any more. */
9074 /* Resolve a BLOCK construct statement. */
9077 resolve_block_construct (gfc_code
* code
)
9079 /* Resolve the BLOCK's namespace. */
9080 gfc_resolve (code
->ext
.block
.ns
);
9082 /* For an ASSOCIATE block, the associations (and their targets) are already
9083 resolved during resolve_symbol. */
9087 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9091 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9095 for (; b
; b
= b
->block
)
9097 t
= gfc_resolve_expr (b
->expr1
);
9098 if (!gfc_resolve_expr (b
->expr2
))
9104 if (t
&& b
->expr1
!= NULL
9105 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9106 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9113 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9114 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9119 resolve_branch (b
->label1
, b
);
9123 resolve_block_construct (b
);
9127 case EXEC_SELECT_TYPE
:
9131 case EXEC_DO_CONCURRENT
:
9139 case EXEC_OACC_PARALLEL_LOOP
:
9140 case EXEC_OACC_PARALLEL
:
9141 case EXEC_OACC_KERNELS_LOOP
:
9142 case EXEC_OACC_KERNELS
:
9143 case EXEC_OACC_DATA
:
9144 case EXEC_OACC_HOST_DATA
:
9145 case EXEC_OACC_LOOP
:
9146 case EXEC_OACC_UPDATE
:
9147 case EXEC_OACC_WAIT
:
9148 case EXEC_OACC_CACHE
:
9149 case EXEC_OACC_ENTER_DATA
:
9150 case EXEC_OACC_EXIT_DATA
:
9151 case EXEC_OMP_ATOMIC
:
9152 case EXEC_OMP_CRITICAL
:
9153 case EXEC_OMP_DISTRIBUTE
:
9154 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9155 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9156 case EXEC_OMP_DISTRIBUTE_SIMD
:
9158 case EXEC_OMP_DO_SIMD
:
9159 case EXEC_OMP_MASTER
:
9160 case EXEC_OMP_ORDERED
:
9161 case EXEC_OMP_PARALLEL
:
9162 case EXEC_OMP_PARALLEL_DO
:
9163 case EXEC_OMP_PARALLEL_DO_SIMD
:
9164 case EXEC_OMP_PARALLEL_SECTIONS
:
9165 case EXEC_OMP_PARALLEL_WORKSHARE
:
9166 case EXEC_OMP_SECTIONS
:
9168 case EXEC_OMP_SINGLE
:
9169 case EXEC_OMP_TARGET
:
9170 case EXEC_OMP_TARGET_DATA
:
9171 case EXEC_OMP_TARGET_TEAMS
:
9172 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9173 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9174 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9175 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9176 case EXEC_OMP_TARGET_UPDATE
:
9178 case EXEC_OMP_TASKGROUP
:
9179 case EXEC_OMP_TASKWAIT
:
9180 case EXEC_OMP_TASKYIELD
:
9181 case EXEC_OMP_TEAMS
:
9182 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9183 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9184 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9185 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9186 case EXEC_OMP_WORKSHARE
:
9190 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9193 gfc_resolve_code (b
->next
, ns
);
9198 /* Does everything to resolve an ordinary assignment. Returns true
9199 if this is an interface assignment. */
9201 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9210 symbol_attribute attr
;
9212 if (gfc_extend_assign (code
, ns
))
9216 if (code
->op
== EXEC_ASSIGN_CALL
)
9218 lhs
= code
->ext
.actual
->expr
;
9219 rhsptr
= &code
->ext
.actual
->next
->expr
;
9223 gfc_actual_arglist
* args
;
9224 gfc_typebound_proc
* tbp
;
9226 gcc_assert (code
->op
== EXEC_COMPCALL
);
9228 args
= code
->expr1
->value
.compcall
.actual
;
9230 rhsptr
= &args
->next
->expr
;
9232 tbp
= code
->expr1
->value
.compcall
.tbp
;
9233 gcc_assert (!tbp
->is_generic
);
9236 /* Make a temporary rhs when there is a default initializer
9237 and rhs is the same symbol as the lhs. */
9238 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9239 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9240 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9241 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9242 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9251 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9252 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9256 /* Handle the case of a BOZ literal on the RHS. */
9257 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9260 if (warn_surprising
)
9261 gfc_warning (OPT_Wsurprising
,
9262 "BOZ literal at %L is bitwise transferred "
9263 "non-integer symbol %qs", &code
->loc
,
9264 lhs
->symtree
->n
.sym
->name
);
9266 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9268 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9270 if (rc
== ARITH_UNDERFLOW
)
9271 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9272 ". This check can be disabled with the option "
9273 "%<-fno-range-check%>", &rhs
->where
);
9274 else if (rc
== ARITH_OVERFLOW
)
9275 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9276 ". This check can be disabled with the option "
9277 "%<-fno-range-check%>", &rhs
->where
);
9278 else if (rc
== ARITH_NAN
)
9279 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9280 ". This check can be disabled with the option "
9281 "%<-fno-range-check%>", &rhs
->where
);
9286 if (lhs
->ts
.type
== BT_CHARACTER
9287 && warn_character_truncation
)
9289 if (lhs
->ts
.u
.cl
!= NULL
9290 && lhs
->ts
.u
.cl
->length
!= NULL
9291 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9292 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9294 if (rhs
->expr_type
== EXPR_CONSTANT
)
9295 rlen
= rhs
->value
.character
.length
;
9297 else if (rhs
->ts
.u
.cl
!= NULL
9298 && rhs
->ts
.u
.cl
->length
!= NULL
9299 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9300 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9302 if (rlen
&& llen
&& rlen
> llen
)
9303 gfc_warning_now (OPT_Wcharacter_truncation
,
9304 "CHARACTER expression will be truncated "
9305 "in assignment (%d/%d) at %L",
9306 llen
, rlen
, &code
->loc
);
9309 /* Ensure that a vector index expression for the lvalue is evaluated
9310 to a temporary if the lvalue symbol is referenced in it. */
9313 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9314 if (ref
->type
== REF_ARRAY
)
9316 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9317 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9318 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9319 ref
->u
.ar
.start
[n
]))
9321 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9325 if (gfc_pure (NULL
))
9327 if (lhs
->ts
.type
== BT_DERIVED
9328 && lhs
->expr_type
== EXPR_VARIABLE
9329 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9330 && rhs
->expr_type
== EXPR_VARIABLE
9331 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9332 || gfc_is_coindexed (rhs
)))
9335 if (gfc_is_coindexed (rhs
))
9336 gfc_error ("Coindexed expression at %L is assigned to "
9337 "a derived type variable with a POINTER "
9338 "component in a PURE procedure",
9341 gfc_error ("The impure variable at %L is assigned to "
9342 "a derived type variable with a POINTER "
9343 "component in a PURE procedure (12.6)",
9348 /* Fortran 2008, C1283. */
9349 if (gfc_is_coindexed (lhs
))
9351 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9352 "procedure", &rhs
->where
);
9357 if (gfc_implicit_pure (NULL
))
9359 if (lhs
->expr_type
== EXPR_VARIABLE
9360 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9361 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9362 gfc_unset_implicit_pure (NULL
);
9364 if (lhs
->ts
.type
== BT_DERIVED
9365 && lhs
->expr_type
== EXPR_VARIABLE
9366 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9367 && rhs
->expr_type
== EXPR_VARIABLE
9368 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9369 || gfc_is_coindexed (rhs
)))
9370 gfc_unset_implicit_pure (NULL
);
9372 /* Fortran 2008, C1283. */
9373 if (gfc_is_coindexed (lhs
))
9374 gfc_unset_implicit_pure (NULL
);
9377 /* F2008, 7.2.1.2. */
9378 attr
= gfc_expr_attr (lhs
);
9379 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9381 if (attr
.codimension
)
9383 gfc_error ("Assignment to polymorphic coarray at %L is not "
9384 "permitted", &lhs
->where
);
9387 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9388 "polymorphic variable at %L", &lhs
->where
))
9390 if (!flag_realloc_lhs
)
9392 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9393 "requires %<-frealloc-lhs%>", &lhs
->where
);
9397 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9398 "is not yet supported", &lhs
->where
);
9401 else if (lhs
->ts
.type
== BT_CLASS
)
9403 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9404 "assignment at %L - check that there is a matching specific "
9405 "subroutine for '=' operator", &lhs
->where
);
9409 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9411 /* F2008, Section 7.2.1.2. */
9412 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9414 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9415 "component in assignment at %L", &lhs
->where
);
9419 gfc_check_assign (lhs
, rhs
, 1);
9421 /* Assign the 'data' of a class object to a derived type. */
9422 if (lhs
->ts
.type
== BT_DERIVED
9423 && rhs
->ts
.type
== BT_CLASS
)
9424 gfc_add_data_component (rhs
);
9426 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9427 Additionally, insert this code when the RHS is a CAF as we then use the
9428 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9429 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9430 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9432 if (flag_coarray
== GFC_FCOARRAY_LIB
9434 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9435 && code
->expr2
->value
.function
.isym
9436 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9437 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9438 && !gfc_expr_attr (rhs
).allocatable
9439 && !gfc_has_vector_subscript (rhs
))))
9441 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9442 && code
->expr2
->value
.function
.isym
9443 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9444 remove_caf_get_intrinsic (code
->expr2
);
9445 code
->op
= EXEC_CALL
;
9446 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9447 code
->resolved_sym
= code
->symtree
->n
.sym
;
9448 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9449 code
->resolved_sym
->attr
.intrinsic
= 1;
9450 code
->resolved_sym
->attr
.subroutine
= 1;
9451 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9452 gfc_commit_symbol (code
->resolved_sym
);
9453 code
->ext
.actual
= gfc_get_actual_arglist ();
9454 code
->ext
.actual
->expr
= lhs
;
9455 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9456 code
->ext
.actual
->next
->expr
= rhs
;
9465 /* Add a component reference onto an expression. */
9468 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9473 ref
= &((*ref
)->next
);
9474 *ref
= gfc_get_ref ();
9475 (*ref
)->type
= REF_COMPONENT
;
9476 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9477 (*ref
)->u
.c
.component
= c
;
9480 /* Add a full array ref, as necessary. */
9483 gfc_add_full_array_ref (e
, c
->as
);
9484 e
->rank
= c
->as
->rank
;
9489 /* Build an assignment. Keep the argument 'op' for future use, so that
9490 pointer assignments can be made. */
9493 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9494 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9496 gfc_code
*this_code
;
9498 this_code
= gfc_get_code (op
);
9499 this_code
->next
= NULL
;
9500 this_code
->expr1
= gfc_copy_expr (expr1
);
9501 this_code
->expr2
= gfc_copy_expr (expr2
);
9502 this_code
->loc
= loc
;
9505 add_comp_ref (this_code
->expr1
, comp1
);
9506 add_comp_ref (this_code
->expr2
, comp2
);
9513 /* Makes a temporary variable expression based on the characteristics of
9514 a given variable expression. */
9517 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9519 static int serial
= 0;
9520 char name
[GFC_MAX_SYMBOL_LEN
];
9523 gfc_array_ref
*aref
;
9526 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9527 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9528 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9534 /* This function could be expanded to support other expression type
9535 but this is not needed here. */
9536 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9538 /* Obtain the arrayspec for the temporary. */
9541 aref
= gfc_find_array_ref (e
);
9542 if (e
->expr_type
== EXPR_VARIABLE
9543 && e
->symtree
->n
.sym
->as
== aref
->as
)
9547 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9548 if (ref
->type
== REF_COMPONENT
9549 && ref
->u
.c
.component
->as
== aref
->as
)
9557 /* Add the attributes and the arrayspec to the temporary. */
9558 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9559 tmp
->n
.sym
->attr
.function
= 0;
9560 tmp
->n
.sym
->attr
.result
= 0;
9561 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9565 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9568 if (as
->type
== AS_DEFERRED
)
9569 tmp
->n
.sym
->attr
.allocatable
= 1;
9572 tmp
->n
.sym
->attr
.dimension
= 0;
9574 gfc_set_sym_referenced (tmp
->n
.sym
);
9575 gfc_commit_symbol (tmp
->n
.sym
);
9576 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9578 /* Should the lhs be a section, use its array ref for the
9579 temporary expression. */
9580 if (aref
&& aref
->type
!= AR_FULL
)
9582 gfc_free_ref_list (e
->ref
);
9583 e
->ref
= gfc_copy_ref (ref
);
9589 /* Add one line of code to the code chain, making sure that 'head' and
9590 'tail' are appropriately updated. */
9593 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9595 gcc_assert (this_code
);
9597 *head
= *tail
= *this_code
;
9599 *tail
= gfc_append_code (*tail
, *this_code
);
9604 /* Counts the potential number of part array references that would
9605 result from resolution of typebound defined assignments. */
9608 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9611 int c_depth
= 0, t_depth
;
9613 for (c
= derived
->components
; c
; c
= c
->next
)
9615 if ((c
->ts
.type
!= BT_DERIVED
9617 || c
->attr
.allocatable
9618 || c
->attr
.proc_pointer_comp
9619 || c
->attr
.class_pointer
9620 || c
->attr
.proc_pointer
)
9621 && !c
->attr
.defined_assign_comp
)
9624 if (c
->as
&& c_depth
== 0)
9627 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9628 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9633 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9635 return depth
+ c_depth
;
9639 /* Implement 7.2.1.3 of the F08 standard:
9640 "An intrinsic assignment where the variable is of derived type is
9641 performed as if each component of the variable were assigned from the
9642 corresponding component of expr using pointer assignment (7.2.2) for
9643 each pointer component, defined assignment for each nonpointer
9644 nonallocatable component of a type that has a type-bound defined
9645 assignment consistent with the component, intrinsic assignment for
9646 each other nonpointer nonallocatable component, ..."
9648 The pointer assignments are taken care of by the intrinsic
9649 assignment of the structure itself. This function recursively adds
9650 defined assignments where required. The recursion is accomplished
9651 by calling gfc_resolve_code.
9653 When the lhs in a defined assignment has intent INOUT, we need a
9654 temporary for the lhs. In pseudo-code:
9656 ! Only call function lhs once.
9657 if (lhs is not a constant or an variable)
9660 ! Do the intrinsic assignment
9662 ! Now do the defined assignments
9663 do over components with typebound defined assignment [%cmp]
9664 #if one component's assignment procedure is INOUT
9666 #if expr2 non-variable
9672 t1%cmp {defined=} expr2%cmp
9678 expr1%cmp {defined=} expr2%cmp
9682 /* The temporary assignments have to be put on top of the additional
9683 code to avoid the result being changed by the intrinsic assignment.
9685 static int component_assignment_level
= 0;
9686 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9689 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9691 gfc_component
*comp1
, *comp2
;
9692 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9694 int error_count
, depth
;
9696 gfc_get_errors (NULL
, &error_count
);
9698 /* Filter out continuing processing after an error. */
9700 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9701 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9704 /* TODO: Handle more than one part array reference in assignments. */
9705 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9706 (*code
)->expr1
->rank
? 1 : 0);
9709 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
9710 "done because multiple part array references would "
9711 "occur in intermediate expressions.", &(*code
)->loc
);
9715 component_assignment_level
++;
9717 /* Create a temporary so that functions get called only once. */
9718 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9719 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9723 /* Assign the rhs to the temporary. */
9724 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9725 this_code
= build_assignment (EXEC_ASSIGN
,
9726 tmp_expr
, (*code
)->expr2
,
9727 NULL
, NULL
, (*code
)->loc
);
9728 /* Add the code and substitute the rhs expression. */
9729 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9730 gfc_free_expr ((*code
)->expr2
);
9731 (*code
)->expr2
= tmp_expr
;
9734 /* Do the intrinsic assignment. This is not needed if the lhs is one
9735 of the temporaries generated here, since the intrinsic assignment
9736 to the final result already does this. */
9737 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9739 this_code
= build_assignment (EXEC_ASSIGN
,
9740 (*code
)->expr1
, (*code
)->expr2
,
9741 NULL
, NULL
, (*code
)->loc
);
9742 add_code_to_chain (&this_code
, &head
, &tail
);
9745 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9746 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9749 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9753 /* The intrinsic assignment does the right thing for pointers
9754 of all kinds and allocatable components. */
9755 if (comp1
->ts
.type
!= BT_DERIVED
9756 || comp1
->attr
.pointer
9757 || comp1
->attr
.allocatable
9758 || comp1
->attr
.proc_pointer_comp
9759 || comp1
->attr
.class_pointer
9760 || comp1
->attr
.proc_pointer
)
9763 /* Make an assigment for this component. */
9764 this_code
= build_assignment (EXEC_ASSIGN
,
9765 (*code
)->expr1
, (*code
)->expr2
,
9766 comp1
, comp2
, (*code
)->loc
);
9768 /* Convert the assignment if there is a defined assignment for
9769 this type. Otherwise, using the call from gfc_resolve_code,
9770 recurse into its components. */
9771 gfc_resolve_code (this_code
, ns
);
9773 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9775 gfc_formal_arglist
*dummy_args
;
9777 /* Check that there is a typebound defined assignment. If not,
9778 then this must be a module defined assignment. We cannot
9779 use the defined_assign_comp attribute here because it must
9780 be this derived type that has the defined assignment and not
9782 if (!(comp1
->ts
.u
.derived
->f2k_derived
9783 && comp1
->ts
.u
.derived
->f2k_derived
9784 ->tb_op
[INTRINSIC_ASSIGN
]))
9786 gfc_free_statements (this_code
);
9791 /* If the first argument of the subroutine has intent INOUT
9792 a temporary must be generated and used instead. */
9793 rsym
= this_code
->resolved_sym
;
9794 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9796 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9798 gfc_code
*temp_code
;
9801 /* Build the temporary required for the assignment and put
9802 it at the head of the generated code. */
9805 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9806 temp_code
= build_assignment (EXEC_ASSIGN
,
9808 NULL
, NULL
, (*code
)->loc
);
9810 /* For allocatable LHS, check whether it is allocated. Note
9811 that allocatable components with defined assignment are
9812 not yet support. See PR 57696. */
9813 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9817 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9818 block
= gfc_get_code (EXEC_IF
);
9819 block
->block
= gfc_get_code (EXEC_IF
);
9821 = gfc_build_intrinsic_call (ns
,
9822 GFC_ISYM_ALLOCATED
, "allocated",
9823 (*code
)->loc
, 1, e
);
9824 block
->block
->next
= temp_code
;
9827 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9830 /* Replace the first actual arg with the component of the
9832 gfc_free_expr (this_code
->ext
.actual
->expr
);
9833 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9834 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9836 /* If the LHS variable is allocatable and wasn't allocated and
9837 the temporary is allocatable, pointer assign the address of
9838 the freshly allocated LHS to the temporary. */
9839 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9840 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9845 cond
= gfc_get_expr ();
9846 cond
->ts
.type
= BT_LOGICAL
;
9847 cond
->ts
.kind
= gfc_default_logical_kind
;
9848 cond
->expr_type
= EXPR_OP
;
9849 cond
->where
= (*code
)->loc
;
9850 cond
->value
.op
.op
= INTRINSIC_NOT
;
9851 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9852 GFC_ISYM_ALLOCATED
, "allocated",
9853 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9854 block
= gfc_get_code (EXEC_IF
);
9855 block
->block
= gfc_get_code (EXEC_IF
);
9856 block
->block
->expr1
= cond
;
9857 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9859 NULL
, NULL
, (*code
)->loc
);
9860 add_code_to_chain (&block
, &head
, &tail
);
9864 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9866 /* Don't add intrinsic assignments since they are already
9867 effected by the intrinsic assignment of the structure. */
9868 gfc_free_statements (this_code
);
9873 add_code_to_chain (&this_code
, &head
, &tail
);
9877 /* Transfer the value to the final result. */
9878 this_code
= build_assignment (EXEC_ASSIGN
,
9880 comp1
, comp2
, (*code
)->loc
);
9881 add_code_to_chain (&this_code
, &head
, &tail
);
9885 /* Put the temporary assignments at the top of the generated code. */
9886 if (tmp_head
&& component_assignment_level
== 1)
9888 gfc_append_code (tmp_head
, head
);
9890 tmp_head
= tmp_tail
= NULL
;
9893 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9894 // not accidentally deallocated. Hence, nullify t1.
9895 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9896 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9902 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9903 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9904 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9905 block
= gfc_get_code (EXEC_IF
);
9906 block
->block
= gfc_get_code (EXEC_IF
);
9907 block
->block
->expr1
= cond
;
9908 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9909 t1
, gfc_get_null_expr (&(*code
)->loc
),
9910 NULL
, NULL
, (*code
)->loc
);
9911 gfc_append_code (tail
, block
);
9915 /* Now attach the remaining code chain to the input code. Step on
9916 to the end of the new code since resolution is complete. */
9917 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9918 tail
->next
= (*code
)->next
;
9919 /* Overwrite 'code' because this would place the intrinsic assignment
9920 before the temporary for the lhs is created. */
9921 gfc_free_expr ((*code
)->expr1
);
9922 gfc_free_expr ((*code
)->expr2
);
9928 component_assignment_level
--;
9932 /* Given a block of code, recursively resolve everything pointed to by this
9936 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9938 int omp_workshare_save
;
9939 int forall_save
, do_concurrent_save
;
9943 frame
.prev
= cs_base
;
9947 find_reachable_labels (code
);
9949 for (; code
; code
= code
->next
)
9951 frame
.current
= code
;
9952 forall_save
= forall_flag
;
9953 do_concurrent_save
= gfc_do_concurrent_flag
;
9955 if (code
->op
== EXEC_FORALL
)
9958 gfc_resolve_forall (code
, ns
, forall_save
);
9961 else if (code
->block
)
9963 omp_workshare_save
= -1;
9966 case EXEC_OACC_PARALLEL_LOOP
:
9967 case EXEC_OACC_PARALLEL
:
9968 case EXEC_OACC_KERNELS_LOOP
:
9969 case EXEC_OACC_KERNELS
:
9970 case EXEC_OACC_DATA
:
9971 case EXEC_OACC_HOST_DATA
:
9972 case EXEC_OACC_LOOP
:
9973 gfc_resolve_oacc_blocks (code
, ns
);
9975 case EXEC_OMP_PARALLEL_WORKSHARE
:
9976 omp_workshare_save
= omp_workshare_flag
;
9977 omp_workshare_flag
= 1;
9978 gfc_resolve_omp_parallel_blocks (code
, ns
);
9980 case EXEC_OMP_PARALLEL
:
9981 case EXEC_OMP_PARALLEL_DO
:
9982 case EXEC_OMP_PARALLEL_DO_SIMD
:
9983 case EXEC_OMP_PARALLEL_SECTIONS
:
9984 case EXEC_OMP_TARGET_TEAMS
:
9985 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9986 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9987 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9988 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9990 case EXEC_OMP_TEAMS
:
9991 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9992 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9993 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9994 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9995 omp_workshare_save
= omp_workshare_flag
;
9996 omp_workshare_flag
= 0;
9997 gfc_resolve_omp_parallel_blocks (code
, ns
);
9999 case EXEC_OMP_DISTRIBUTE
:
10000 case EXEC_OMP_DISTRIBUTE_SIMD
:
10002 case EXEC_OMP_DO_SIMD
:
10003 case EXEC_OMP_SIMD
:
10004 gfc_resolve_omp_do_blocks (code
, ns
);
10006 case EXEC_SELECT_TYPE
:
10007 /* Blocks are handled in resolve_select_type because we have
10008 to transform the SELECT TYPE into ASSOCIATE first. */
10010 case EXEC_DO_CONCURRENT
:
10011 gfc_do_concurrent_flag
= 1;
10012 gfc_resolve_blocks (code
->block
, ns
);
10013 gfc_do_concurrent_flag
= 2;
10015 case EXEC_OMP_WORKSHARE
:
10016 omp_workshare_save
= omp_workshare_flag
;
10017 omp_workshare_flag
= 1;
10020 gfc_resolve_blocks (code
->block
, ns
);
10024 if (omp_workshare_save
!= -1)
10025 omp_workshare_flag
= omp_workshare_save
;
10029 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10030 t
= gfc_resolve_expr (code
->expr1
);
10031 forall_flag
= forall_save
;
10032 gfc_do_concurrent_flag
= do_concurrent_save
;
10034 if (!gfc_resolve_expr (code
->expr2
))
10037 if (code
->op
== EXEC_ALLOCATE
10038 && !gfc_resolve_expr (code
->expr3
))
10044 case EXEC_END_BLOCK
:
10045 case EXEC_END_NESTED_BLOCK
:
10049 case EXEC_ERROR_STOP
:
10051 case EXEC_CONTINUE
:
10053 case EXEC_ASSIGN_CALL
:
10056 case EXEC_CRITICAL
:
10057 resolve_critical (code
);
10060 case EXEC_SYNC_ALL
:
10061 case EXEC_SYNC_IMAGES
:
10062 case EXEC_SYNC_MEMORY
:
10063 resolve_sync (code
);
10068 resolve_lock_unlock (code
);
10072 /* Keep track of which entry we are up to. */
10073 current_entry_id
= code
->ext
.entry
->id
;
10077 resolve_where (code
, NULL
);
10081 if (code
->expr1
!= NULL
)
10083 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10084 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10085 "INTEGER variable", &code
->expr1
->where
);
10086 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10087 gfc_error ("Variable %qs has not been assigned a target "
10088 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10089 &code
->expr1
->where
);
10092 resolve_branch (code
->label1
, code
);
10096 if (code
->expr1
!= NULL
10097 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10098 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10099 "INTEGER return specifier", &code
->expr1
->where
);
10102 case EXEC_INIT_ASSIGN
:
10103 case EXEC_END_PROCEDURE
:
10110 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10112 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10113 && code
->expr1
->value
.function
.isym
10114 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10115 remove_caf_get_intrinsic (code
->expr1
);
10117 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10121 if (resolve_ordinary_assign (code
, ns
))
10123 if (code
->op
== EXEC_COMPCALL
)
10129 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10130 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10131 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10132 generate_component_assignments (&code
, ns
);
10136 case EXEC_LABEL_ASSIGN
:
10137 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10138 gfc_error ("Label %d referenced at %L is never defined",
10139 code
->label1
->value
, &code
->label1
->where
);
10141 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10142 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10143 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10144 != gfc_default_integer_kind
10145 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10146 gfc_error ("ASSIGN statement at %L requires a scalar "
10147 "default INTEGER variable", &code
->expr1
->where
);
10150 case EXEC_POINTER_ASSIGN
:
10157 /* This is both a variable definition and pointer assignment
10158 context, so check both of them. For rank remapping, a final
10159 array ref may be present on the LHS and fool gfc_expr_attr
10160 used in gfc_check_vardef_context. Remove it. */
10161 e
= remove_last_array_ref (code
->expr1
);
10162 t
= gfc_check_vardef_context (e
, true, false, false,
10163 _("pointer assignment"));
10165 t
= gfc_check_vardef_context (e
, false, false, false,
10166 _("pointer assignment"));
10171 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10175 case EXEC_ARITHMETIC_IF
:
10177 && code
->expr1
->ts
.type
!= BT_INTEGER
10178 && code
->expr1
->ts
.type
!= BT_REAL
)
10179 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10180 "expression", &code
->expr1
->where
);
10182 resolve_branch (code
->label1
, code
);
10183 resolve_branch (code
->label2
, code
);
10184 resolve_branch (code
->label3
, code
);
10188 if (t
&& code
->expr1
!= NULL
10189 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10190 || code
->expr1
->rank
!= 0))
10191 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10192 &code
->expr1
->where
);
10197 resolve_call (code
);
10200 case EXEC_COMPCALL
:
10202 resolve_typebound_subroutine (code
);
10205 case EXEC_CALL_PPC
:
10206 resolve_ppc_call (code
);
10210 /* Select is complicated. Also, a SELECT construct could be
10211 a transformed computed GOTO. */
10212 resolve_select (code
, false);
10215 case EXEC_SELECT_TYPE
:
10216 resolve_select_type (code
, ns
);
10220 resolve_block_construct (code
);
10224 if (code
->ext
.iterator
!= NULL
)
10226 gfc_iterator
*iter
= code
->ext
.iterator
;
10227 if (gfc_resolve_iterator (iter
, true, false))
10228 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10232 case EXEC_DO_WHILE
:
10233 if (code
->expr1
== NULL
)
10234 gfc_internal_error ("gfc_resolve_code(): No expression on "
10237 && (code
->expr1
->rank
!= 0
10238 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10239 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10240 "a scalar LOGICAL expression", &code
->expr1
->where
);
10243 case EXEC_ALLOCATE
:
10245 resolve_allocate_deallocate (code
, "ALLOCATE");
10249 case EXEC_DEALLOCATE
:
10251 resolve_allocate_deallocate (code
, "DEALLOCATE");
10256 if (!gfc_resolve_open (code
->ext
.open
))
10259 resolve_branch (code
->ext
.open
->err
, code
);
10263 if (!gfc_resolve_close (code
->ext
.close
))
10266 resolve_branch (code
->ext
.close
->err
, code
);
10269 case EXEC_BACKSPACE
:
10273 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10276 resolve_branch (code
->ext
.filepos
->err
, code
);
10280 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10283 resolve_branch (code
->ext
.inquire
->err
, code
);
10286 case EXEC_IOLENGTH
:
10287 gcc_assert (code
->ext
.inquire
!= NULL
);
10288 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10291 resolve_branch (code
->ext
.inquire
->err
, code
);
10295 if (!gfc_resolve_wait (code
->ext
.wait
))
10298 resolve_branch (code
->ext
.wait
->err
, code
);
10299 resolve_branch (code
->ext
.wait
->end
, code
);
10300 resolve_branch (code
->ext
.wait
->eor
, code
);
10305 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10308 resolve_branch (code
->ext
.dt
->err
, code
);
10309 resolve_branch (code
->ext
.dt
->end
, code
);
10310 resolve_branch (code
->ext
.dt
->eor
, code
);
10313 case EXEC_TRANSFER
:
10314 resolve_transfer (code
);
10317 case EXEC_DO_CONCURRENT
:
10319 resolve_forall_iterators (code
->ext
.forall_iterator
);
10321 if (code
->expr1
!= NULL
10322 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10323 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10324 "expression", &code
->expr1
->where
);
10327 case EXEC_OACC_PARALLEL_LOOP
:
10328 case EXEC_OACC_PARALLEL
:
10329 case EXEC_OACC_KERNELS_LOOP
:
10330 case EXEC_OACC_KERNELS
:
10331 case EXEC_OACC_DATA
:
10332 case EXEC_OACC_HOST_DATA
:
10333 case EXEC_OACC_LOOP
:
10334 case EXEC_OACC_UPDATE
:
10335 case EXEC_OACC_WAIT
:
10336 case EXEC_OACC_CACHE
:
10337 case EXEC_OACC_ENTER_DATA
:
10338 case EXEC_OACC_EXIT_DATA
:
10339 gfc_resolve_oacc_directive (code
, ns
);
10342 case EXEC_OMP_ATOMIC
:
10343 case EXEC_OMP_BARRIER
:
10344 case EXEC_OMP_CANCEL
:
10345 case EXEC_OMP_CANCELLATION_POINT
:
10346 case EXEC_OMP_CRITICAL
:
10347 case EXEC_OMP_FLUSH
:
10348 case EXEC_OMP_DISTRIBUTE
:
10349 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10350 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10351 case EXEC_OMP_DISTRIBUTE_SIMD
:
10353 case EXEC_OMP_DO_SIMD
:
10354 case EXEC_OMP_MASTER
:
10355 case EXEC_OMP_ORDERED
:
10356 case EXEC_OMP_SECTIONS
:
10357 case EXEC_OMP_SIMD
:
10358 case EXEC_OMP_SINGLE
:
10359 case EXEC_OMP_TARGET
:
10360 case EXEC_OMP_TARGET_DATA
:
10361 case EXEC_OMP_TARGET_TEAMS
:
10362 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10363 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10364 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10365 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10366 case EXEC_OMP_TARGET_UPDATE
:
10367 case EXEC_OMP_TASK
:
10368 case EXEC_OMP_TASKGROUP
:
10369 case EXEC_OMP_TASKWAIT
:
10370 case EXEC_OMP_TASKYIELD
:
10371 case EXEC_OMP_TEAMS
:
10372 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10373 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10374 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10375 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10376 case EXEC_OMP_WORKSHARE
:
10377 gfc_resolve_omp_directive (code
, ns
);
10380 case EXEC_OMP_PARALLEL
:
10381 case EXEC_OMP_PARALLEL_DO
:
10382 case EXEC_OMP_PARALLEL_DO_SIMD
:
10383 case EXEC_OMP_PARALLEL_SECTIONS
:
10384 case EXEC_OMP_PARALLEL_WORKSHARE
:
10385 omp_workshare_save
= omp_workshare_flag
;
10386 omp_workshare_flag
= 0;
10387 gfc_resolve_omp_directive (code
, ns
);
10388 omp_workshare_flag
= omp_workshare_save
;
10392 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10396 cs_base
= frame
.prev
;
10400 /* Resolve initial values and make sure they are compatible with
10404 resolve_values (gfc_symbol
*sym
)
10408 if (sym
->value
== NULL
)
10411 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10412 t
= resolve_structure_cons (sym
->value
, 1);
10414 t
= gfc_resolve_expr (sym
->value
);
10419 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10423 /* Verify any BIND(C) derived types in the namespace so we can report errors
10424 for them once, rather than for each variable declared of that type. */
10427 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10429 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10430 && derived_sym
->attr
.is_bind_c
== 1)
10431 verify_bind_c_derived_type (derived_sym
);
10437 /* Verify that any binding labels used in a given namespace do not collide
10438 with the names or binding labels of any global symbols. Multiple INTERFACE
10439 for the same procedure are permitted. */
10442 gfc_verify_binding_labels (gfc_symbol
*sym
)
10445 const char *module
;
10447 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10448 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10451 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10454 module
= sym
->module
;
10455 else if (sym
->ns
&& sym
->ns
->proc_name
10456 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10457 module
= sym
->ns
->proc_name
->name
;
10458 else if (sym
->ns
&& sym
->ns
->parent
10459 && sym
->ns
&& sym
->ns
->parent
->proc_name
10460 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10461 module
= sym
->ns
->parent
->proc_name
->name
;
10467 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10470 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10471 gsym
->where
= sym
->declared_at
;
10472 gsym
->sym_name
= sym
->name
;
10473 gsym
->binding_label
= sym
->binding_label
;
10474 gsym
->ns
= sym
->ns
;
10475 gsym
->mod_name
= module
;
10476 if (sym
->attr
.function
)
10477 gsym
->type
= GSYM_FUNCTION
;
10478 else if (sym
->attr
.subroutine
)
10479 gsym
->type
= GSYM_SUBROUTINE
;
10480 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10481 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10485 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10487 gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
10488 "identifier as entity at %L", sym
->name
,
10489 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10490 /* Clear the binding label to prevent checking multiple times. */
10491 sym
->binding_label
= NULL
;
10494 else if (sym
->attr
.flavor
== FL_VARIABLE
10495 && (strcmp (module
, gsym
->mod_name
) != 0
10496 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10498 /* This can only happen if the variable is defined in a module - if it
10499 isn't the same module, reject it. */
10500 gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
10501 "the same global identifier as entity at %L from module %s",
10502 sym
->name
, module
, sym
->binding_label
,
10503 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10504 sym
->binding_label
= NULL
;
10506 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10507 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10508 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10509 && sym
!= gsym
->ns
->proc_name
10510 && (module
!= gsym
->mod_name
10511 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10512 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10514 /* Print an error if the procedure is defined multiple times; we have to
10515 exclude references to the same procedure via module association or
10516 multiple checks for the same procedure. */
10517 gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
10518 "global identifier as entity at %L", sym
->name
,
10519 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10520 sym
->binding_label
= NULL
;
10525 /* Resolve an index expression. */
10528 resolve_index_expr (gfc_expr
*e
)
10530 if (!gfc_resolve_expr (e
))
10533 if (!gfc_simplify_expr (e
, 0))
10536 if (!gfc_specification_expr (e
))
10543 /* Resolve a charlen structure. */
10546 resolve_charlen (gfc_charlen
*cl
)
10549 bool saved_specification_expr
;
10555 saved_specification_expr
= specification_expr
;
10556 specification_expr
= true;
10558 if (cl
->length_from_typespec
)
10560 if (!gfc_resolve_expr (cl
->length
))
10562 specification_expr
= saved_specification_expr
;
10566 if (!gfc_simplify_expr (cl
->length
, 0))
10568 specification_expr
= saved_specification_expr
;
10575 if (!resolve_index_expr (cl
->length
))
10577 specification_expr
= saved_specification_expr
;
10582 /* "If the character length parameter value evaluates to a negative
10583 value, the length of character entities declared is zero." */
10584 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10586 if (warn_surprising
)
10587 gfc_warning_now (OPT_Wsurprising
,
10588 "CHARACTER variable at %L has negative length %d,"
10589 " the length has been set to zero",
10590 &cl
->length
->where
, i
);
10591 gfc_replace_expr (cl
->length
,
10592 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10595 /* Check that the character length is not too large. */
10596 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10597 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10598 && cl
->length
->ts
.type
== BT_INTEGER
10599 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10601 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10602 specification_expr
= saved_specification_expr
;
10606 specification_expr
= saved_specification_expr
;
10611 /* Test for non-constant shape arrays. */
10614 is_non_constant_shape_array (gfc_symbol
*sym
)
10620 not_constant
= false;
10621 if (sym
->as
!= NULL
)
10623 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10624 has not been simplified; parameter array references. Do the
10625 simplification now. */
10626 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10628 e
= sym
->as
->lower
[i
];
10629 if (e
&& (!resolve_index_expr(e
)
10630 || !gfc_is_constant_expr (e
)))
10631 not_constant
= true;
10632 e
= sym
->as
->upper
[i
];
10633 if (e
&& (!resolve_index_expr(e
)
10634 || !gfc_is_constant_expr (e
)))
10635 not_constant
= true;
10638 return not_constant
;
10641 /* Given a symbol and an initialization expression, add code to initialize
10642 the symbol to the function entry. */
10644 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10648 gfc_namespace
*ns
= sym
->ns
;
10650 /* Search for the function namespace if this is a contained
10651 function without an explicit result. */
10652 if (sym
->attr
.function
&& sym
== sym
->result
10653 && sym
->name
!= sym
->ns
->proc_name
->name
)
10655 ns
= ns
->contained
;
10656 for (;ns
; ns
= ns
->sibling
)
10657 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10663 gfc_free_expr (init
);
10667 /* Build an l-value expression for the result. */
10668 lval
= gfc_lval_expr_from_sym (sym
);
10670 /* Add the code at scope entry. */
10671 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10672 init_st
->next
= ns
->code
;
10673 ns
->code
= init_st
;
10675 /* Assign the default initializer to the l-value. */
10676 init_st
->loc
= sym
->declared_at
;
10677 init_st
->expr1
= lval
;
10678 init_st
->expr2
= init
;
10681 /* Assign the default initializer to a derived type variable or result. */
10684 apply_default_init (gfc_symbol
*sym
)
10686 gfc_expr
*init
= NULL
;
10688 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10691 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10692 init
= gfc_default_initializer (&sym
->ts
);
10694 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10697 build_init_assign (sym
, init
);
10698 sym
->attr
.referenced
= 1;
10701 /* Build an initializer for a local integer, real, complex, logical, or
10702 character variable, based on the command line flags finit-local-zero,
10703 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10704 null if the symbol should not have a default initialization. */
10706 build_default_init_expr (gfc_symbol
*sym
)
10709 gfc_expr
*init_expr
;
10712 /* These symbols should never have a default initialization. */
10713 if (sym
->attr
.allocatable
10714 || sym
->attr
.external
10716 || sym
->attr
.pointer
10717 || sym
->attr
.in_equivalence
10718 || sym
->attr
.in_common
10721 || sym
->attr
.cray_pointee
10722 || sym
->attr
.cray_pointer
10726 /* Now we'll try to build an initializer expression. */
10727 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10728 &sym
->declared_at
);
10730 /* We will only initialize integers, reals, complex, logicals, and
10731 characters, and only if the corresponding command-line flags
10732 were set. Otherwise, we free init_expr and return null. */
10733 switch (sym
->ts
.type
)
10736 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10737 mpz_set_si (init_expr
->value
.integer
,
10738 gfc_option
.flag_init_integer_value
);
10741 gfc_free_expr (init_expr
);
10747 switch (flag_init_real
)
10749 case GFC_INIT_REAL_SNAN
:
10750 init_expr
->is_snan
= 1;
10751 /* Fall through. */
10752 case GFC_INIT_REAL_NAN
:
10753 mpfr_set_nan (init_expr
->value
.real
);
10756 case GFC_INIT_REAL_INF
:
10757 mpfr_set_inf (init_expr
->value
.real
, 1);
10760 case GFC_INIT_REAL_NEG_INF
:
10761 mpfr_set_inf (init_expr
->value
.real
, -1);
10764 case GFC_INIT_REAL_ZERO
:
10765 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10769 gfc_free_expr (init_expr
);
10776 switch (flag_init_real
)
10778 case GFC_INIT_REAL_SNAN
:
10779 init_expr
->is_snan
= 1;
10780 /* Fall through. */
10781 case GFC_INIT_REAL_NAN
:
10782 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10783 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10786 case GFC_INIT_REAL_INF
:
10787 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10788 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10791 case GFC_INIT_REAL_NEG_INF
:
10792 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10793 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10796 case GFC_INIT_REAL_ZERO
:
10797 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10801 gfc_free_expr (init_expr
);
10808 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10809 init_expr
->value
.logical
= 0;
10810 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10811 init_expr
->value
.logical
= 1;
10814 gfc_free_expr (init_expr
);
10820 /* For characters, the length must be constant in order to
10821 create a default initializer. */
10822 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10823 && sym
->ts
.u
.cl
->length
10824 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10826 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10827 init_expr
->value
.character
.length
= char_len
;
10828 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10829 for (i
= 0; i
< char_len
; i
++)
10830 init_expr
->value
.character
.string
[i
]
10831 = (unsigned char) gfc_option
.flag_init_character_value
;
10835 gfc_free_expr (init_expr
);
10838 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10839 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
10841 gfc_actual_arglist
*arg
;
10842 init_expr
= gfc_get_expr ();
10843 init_expr
->where
= sym
->declared_at
;
10844 init_expr
->ts
= sym
->ts
;
10845 init_expr
->expr_type
= EXPR_FUNCTION
;
10846 init_expr
->value
.function
.isym
=
10847 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10848 init_expr
->value
.function
.name
= "repeat";
10849 arg
= gfc_get_actual_arglist ();
10850 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10852 arg
->expr
->value
.character
.string
[0]
10853 = gfc_option
.flag_init_character_value
;
10854 arg
->next
= gfc_get_actual_arglist ();
10855 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10856 init_expr
->value
.function
.actual
= arg
;
10861 gfc_free_expr (init_expr
);
10867 /* Add an initialization expression to a local variable. */
10869 apply_default_init_local (gfc_symbol
*sym
)
10871 gfc_expr
*init
= NULL
;
10873 /* The symbol should be a variable or a function return value. */
10874 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10875 || (sym
->attr
.function
&& sym
->result
!= sym
))
10878 /* Try to build the initializer expression. If we can't initialize
10879 this symbol, then init will be NULL. */
10880 init
= build_default_init_expr (sym
);
10884 /* For saved variables, we don't want to add an initializer at function
10885 entry, so we just add a static initializer. Note that automatic variables
10886 are stack allocated even with -fno-automatic; we have also to exclude
10887 result variable, which are also nonstatic. */
10888 if (sym
->attr
.save
|| sym
->ns
->save_all
10889 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
10890 && !sym
->ns
->proc_name
->attr
.recursive
10891 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10893 /* Don't clobber an existing initializer! */
10894 gcc_assert (sym
->value
== NULL
);
10899 build_init_assign (sym
, init
);
10903 /* Resolution of common features of flavors variable and procedure. */
10906 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10908 gfc_array_spec
*as
;
10910 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10911 as
= CLASS_DATA (sym
)->as
;
10915 /* Constraints on deferred shape variable. */
10916 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10918 bool pointer
, allocatable
, dimension
;
10920 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10922 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10923 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10924 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10928 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10929 allocatable
= sym
->attr
.allocatable
;
10930 dimension
= sym
->attr
.dimension
;
10935 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10937 gfc_error ("Allocatable array %qs at %L must have a deferred "
10938 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10941 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10942 "%qs at %L may not be ALLOCATABLE",
10943 sym
->name
, &sym
->declared_at
))
10947 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10949 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
10950 "assumed rank", sym
->name
, &sym
->declared_at
);
10956 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10957 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10959 gfc_error ("Array %qs at %L cannot have a deferred shape",
10960 sym
->name
, &sym
->declared_at
);
10965 /* Constraints on polymorphic variables. */
10966 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10969 if (sym
->attr
.class_ok
10970 && !sym
->attr
.select_type_temporary
10971 && !UNLIMITED_POLY (sym
)
10972 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10974 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
10975 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10976 &sym
->declared_at
);
10981 /* Assume that use associated symbols were checked in the module ns.
10982 Class-variables that are associate-names are also something special
10983 and excepted from the test. */
10984 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10986 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
10987 "or pointer", sym
->name
, &sym
->declared_at
);
10996 /* Additional checks for symbols with flavor variable and derived
10997 type. To be called from resolve_fl_variable. */
11000 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11002 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11004 /* Check to see if a derived type is blocked from being host
11005 associated by the presence of another class I symbol in the same
11006 namespace. 14.6.1.3 of the standard and the discussion on
11007 comp.lang.fortran. */
11008 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11009 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11012 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11013 if (s
&& s
->attr
.generic
)
11014 s
= gfc_find_dt_in_generic (s
);
11015 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11017 gfc_error_1 ("The type '%s' cannot be host associated at %L "
11018 "because it is blocked by an incompatible object "
11019 "of the same name declared at %L",
11020 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11026 /* 4th constraint in section 11.3: "If an object of a type for which
11027 component-initialization is specified (R429) appears in the
11028 specification-part of a module and does not have the ALLOCATABLE
11029 or POINTER attribute, the object shall have the SAVE attribute."
11031 The check for initializers is performed with
11032 gfc_has_default_initializer because gfc_default_initializer generates
11033 a hidden default for allocatable components. */
11034 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11035 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11036 && !sym
->ns
->save_all
&& !sym
->attr
.save
11037 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11038 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11039 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11040 "%qs at %L, needed due to the default "
11041 "initialization", sym
->name
, &sym
->declared_at
))
11044 /* Assign default initializer. */
11045 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11046 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11048 sym
->value
= gfc_default_initializer (&sym
->ts
);
11055 /* Resolve symbols with flavor variable. */
11058 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11060 int no_init_flag
, automatic_flag
;
11062 const char *auto_save_msg
;
11063 bool saved_specification_expr
;
11065 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11068 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11071 /* Set this flag to check that variables are parameters of all entries.
11072 This check is effected by the call to gfc_resolve_expr through
11073 is_non_constant_shape_array. */
11074 saved_specification_expr
= specification_expr
;
11075 specification_expr
= true;
11077 if (sym
->ns
->proc_name
11078 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11079 || sym
->ns
->proc_name
->attr
.is_main_program
)
11080 && !sym
->attr
.use_assoc
11081 && !sym
->attr
.allocatable
11082 && !sym
->attr
.pointer
11083 && is_non_constant_shape_array (sym
))
11085 /* The shape of a main program or module array needs to be
11087 gfc_error ("The module or main program array '%s' at %L must "
11088 "have constant shape", sym
->name
, &sym
->declared_at
);
11089 specification_expr
= saved_specification_expr
;
11093 /* Constraints on deferred type parameter. */
11094 if (sym
->ts
.deferred
11095 && !(sym
->attr
.pointer
11096 || sym
->attr
.allocatable
11097 || sym
->attr
.omp_udr_artificial_var
))
11099 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11100 "requires either the pointer or allocatable attribute",
11101 sym
->name
, &sym
->declared_at
);
11102 specification_expr
= saved_specification_expr
;
11106 if (sym
->ts
.type
== BT_CHARACTER
)
11108 /* Make sure that character string variables with assumed length are
11109 dummy arguments. */
11110 e
= sym
->ts
.u
.cl
->length
;
11111 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11112 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11113 && !sym
->attr
.omp_udr_artificial_var
)
11115 gfc_error ("Entity with assumed character length at %L must be a "
11116 "dummy argument or a PARAMETER", &sym
->declared_at
);
11117 specification_expr
= saved_specification_expr
;
11121 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11123 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11124 specification_expr
= saved_specification_expr
;
11128 if (!gfc_is_constant_expr (e
)
11129 && !(e
->expr_type
== EXPR_VARIABLE
11130 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11132 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11133 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11134 || sym
->ns
->proc_name
->attr
.is_main_program
))
11136 gfc_error ("'%s' at %L must have constant character length "
11137 "in this context", sym
->name
, &sym
->declared_at
);
11138 specification_expr
= saved_specification_expr
;
11141 if (sym
->attr
.in_common
)
11143 gfc_error ("COMMON variable %qs at %L must have constant "
11144 "character length", sym
->name
, &sym
->declared_at
);
11145 specification_expr
= saved_specification_expr
;
11151 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11152 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11154 /* Determine if the symbol may not have an initializer. */
11155 no_init_flag
= automatic_flag
= 0;
11156 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11157 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11159 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11160 && is_non_constant_shape_array (sym
))
11162 no_init_flag
= automatic_flag
= 1;
11164 /* Also, they must not have the SAVE attribute.
11165 SAVE_IMPLICIT is checked below. */
11166 if (sym
->as
&& sym
->attr
.codimension
)
11168 int corank
= sym
->as
->corank
;
11169 sym
->as
->corank
= 0;
11170 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11171 sym
->as
->corank
= corank
;
11173 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11175 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11176 specification_expr
= saved_specification_expr
;
11181 /* Ensure that any initializer is simplified. */
11183 gfc_simplify_expr (sym
->value
, 1);
11185 /* Reject illegal initializers. */
11186 if (!sym
->mark
&& sym
->value
)
11188 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11189 && CLASS_DATA (sym
)->attr
.allocatable
))
11190 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11191 sym
->name
, &sym
->declared_at
);
11192 else if (sym
->attr
.external
)
11193 gfc_error ("External %qs at %L cannot have an initializer",
11194 sym
->name
, &sym
->declared_at
);
11195 else if (sym
->attr
.dummy
11196 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11197 gfc_error ("Dummy %qs at %L cannot have an initializer",
11198 sym
->name
, &sym
->declared_at
);
11199 else if (sym
->attr
.intrinsic
)
11200 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11201 sym
->name
, &sym
->declared_at
);
11202 else if (sym
->attr
.result
)
11203 gfc_error ("Function result %qs at %L cannot have an initializer",
11204 sym
->name
, &sym
->declared_at
);
11205 else if (automatic_flag
)
11206 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11207 sym
->name
, &sym
->declared_at
);
11209 goto no_init_error
;
11210 specification_expr
= saved_specification_expr
;
11215 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11217 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11218 specification_expr
= saved_specification_expr
;
11222 specification_expr
= saved_specification_expr
;
11227 /* Resolve a procedure. */
11230 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11232 gfc_formal_arglist
*arg
;
11234 if (sym
->attr
.function
11235 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11238 if (sym
->ts
.type
== BT_CHARACTER
)
11240 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11242 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11243 && !resolve_charlen (cl
))
11246 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11247 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11249 gfc_error ("Character-valued statement function %qs at %L must "
11250 "have constant length", sym
->name
, &sym
->declared_at
);
11255 /* Ensure that derived type for are not of a private type. Internal
11256 module procedures are excluded by 2.2.3.3 - i.e., they are not
11257 externally accessible and can access all the objects accessible in
11259 if (!(sym
->ns
->parent
11260 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11261 && gfc_check_symbol_access (sym
))
11263 gfc_interface
*iface
;
11265 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11268 && arg
->sym
->ts
.type
== BT_DERIVED
11269 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11270 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11271 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11272 "and cannot be a dummy argument"
11273 " of %qs, which is PUBLIC at %L",
11274 arg
->sym
->name
, sym
->name
,
11275 &sym
->declared_at
))
11277 /* Stop this message from recurring. */
11278 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11283 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11284 PRIVATE to the containing module. */
11285 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11287 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11290 && arg
->sym
->ts
.type
== BT_DERIVED
11291 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11292 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11293 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11294 "PUBLIC interface %qs at %L "
11295 "takes dummy arguments of %qs which "
11296 "is PRIVATE", iface
->sym
->name
,
11297 sym
->name
, &iface
->sym
->declared_at
,
11298 gfc_typename(&arg
->sym
->ts
)))
11300 /* Stop this message from recurring. */
11301 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11308 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11309 && !sym
->attr
.proc_pointer
)
11311 gfc_error ("Function %qs at %L cannot have an initializer",
11312 sym
->name
, &sym
->declared_at
);
11316 /* An external symbol may not have an initializer because it is taken to be
11317 a procedure. Exception: Procedure Pointers. */
11318 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11320 gfc_error ("External object %qs at %L may not have an initializer",
11321 sym
->name
, &sym
->declared_at
);
11325 /* An elemental function is required to return a scalar 12.7.1 */
11326 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11328 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11329 "result", sym
->name
, &sym
->declared_at
);
11330 /* Reset so that the error only occurs once. */
11331 sym
->attr
.elemental
= 0;
11335 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11336 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11338 gfc_error ("Statement function %qs at %L may not have pointer or "
11339 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11343 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11344 char-len-param shall not be array-valued, pointer-valued, recursive
11345 or pure. ....snip... A character value of * may only be used in the
11346 following ways: (i) Dummy arg of procedure - dummy associates with
11347 actual length; (ii) To declare a named constant; or (iii) External
11348 function - but length must be declared in calling scoping unit. */
11349 if (sym
->attr
.function
11350 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11351 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11353 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11354 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11356 if (sym
->as
&& sym
->as
->rank
)
11357 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11358 "array-valued", sym
->name
, &sym
->declared_at
);
11360 if (sym
->attr
.pointer
)
11361 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11362 "pointer-valued", sym
->name
, &sym
->declared_at
);
11364 if (sym
->attr
.pure
)
11365 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11366 "pure", sym
->name
, &sym
->declared_at
);
11368 if (sym
->attr
.recursive
)
11369 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11370 "recursive", sym
->name
, &sym
->declared_at
);
11375 /* Appendix B.2 of the standard. Contained functions give an
11376 error anyway. Deferred character length is an F2003 feature.
11377 Don't warn on intrinsic conversion functions, which start
11378 with two underscores. */
11379 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11380 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11381 gfc_notify_std (GFC_STD_F95_OBS
,
11382 "CHARACTER(*) function %qs at %L",
11383 sym
->name
, &sym
->declared_at
);
11386 /* F2008, C1218. */
11387 if (sym
->attr
.elemental
)
11389 if (sym
->attr
.proc_pointer
)
11391 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11392 sym
->name
, &sym
->declared_at
);
11395 if (sym
->attr
.dummy
)
11397 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11398 sym
->name
, &sym
->declared_at
);
11403 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11405 gfc_formal_arglist
*curr_arg
;
11406 int has_non_interop_arg
= 0;
11408 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11409 sym
->common_block
))
11411 /* Clear these to prevent looking at them again if there was an
11413 sym
->attr
.is_bind_c
= 0;
11414 sym
->attr
.is_c_interop
= 0;
11415 sym
->ts
.is_c_interop
= 0;
11419 /* So far, no errors have been found. */
11420 sym
->attr
.is_c_interop
= 1;
11421 sym
->ts
.is_c_interop
= 1;
11424 curr_arg
= gfc_sym_get_dummy_args (sym
);
11425 while (curr_arg
!= NULL
)
11427 /* Skip implicitly typed dummy args here. */
11428 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11429 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11430 /* If something is found to fail, record the fact so we
11431 can mark the symbol for the procedure as not being
11432 BIND(C) to try and prevent multiple errors being
11434 has_non_interop_arg
= 1;
11436 curr_arg
= curr_arg
->next
;
11439 /* See if any of the arguments were not interoperable and if so, clear
11440 the procedure symbol to prevent duplicate error messages. */
11441 if (has_non_interop_arg
!= 0)
11443 sym
->attr
.is_c_interop
= 0;
11444 sym
->ts
.is_c_interop
= 0;
11445 sym
->attr
.is_bind_c
= 0;
11449 if (!sym
->attr
.proc_pointer
)
11451 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11453 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11454 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11457 if (sym
->attr
.intent
)
11459 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11460 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11463 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11465 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11466 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11469 if (sym
->attr
.external
&& sym
->attr
.function
11470 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11471 || sym
->attr
.contained
))
11473 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11474 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11477 if (strcmp ("ppr@", sym
->name
) == 0)
11479 gfc_error ("Procedure pointer result %qs at %L "
11480 "is missing the pointer attribute",
11481 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11490 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11491 been defined and we now know their defined arguments, check that they fulfill
11492 the requirements of the standard for procedures used as finalizers. */
11495 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11497 gfc_finalizer
* list
;
11498 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11499 bool result
= true;
11500 bool seen_scalar
= false;
11503 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11506 gfc_resolve_finalizers (parent
, finalizable
);
11508 /* Return early when not finalizable. Additionally, ensure that derived-type
11509 components have a their finalizables resolved. */
11510 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11512 bool has_final
= false;
11513 for (c
= derived
->components
; c
; c
= c
->next
)
11514 if (c
->ts
.type
== BT_DERIVED
11515 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11517 bool has_final2
= false;
11518 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11519 return false; /* Error. */
11520 has_final
= has_final
|| has_final2
;
11525 *finalizable
= false;
11530 /* Walk over the list of finalizer-procedures, check them, and if any one
11531 does not fit in with the standard's definition, print an error and remove
11532 it from the list. */
11533 prev_link
= &derived
->f2k_derived
->finalizers
;
11534 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11536 gfc_formal_arglist
*dummy_args
;
11541 /* Skip this finalizer if we already resolved it. */
11542 if (list
->proc_tree
)
11544 prev_link
= &(list
->next
);
11548 /* Check this exists and is a SUBROUTINE. */
11549 if (!list
->proc_sym
->attr
.subroutine
)
11551 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
11552 list
->proc_sym
->name
, &list
->where
);
11556 /* We should have exactly one argument. */
11557 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11558 if (!dummy_args
|| dummy_args
->next
)
11560 gfc_error ("FINAL procedure at %L must have exactly one argument",
11564 arg
= dummy_args
->sym
;
11566 /* This argument must be of our type. */
11567 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11569 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
11570 &arg
->declared_at
, derived
->name
);
11574 /* It must neither be a pointer nor allocatable nor optional. */
11575 if (arg
->attr
.pointer
)
11577 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11578 &arg
->declared_at
);
11581 if (arg
->attr
.allocatable
)
11583 gfc_error ("Argument of FINAL procedure at %L must not be"
11584 " ALLOCATABLE", &arg
->declared_at
);
11587 if (arg
->attr
.optional
)
11589 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11590 &arg
->declared_at
);
11594 /* It must not be INTENT(OUT). */
11595 if (arg
->attr
.intent
== INTENT_OUT
)
11597 gfc_error ("Argument of FINAL procedure at %L must not be"
11598 " INTENT(OUT)", &arg
->declared_at
);
11602 /* Warn if the procedure is non-scalar and not assumed shape. */
11603 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11604 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11605 gfc_warning (OPT_Wsurprising
,
11606 "Non-scalar FINAL procedure at %L should have assumed"
11607 " shape argument", &arg
->declared_at
);
11609 /* Check that it does not match in kind and rank with a FINAL procedure
11610 defined earlier. To really loop over the *earlier* declarations,
11611 we need to walk the tail of the list as new ones were pushed at the
11613 /* TODO: Handle kind parameters once they are implemented. */
11614 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11615 for (i
= list
->next
; i
; i
= i
->next
)
11617 gfc_formal_arglist
*dummy_args
;
11619 /* Argument list might be empty; that is an error signalled earlier,
11620 but we nevertheless continued resolving. */
11621 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11624 gfc_symbol
* i_arg
= dummy_args
->sym
;
11625 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11626 if (i_rank
== my_rank
)
11628 gfc_error ("FINAL procedure %qs declared at %L has the same"
11629 " rank (%d) as %qs",
11630 list
->proc_sym
->name
, &list
->where
, my_rank
,
11631 i
->proc_sym
->name
);
11637 /* Is this the/a scalar finalizer procedure? */
11638 if (!arg
->as
|| arg
->as
->rank
== 0)
11639 seen_scalar
= true;
11641 /* Find the symtree for this procedure. */
11642 gcc_assert (!list
->proc_tree
);
11643 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11645 prev_link
= &list
->next
;
11648 /* Remove wrong nodes immediately from the list so we don't risk any
11649 troubles in the future when they might fail later expectations. */
11652 *prev_link
= list
->next
;
11653 gfc_free_finalizer (i
);
11657 if (result
== false)
11660 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11661 were nodes in the list, must have been for arrays. It is surely a good
11662 idea to have a scalar version there if there's something to finalize. */
11663 if (warn_surprising
&& result
&& !seen_scalar
)
11664 gfc_warning (OPT_Wsurprising
,
11665 "Only array FINAL procedures declared for derived type %qs"
11666 " defined at %L, suggest also scalar one",
11667 derived
->name
, &derived
->declared_at
);
11669 vtab
= gfc_find_derived_vtab (derived
);
11670 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11671 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11674 *finalizable
= true;
11680 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11683 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11684 const char* generic_name
, locus where
)
11686 gfc_symbol
*sym1
, *sym2
;
11687 const char *pass1
, *pass2
;
11688 gfc_formal_arglist
*dummy_args
;
11690 gcc_assert (t1
->specific
&& t2
->specific
);
11691 gcc_assert (!t1
->specific
->is_generic
);
11692 gcc_assert (!t2
->specific
->is_generic
);
11693 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11695 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11696 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11701 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11702 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11703 || sym1
->attr
.function
!= sym2
->attr
.function
)
11705 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
11706 " GENERIC %qs at %L",
11707 sym1
->name
, sym2
->name
, generic_name
, &where
);
11711 /* Determine PASS arguments. */
11712 if (t1
->specific
->nopass
)
11714 else if (t1
->specific
->pass_arg
)
11715 pass1
= t1
->specific
->pass_arg
;
11718 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11720 pass1
= dummy_args
->sym
->name
;
11724 if (t2
->specific
->nopass
)
11726 else if (t2
->specific
->pass_arg
)
11727 pass2
= t2
->specific
->pass_arg
;
11730 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11732 pass2
= dummy_args
->sym
->name
;
11737 /* Compare the interfaces. */
11738 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11739 NULL
, 0, pass1
, pass2
))
11741 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
11742 sym1
->name
, sym2
->name
, generic_name
, &where
);
11750 /* Worker function for resolving a generic procedure binding; this is used to
11751 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11753 The difference between those cases is finding possible inherited bindings
11754 that are overridden, as one has to look for them in tb_sym_root,
11755 tb_uop_root or tb_op, respectively. Thus the caller must already find
11756 the super-type and set p->overridden correctly. */
11759 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11760 gfc_typebound_proc
* p
, const char* name
)
11762 gfc_tbp_generic
* target
;
11763 gfc_symtree
* first_target
;
11764 gfc_symtree
* inherited
;
11766 gcc_assert (p
&& p
->is_generic
);
11768 /* Try to find the specific bindings for the symtrees in our target-list. */
11769 gcc_assert (p
->u
.generic
);
11770 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11771 if (!target
->specific
)
11773 gfc_typebound_proc
* overridden_tbp
;
11774 gfc_tbp_generic
* g
;
11775 const char* target_name
;
11777 target_name
= target
->specific_st
->name
;
11779 /* Defined for this type directly. */
11780 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11782 target
->specific
= target
->specific_st
->n
.tb
;
11783 goto specific_found
;
11786 /* Look for an inherited specific binding. */
11789 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11794 gcc_assert (inherited
->n
.tb
);
11795 target
->specific
= inherited
->n
.tb
;
11796 goto specific_found
;
11800 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
11801 " at %L", target_name
, name
, &p
->where
);
11804 /* Once we've found the specific binding, check it is not ambiguous with
11805 other specifics already found or inherited for the same GENERIC. */
11807 gcc_assert (target
->specific
);
11809 /* This must really be a specific binding! */
11810 if (target
->specific
->is_generic
)
11812 gfc_error ("GENERIC %qs at %L must target a specific binding,"
11813 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
11817 /* Check those already resolved on this type directly. */
11818 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11819 if (g
!= target
&& g
->specific
11820 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11823 /* Check for ambiguity with inherited specific targets. */
11824 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11825 overridden_tbp
= overridden_tbp
->overridden
)
11826 if (overridden_tbp
->is_generic
)
11828 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11830 gcc_assert (g
->specific
);
11831 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11837 /* If we attempt to "overwrite" a specific binding, this is an error. */
11838 if (p
->overridden
&& !p
->overridden
->is_generic
)
11840 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
11841 " the same name", name
, &p
->where
);
11845 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11846 all must have the same attributes here. */
11847 first_target
= p
->u
.generic
->specific
->u
.specific
;
11848 gcc_assert (first_target
);
11849 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11850 p
->function
= first_target
->n
.sym
->attr
.function
;
11856 /* Resolve a GENERIC procedure binding for a derived type. */
11859 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11861 gfc_symbol
* super_type
;
11863 /* Find the overridden binding if any. */
11864 st
->n
.tb
->overridden
= NULL
;
11865 super_type
= gfc_get_derived_super_type (derived
);
11868 gfc_symtree
* overridden
;
11869 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11872 if (overridden
&& overridden
->n
.tb
)
11873 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11876 /* Resolve using worker function. */
11877 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11881 /* Retrieve the target-procedure of an operator binding and do some checks in
11882 common for intrinsic and user-defined type-bound operators. */
11885 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11887 gfc_symbol
* target_proc
;
11889 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11890 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11891 gcc_assert (target_proc
);
11893 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11894 if (target
->specific
->nopass
)
11896 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11900 return target_proc
;
11904 /* Resolve a type-bound intrinsic operator. */
11907 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11908 gfc_typebound_proc
* p
)
11910 gfc_symbol
* super_type
;
11911 gfc_tbp_generic
* target
;
11913 /* If there's already an error here, do nothing (but don't fail again). */
11917 /* Operators should always be GENERIC bindings. */
11918 gcc_assert (p
->is_generic
);
11920 /* Look for an overridden binding. */
11921 super_type
= gfc_get_derived_super_type (derived
);
11922 if (super_type
&& super_type
->f2k_derived
)
11923 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11926 p
->overridden
= NULL
;
11928 /* Resolve general GENERIC properties using worker function. */
11929 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11932 /* Check the targets to be procedures of correct interface. */
11933 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11935 gfc_symbol
* target_proc
;
11937 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11941 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11944 /* Add target to non-typebound operator list. */
11945 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11946 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11948 gfc_interface
*head
, *intr
;
11949 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11951 head
= derived
->ns
->op
[op
];
11952 intr
= gfc_get_interface ();
11953 intr
->sym
= target_proc
;
11954 intr
->where
= p
->where
;
11956 derived
->ns
->op
[op
] = intr
;
11968 /* Resolve a type-bound user operator (tree-walker callback). */
11970 static gfc_symbol
* resolve_bindings_derived
;
11971 static bool resolve_bindings_result
;
11973 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11976 resolve_typebound_user_op (gfc_symtree
* stree
)
11978 gfc_symbol
* super_type
;
11979 gfc_tbp_generic
* target
;
11981 gcc_assert (stree
&& stree
->n
.tb
);
11983 if (stree
->n
.tb
->error
)
11986 /* Operators should always be GENERIC bindings. */
11987 gcc_assert (stree
->n
.tb
->is_generic
);
11989 /* Find overridden procedure, if any. */
11990 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11991 if (super_type
&& super_type
->f2k_derived
)
11993 gfc_symtree
* overridden
;
11994 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11995 stree
->name
, true, NULL
);
11997 if (overridden
&& overridden
->n
.tb
)
11998 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12001 stree
->n
.tb
->overridden
= NULL
;
12003 /* Resolve basically using worker function. */
12004 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12007 /* Check the targets to be functions of correct interface. */
12008 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12010 gfc_symbol
* target_proc
;
12012 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12016 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12023 resolve_bindings_result
= false;
12024 stree
->n
.tb
->error
= 1;
12028 /* Resolve the type-bound procedures for a derived type. */
12031 resolve_typebound_procedure (gfc_symtree
* stree
)
12035 gfc_symbol
* me_arg
;
12036 gfc_symbol
* super_type
;
12037 gfc_component
* comp
;
12039 gcc_assert (stree
);
12041 /* Undefined specific symbol from GENERIC target definition. */
12045 if (stree
->n
.tb
->error
)
12048 /* If this is a GENERIC binding, use that routine. */
12049 if (stree
->n
.tb
->is_generic
)
12051 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12056 /* Get the target-procedure to check it. */
12057 gcc_assert (!stree
->n
.tb
->is_generic
);
12058 gcc_assert (stree
->n
.tb
->u
.specific
);
12059 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12060 where
= stree
->n
.tb
->where
;
12062 /* Default access should already be resolved from the parser. */
12063 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12065 if (stree
->n
.tb
->deferred
)
12067 if (!check_proc_interface (proc
, &where
))
12072 /* Check for F08:C465. */
12073 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12074 || (proc
->attr
.proc
!= PROC_MODULE
12075 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12076 || proc
->attr
.abstract
)
12078 gfc_error ("%qs must be a module procedure or an external procedure with"
12079 " an explicit interface at %L", proc
->name
, &where
);
12084 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12085 stree
->n
.tb
->function
= proc
->attr
.function
;
12087 /* Find the super-type of the current derived type. We could do this once and
12088 store in a global if speed is needed, but as long as not I believe this is
12089 more readable and clearer. */
12090 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12092 /* If PASS, resolve and check arguments if not already resolved / loaded
12093 from a .mod file. */
12094 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12096 gfc_formal_arglist
*dummy_args
;
12098 dummy_args
= gfc_sym_get_dummy_args (proc
);
12099 if (stree
->n
.tb
->pass_arg
)
12101 gfc_formal_arglist
*i
;
12103 /* If an explicit passing argument name is given, walk the arg-list
12104 and look for it. */
12107 stree
->n
.tb
->pass_arg_num
= 1;
12108 for (i
= dummy_args
; i
; i
= i
->next
)
12110 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12115 ++stree
->n
.tb
->pass_arg_num
;
12120 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12122 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12123 stree
->n
.tb
->pass_arg
);
12129 /* Otherwise, take the first one; there should in fact be at least
12131 stree
->n
.tb
->pass_arg_num
= 1;
12134 gfc_error ("Procedure %qs with PASS at %L must have at"
12135 " least one argument", proc
->name
, &where
);
12138 me_arg
= dummy_args
->sym
;
12141 /* Now check that the argument-type matches and the passed-object
12142 dummy argument is generally fine. */
12144 gcc_assert (me_arg
);
12146 if (me_arg
->ts
.type
!= BT_CLASS
)
12148 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12149 " at %L", proc
->name
, &where
);
12153 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12154 != resolve_bindings_derived
)
12156 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12157 " the derived-type %qs", me_arg
->name
, proc
->name
,
12158 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12162 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12163 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12165 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12166 " scalar", proc
->name
, &where
);
12169 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12171 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12172 " be ALLOCATABLE", proc
->name
, &where
);
12175 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12177 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12178 " be POINTER", proc
->name
, &where
);
12183 /* If we are extending some type, check that we don't override a procedure
12184 flagged NON_OVERRIDABLE. */
12185 stree
->n
.tb
->overridden
= NULL
;
12188 gfc_symtree
* overridden
;
12189 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12190 stree
->name
, true, NULL
);
12194 if (overridden
->n
.tb
)
12195 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12197 if (!gfc_check_typebound_override (stree
, overridden
))
12202 /* See if there's a name collision with a component directly in this type. */
12203 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12204 if (!strcmp (comp
->name
, stree
->name
))
12206 gfc_error ("Procedure %qs at %L has the same name as a component of"
12208 stree
->name
, &where
, resolve_bindings_derived
->name
);
12212 /* Try to find a name collision with an inherited component. */
12213 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12215 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12216 " component of %qs",
12217 stree
->name
, &where
, resolve_bindings_derived
->name
);
12221 stree
->n
.tb
->error
= 0;
12225 resolve_bindings_result
= false;
12226 stree
->n
.tb
->error
= 1;
12231 resolve_typebound_procedures (gfc_symbol
* derived
)
12234 gfc_symbol
* super_type
;
12236 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12239 super_type
= gfc_get_derived_super_type (derived
);
12241 resolve_symbol (super_type
);
12243 resolve_bindings_derived
= derived
;
12244 resolve_bindings_result
= true;
12246 if (derived
->f2k_derived
->tb_sym_root
)
12247 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12248 &resolve_typebound_procedure
);
12250 if (derived
->f2k_derived
->tb_uop_root
)
12251 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12252 &resolve_typebound_user_op
);
12254 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12256 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12257 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12258 (gfc_intrinsic_op
)op
, p
))
12259 resolve_bindings_result
= false;
12262 return resolve_bindings_result
;
12266 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12267 to give all identical derived types the same backend_decl. */
12269 add_dt_to_dt_list (gfc_symbol
*derived
)
12271 gfc_dt_list
*dt_list
;
12273 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12274 if (derived
== dt_list
->derived
)
12277 dt_list
= gfc_get_dt_list ();
12278 dt_list
->next
= gfc_derived_types
;
12279 dt_list
->derived
= derived
;
12280 gfc_derived_types
= dt_list
;
12284 /* Ensure that a derived-type is really not abstract, meaning that every
12285 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12288 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12293 if (!ensure_not_abstract_walker (sub
, st
->left
))
12295 if (!ensure_not_abstract_walker (sub
, st
->right
))
12298 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12300 gfc_symtree
* overriding
;
12301 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12304 gcc_assert (overriding
->n
.tb
);
12305 if (overriding
->n
.tb
->deferred
)
12307 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12308 " %qs is DEFERRED and not overridden",
12309 sub
->name
, &sub
->declared_at
, st
->name
);
12318 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12320 /* The algorithm used here is to recursively travel up the ancestry of sub
12321 and for each ancestor-type, check all bindings. If any of them is
12322 DEFERRED, look it up starting from sub and see if the found (overriding)
12323 binding is not DEFERRED.
12324 This is not the most efficient way to do this, but it should be ok and is
12325 clearer than something sophisticated. */
12327 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12329 if (!ancestor
->attr
.abstract
)
12332 /* Walk bindings of this ancestor. */
12333 if (ancestor
->f2k_derived
)
12336 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12341 /* Find next ancestor type and recurse on it. */
12342 ancestor
= gfc_get_derived_super_type (ancestor
);
12344 return ensure_not_abstract (sub
, ancestor
);
12350 /* This check for typebound defined assignments is done recursively
12351 since the order in which derived types are resolved is not always in
12352 order of the declarations. */
12355 check_defined_assignments (gfc_symbol
*derived
)
12359 for (c
= derived
->components
; c
; c
= c
->next
)
12361 if (c
->ts
.type
!= BT_DERIVED
12363 || c
->attr
.allocatable
12364 || c
->attr
.proc_pointer_comp
12365 || c
->attr
.class_pointer
12366 || c
->attr
.proc_pointer
)
12369 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12370 || (c
->ts
.u
.derived
->f2k_derived
12371 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12373 derived
->attr
.defined_assign_comp
= 1;
12377 check_defined_assignments (c
->ts
.u
.derived
);
12378 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12380 derived
->attr
.defined_assign_comp
= 1;
12387 /* Resolve the components of a derived type. This does not have to wait until
12388 resolution stage, but can be done as soon as the dt declaration has been
12392 resolve_fl_derived0 (gfc_symbol
*sym
)
12394 gfc_symbol
* super_type
;
12397 if (sym
->attr
.unlimited_polymorphic
)
12400 super_type
= gfc_get_derived_super_type (sym
);
12403 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12405 gfc_error ("As extending type %qs at %L has a coarray component, "
12406 "parent type %qs shall also have one", sym
->name
,
12407 &sym
->declared_at
, super_type
->name
);
12411 /* Ensure the extended type gets resolved before we do. */
12412 if (super_type
&& !resolve_fl_derived0 (super_type
))
12415 /* An ABSTRACT type must be extensible. */
12416 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12418 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12419 sym
->name
, &sym
->declared_at
);
12423 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12426 bool success
= true;
12428 for ( ; c
!= NULL
; c
= c
->next
)
12430 if (c
->attr
.artificial
)
12434 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12435 && c
->attr
.codimension
12436 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12438 gfc_error ("Coarray component %qs at %L must be allocatable with "
12439 "deferred shape", c
->name
, &c
->loc
);
12445 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12446 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12448 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12449 "shall not be a coarray", c
->name
, &c
->loc
);
12455 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12456 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12457 || c
->attr
.allocatable
))
12459 gfc_error ("Component %qs at %L with coarray component "
12460 "shall be a nonpointer, nonallocatable scalar",
12467 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12469 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12470 "is not an array pointer", c
->name
, &c
->loc
);
12475 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12477 gfc_symbol
*ifc
= c
->ts
.interface
;
12479 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
12486 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12488 /* Resolve interface and copy attributes. */
12489 if (ifc
->formal
&& !ifc
->formal_ns
)
12490 resolve_symbol (ifc
);
12491 if (ifc
->attr
.intrinsic
)
12492 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12496 c
->ts
= ifc
->result
->ts
;
12497 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12498 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12499 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12500 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12501 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12506 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12507 c
->attr
.pointer
= ifc
->attr
.pointer
;
12508 c
->attr
.dimension
= ifc
->attr
.dimension
;
12509 c
->as
= gfc_copy_array_spec (ifc
->as
);
12510 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12512 c
->ts
.interface
= ifc
;
12513 c
->attr
.function
= ifc
->attr
.function
;
12514 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12516 c
->attr
.pure
= ifc
->attr
.pure
;
12517 c
->attr
.elemental
= ifc
->attr
.elemental
;
12518 c
->attr
.recursive
= ifc
->attr
.recursive
;
12519 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12520 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12521 /* Copy char length. */
12522 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12524 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12525 if (cl
->length
&& !cl
->resolved
12526 && !gfc_resolve_expr (cl
->length
))
12536 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12538 /* Since PPCs are not implicitly typed, a PPC without an explicit
12539 interface must be a subroutine. */
12540 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12543 /* Procedure pointer components: Check PASS arg. */
12544 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12545 && !sym
->attr
.vtype
)
12547 gfc_symbol
* me_arg
;
12549 if (c
->tb
->pass_arg
)
12551 gfc_formal_arglist
* i
;
12553 /* If an explicit passing argument name is given, walk the arg-list
12554 and look for it. */
12557 c
->tb
->pass_arg_num
= 1;
12558 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12560 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12565 c
->tb
->pass_arg_num
++;
12570 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12571 "at %L has no argument %qs", c
->name
,
12572 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12580 /* Otherwise, take the first one; there should in fact be at least
12582 c
->tb
->pass_arg_num
= 1;
12583 if (!c
->ts
.interface
->formal
)
12585 gfc_error ("Procedure pointer component %qs with PASS at %L "
12586 "must have at least one argument",
12592 me_arg
= c
->ts
.interface
->formal
->sym
;
12595 /* Now check that the argument-type matches. */
12596 gcc_assert (me_arg
);
12597 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12598 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12599 || (me_arg
->ts
.type
== BT_CLASS
12600 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12602 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12603 " the derived type %qs", me_arg
->name
, c
->name
,
12604 me_arg
->name
, &c
->loc
, sym
->name
);
12610 /* Check for C453. */
12611 if (me_arg
->attr
.dimension
)
12613 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12614 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12621 if (me_arg
->attr
.pointer
)
12623 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12624 "may not have the POINTER attribute", me_arg
->name
,
12625 c
->name
, me_arg
->name
, &c
->loc
);
12631 if (me_arg
->attr
.allocatable
)
12633 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12634 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12635 me_arg
->name
, &c
->loc
);
12641 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12643 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12644 " at %L", c
->name
, &c
->loc
);
12651 /* Check type-spec if this is not the parent-type component. */
12652 if (((sym
->attr
.is_class
12653 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12654 || c
!= sym
->components
->ts
.u
.derived
->components
))
12655 || (!sym
->attr
.is_class
12656 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12657 && !sym
->attr
.vtype
12658 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12661 /* If this type is an extension, set the accessibility of the parent
12664 && ((sym
->attr
.is_class
12665 && c
== sym
->components
->ts
.u
.derived
->components
)
12666 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12667 && strcmp (super_type
->name
, c
->name
) == 0)
12668 c
->attr
.access
= super_type
->attr
.access
;
12670 /* If this type is an extension, see if this component has the same name
12671 as an inherited type-bound procedure. */
12672 if (super_type
&& !sym
->attr
.is_class
12673 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12675 gfc_error ("Component %qs of %qs at %L has the same name as an"
12676 " inherited type-bound procedure",
12677 c
->name
, sym
->name
, &c
->loc
);
12681 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12682 && !c
->ts
.deferred
)
12684 if (c
->ts
.u
.cl
->length
== NULL
12685 || (!resolve_charlen(c
->ts
.u
.cl
))
12686 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12688 gfc_error ("Character length of component %qs needs to "
12689 "be a constant specification expression at %L",
12691 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12696 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12697 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12699 gfc_error ("Character component %qs of %qs at %L with deferred "
12700 "length must be a POINTER or ALLOCATABLE",
12701 c
->name
, sym
->name
, &c
->loc
);
12705 /* Add the hidden deferred length field. */
12706 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12707 && !sym
->attr
.is_class
)
12709 char name
[GFC_MAX_SYMBOL_LEN
+9];
12710 gfc_component
*strlen
;
12711 sprintf (name
, "_%s_length", c
->name
);
12712 strlen
= gfc_find_component (sym
, name
, true, true);
12713 if (strlen
== NULL
)
12715 if (!gfc_add_component (sym
, name
, &strlen
))
12717 strlen
->ts
.type
= BT_INTEGER
;
12718 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12719 strlen
->attr
.access
= ACCESS_PRIVATE
;
12720 strlen
->attr
.artificial
= 1;
12724 if (c
->ts
.type
== BT_DERIVED
12725 && sym
->component_access
!= ACCESS_PRIVATE
12726 && gfc_check_symbol_access (sym
)
12727 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12728 && !c
->ts
.u
.derived
->attr
.use_assoc
12729 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12730 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
12731 "PRIVATE type and cannot be a component of "
12732 "%qs, which is PUBLIC at %L", c
->name
,
12733 sym
->name
, &sym
->declared_at
))
12736 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12738 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12739 "type %s", c
->name
, &c
->loc
, sym
->name
);
12743 if (sym
->attr
.sequence
)
12745 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12747 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12748 "not have the SEQUENCE attribute",
12749 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12754 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12755 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12756 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12757 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12758 CLASS_DATA (c
)->ts
.u
.derived
12759 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12761 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12762 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12763 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12765 gfc_error ("The pointer component %qs of %qs at %L is a type "
12766 "that has not been declared", c
->name
, sym
->name
,
12771 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12772 && CLASS_DATA (c
)->attr
.class_pointer
12773 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12774 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12775 && !UNLIMITED_POLY (c
))
12777 gfc_error ("The pointer component %qs of %qs at %L is a type "
12778 "that has not been declared", c
->name
, sym
->name
,
12784 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12785 && (!c
->attr
.class_ok
12786 || !(CLASS_DATA (c
)->attr
.class_pointer
12787 || CLASS_DATA (c
)->attr
.allocatable
)))
12789 gfc_error ("Component %qs with CLASS at %L must be allocatable "
12790 "or pointer", c
->name
, &c
->loc
);
12791 /* Prevent a recurrence of the error. */
12792 c
->ts
.type
= BT_UNKNOWN
;
12796 /* Ensure that all the derived type components are put on the
12797 derived type list; even in formal namespaces, where derived type
12798 pointer components might not have been declared. */
12799 if (c
->ts
.type
== BT_DERIVED
12801 && c
->ts
.u
.derived
->components
12803 && sym
!= c
->ts
.u
.derived
)
12804 add_dt_to_dt_list (c
->ts
.u
.derived
);
12806 if (!gfc_resolve_array_spec (c
->as
,
12807 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12808 || c
->attr
.allocatable
)))
12811 if (c
->initializer
&& !sym
->attr
.vtype
12812 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12819 check_defined_assignments (sym
);
12821 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12822 sym
->attr
.defined_assign_comp
12823 = super_type
->attr
.defined_assign_comp
;
12825 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12826 all DEFERRED bindings are overridden. */
12827 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12828 && !sym
->attr
.is_class
12829 && !ensure_not_abstract (sym
, super_type
))
12832 /* Add derived type to the derived type list. */
12833 add_dt_to_dt_list (sym
);
12839 /* The following procedure does the full resolution of a derived type,
12840 including resolution of all type-bound procedures (if present). In contrast
12841 to 'resolve_fl_derived0' this can only be done after the module has been
12842 parsed completely. */
12845 resolve_fl_derived (gfc_symbol
*sym
)
12847 gfc_symbol
*gen_dt
= NULL
;
12849 if (sym
->attr
.unlimited_polymorphic
)
12852 if (!sym
->attr
.is_class
)
12853 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12854 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12855 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12856 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12857 && !gfc_notify_std_1 (GFC_STD_F2003
, "Generic name '%s' of function "
12858 "'%s' at %L being the same name as derived "
12859 "type at %L", sym
->name
,
12860 gen_dt
->generic
->sym
== sym
12861 ? gen_dt
->generic
->next
->sym
->name
12862 : gen_dt
->generic
->sym
->name
,
12863 gen_dt
->generic
->sym
== sym
12864 ? &gen_dt
->generic
->next
->sym
->declared_at
12865 : &gen_dt
->generic
->sym
->declared_at
,
12866 &sym
->declared_at
))
12869 /* Resolve the finalizer procedures. */
12870 if (!gfc_resolve_finalizers (sym
, NULL
))
12873 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12875 /* Fix up incomplete CLASS symbols. */
12876 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12877 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12879 /* Nothing more to do for unlimited polymorphic entities. */
12880 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12882 else if (vptr
->ts
.u
.derived
== NULL
)
12884 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12886 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12890 if (!resolve_fl_derived0 (sym
))
12893 /* Resolve the type-bound procedures. */
12894 if (!resolve_typebound_procedures (sym
))
12902 resolve_fl_namelist (gfc_symbol
*sym
)
12907 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12909 /* Check again, the check in match only works if NAMELIST comes
12911 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12913 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
12914 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12918 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12919 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12920 "with assumed shape in namelist %qs at %L",
12921 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12924 if (is_non_constant_shape_array (nl
->sym
)
12925 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12926 "with nonconstant shape in namelist %qs at %L",
12927 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12930 if (nl
->sym
->ts
.type
== BT_CHARACTER
12931 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12932 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12933 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
12934 "nonconstant character length in "
12935 "namelist %qs at %L", nl
->sym
->name
,
12936 sym
->name
, &sym
->declared_at
))
12939 /* FIXME: Once UDDTIO is implemented, the following can be
12941 if (nl
->sym
->ts
.type
== BT_CLASS
)
12943 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
12944 "polymorphic and requires a defined input/output "
12945 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12949 if (nl
->sym
->ts
.type
== BT_DERIVED
12950 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12951 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12953 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
12954 "namelist %qs at %L with ALLOCATABLE "
12955 "or POINTER components", nl
->sym
->name
,
12956 sym
->name
, &sym
->declared_at
))
12959 /* FIXME: Once UDDTIO is implemented, the following can be
12961 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
12962 "ALLOCATABLE or POINTER components and thus requires "
12963 "a defined input/output procedure", nl
->sym
->name
,
12964 sym
->name
, &sym
->declared_at
);
12969 /* Reject PRIVATE objects in a PUBLIC namelist. */
12970 if (gfc_check_symbol_access (sym
))
12972 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12974 if (!nl
->sym
->attr
.use_assoc
12975 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12976 && !gfc_check_symbol_access (nl
->sym
))
12978 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
12979 "cannot be member of PUBLIC namelist %qs at %L",
12980 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12984 /* Types with private components that came here by USE-association. */
12985 if (nl
->sym
->ts
.type
== BT_DERIVED
12986 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12988 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
12989 "components and cannot be member of namelist %qs at %L",
12990 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12994 /* Types with private components that are defined in the same module. */
12995 if (nl
->sym
->ts
.type
== BT_DERIVED
12996 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12997 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12999 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13000 "cannot be a member of PUBLIC namelist %qs at %L",
13001 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13008 /* 14.1.2 A module or internal procedure represent local entities
13009 of the same type as a namelist member and so are not allowed. */
13010 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13012 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13015 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13016 if ((nl
->sym
== sym
->ns
->proc_name
)
13018 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13023 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13024 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13026 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13027 "attribute in %qs at %L", nlsym
->name
,
13028 &sym
->declared_at
);
13038 resolve_fl_parameter (gfc_symbol
*sym
)
13040 /* A parameter array's shape needs to be constant. */
13041 if (sym
->as
!= NULL
13042 && (sym
->as
->type
== AS_DEFERRED
13043 || is_non_constant_shape_array (sym
)))
13045 gfc_error ("Parameter array %qs at %L cannot be automatic "
13046 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13050 /* Make sure a parameter that has been implicitly typed still
13051 matches the implicit type, since PARAMETER statements can precede
13052 IMPLICIT statements. */
13053 if (sym
->attr
.implicit_type
13054 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13057 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13058 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13062 /* Make sure the types of derived parameters are consistent. This
13063 type checking is deferred until resolution because the type may
13064 refer to a derived type from the host. */
13065 if (sym
->ts
.type
== BT_DERIVED
13066 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13068 gfc_error ("Incompatible derived type in PARAMETER at %L",
13069 &sym
->value
->where
);
13076 /* Do anything necessary to resolve a symbol. Right now, we just
13077 assume that an otherwise unknown symbol is a variable. This sort
13078 of thing commonly happens for symbols in module. */
13081 resolve_symbol (gfc_symbol
*sym
)
13083 int check_constant
, mp_flag
;
13084 gfc_symtree
*symtree
;
13085 gfc_symtree
*this_symtree
;
13088 symbol_attribute class_attr
;
13089 gfc_array_spec
*as
;
13090 bool saved_specification_expr
;
13096 if (sym
->attr
.artificial
)
13099 if (sym
->attr
.unlimited_polymorphic
)
13102 if (sym
->attr
.flavor
== FL_UNKNOWN
13103 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13104 && !sym
->attr
.generic
&& !sym
->attr
.external
13105 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13106 && sym
->ts
.type
== BT_UNKNOWN
))
13109 /* If we find that a flavorless symbol is an interface in one of the
13110 parent namespaces, find its symtree in this namespace, free the
13111 symbol and set the symtree to point to the interface symbol. */
13112 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13114 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13115 if (symtree
&& (symtree
->n
.sym
->generic
||
13116 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13117 && sym
->ns
->construct_entities
)))
13119 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13121 gfc_release_symbol (sym
);
13122 symtree
->n
.sym
->refs
++;
13123 this_symtree
->n
.sym
= symtree
->n
.sym
;
13128 /* Otherwise give it a flavor according to such attributes as
13130 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13131 && sym
->attr
.intrinsic
== 0)
13132 sym
->attr
.flavor
= FL_VARIABLE
;
13133 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13135 sym
->attr
.flavor
= FL_PROCEDURE
;
13136 if (sym
->attr
.dimension
)
13137 sym
->attr
.function
= 1;
13141 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13142 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13144 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13145 && !resolve_procedure_interface (sym
))
13148 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13149 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13151 if (sym
->attr
.external
)
13152 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13153 "at %L", &sym
->declared_at
);
13155 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13156 "at %L", &sym
->declared_at
);
13161 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13164 /* Symbols that are module procedures with results (functions) have
13165 the types and array specification copied for type checking in
13166 procedures that call them, as well as for saving to a module
13167 file. These symbols can't stand the scrutiny that their results
13169 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13171 /* Make sure that the intrinsic is consistent with its internal
13172 representation. This needs to be done before assigning a default
13173 type to avoid spurious warnings. */
13174 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13175 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13178 /* Resolve associate names. */
13180 resolve_assoc_var (sym
, true);
13182 /* Assign default type to symbols that need one and don't have one. */
13183 if (sym
->ts
.type
== BT_UNKNOWN
)
13185 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13187 gfc_set_default_type (sym
, 1, NULL
);
13190 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13191 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13192 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13193 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13195 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13197 /* The specific case of an external procedure should emit an error
13198 in the case that there is no implicit type. */
13200 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13203 /* Result may be in another namespace. */
13204 resolve_symbol (sym
->result
);
13206 if (!sym
->result
->attr
.proc_pointer
)
13208 sym
->ts
= sym
->result
->ts
;
13209 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13210 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13211 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13212 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13213 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13218 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13220 bool saved_specification_expr
= specification_expr
;
13221 specification_expr
= true;
13222 gfc_resolve_array_spec (sym
->result
->as
, false);
13223 specification_expr
= saved_specification_expr
;
13226 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13228 as
= CLASS_DATA (sym
)->as
;
13229 class_attr
= CLASS_DATA (sym
)->attr
;
13230 class_attr
.pointer
= class_attr
.class_pointer
;
13234 class_attr
= sym
->attr
;
13239 if (sym
->attr
.contiguous
13240 && (!class_attr
.dimension
13241 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13242 && !class_attr
.pointer
)))
13244 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13245 "array pointer or an assumed-shape or assumed-rank array",
13246 sym
->name
, &sym
->declared_at
);
13250 /* Assumed size arrays and assumed shape arrays must be dummy
13251 arguments. Array-spec's of implied-shape should have been resolved to
13252 AS_EXPLICIT already. */
13256 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13257 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13258 || as
->type
== AS_ASSUMED_SHAPE
)
13259 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13261 if (as
->type
== AS_ASSUMED_SIZE
)
13262 gfc_error ("Assumed size array at %L must be a dummy argument",
13263 &sym
->declared_at
);
13265 gfc_error ("Assumed shape array at %L must be a dummy argument",
13266 &sym
->declared_at
);
13269 /* TS 29113, C535a. */
13270 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13271 && !sym
->attr
.select_type_temporary
)
13273 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13274 &sym
->declared_at
);
13277 if (as
->type
== AS_ASSUMED_RANK
13278 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13280 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13281 "CODIMENSION attribute", &sym
->declared_at
);
13286 /* Make sure symbols with known intent or optional are really dummy
13287 variable. Because of ENTRY statement, this has to be deferred
13288 until resolution time. */
13290 if (!sym
->attr
.dummy
13291 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13293 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13297 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13299 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13300 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13304 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13306 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13307 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13309 gfc_error ("Character dummy variable %qs at %L with VALUE "
13310 "attribute must have constant length",
13311 sym
->name
, &sym
->declared_at
);
13315 if (sym
->ts
.is_c_interop
13316 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13318 gfc_error ("C interoperable character dummy variable %qs at %L "
13319 "with VALUE attribute must have length one",
13320 sym
->name
, &sym
->declared_at
);
13325 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13326 && sym
->ts
.u
.derived
->attr
.generic
)
13328 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13329 if (!sym
->ts
.u
.derived
)
13331 gfc_error ("The derived type %qs at %L is of type %qs, "
13332 "which has not been defined", sym
->name
,
13333 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13334 sym
->ts
.type
= BT_UNKNOWN
;
13339 /* Use the same constraints as TYPE(*), except for the type check
13340 and that only scalars and assumed-size arrays are permitted. */
13341 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13343 if (!sym
->attr
.dummy
)
13345 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13346 "a dummy argument", sym
->name
, &sym
->declared_at
);
13350 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13351 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13352 && sym
->ts
.type
!= BT_COMPLEX
)
13354 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13355 "of type TYPE(*) or of an numeric intrinsic type",
13356 sym
->name
, &sym
->declared_at
);
13360 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13361 || sym
->attr
.pointer
|| sym
->attr
.value
)
13363 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13364 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13365 "attribute", sym
->name
, &sym
->declared_at
);
13369 if (sym
->attr
.intent
== INTENT_OUT
)
13371 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13372 "have the INTENT(OUT) attribute",
13373 sym
->name
, &sym
->declared_at
);
13376 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13378 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13379 "either be a scalar or an assumed-size array",
13380 sym
->name
, &sym
->declared_at
);
13384 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13385 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13387 sym
->ts
.type
= BT_ASSUMED
;
13388 sym
->as
= gfc_get_array_spec ();
13389 sym
->as
->type
= AS_ASSUMED_SIZE
;
13391 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13393 else if (sym
->ts
.type
== BT_ASSUMED
)
13395 /* TS 29113, C407a. */
13396 if (!sym
->attr
.dummy
)
13398 gfc_error ("Assumed type of variable %s at %L is only permitted "
13399 "for dummy variables", sym
->name
, &sym
->declared_at
);
13402 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13403 || sym
->attr
.pointer
|| sym
->attr
.value
)
13405 gfc_error ("Assumed-type variable %s at %L may not have the "
13406 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13407 sym
->name
, &sym
->declared_at
);
13410 if (sym
->attr
.intent
== INTENT_OUT
)
13412 gfc_error ("Assumed-type variable %s at %L may not have the "
13413 "INTENT(OUT) attribute",
13414 sym
->name
, &sym
->declared_at
);
13417 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13419 gfc_error ("Assumed-type variable %s at %L shall not be an "
13420 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13425 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13426 do this for something that was implicitly typed because that is handled
13427 in gfc_set_default_type. Handle dummy arguments and procedure
13428 definitions separately. Also, anything that is use associated is not
13429 handled here but instead is handled in the module it is declared in.
13430 Finally, derived type definitions are allowed to be BIND(C) since that
13431 only implies that they're interoperable, and they are checked fully for
13432 interoperability when a variable is declared of that type. */
13433 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13434 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13435 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13439 /* First, make sure the variable is declared at the
13440 module-level scope (J3/04-007, Section 15.3). */
13441 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13442 sym
->attr
.in_common
== 0)
13444 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13445 "is neither a COMMON block nor declared at the "
13446 "module level scope", sym
->name
, &(sym
->declared_at
));
13449 else if (sym
->common_head
!= NULL
)
13451 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13455 /* If type() declaration, we need to verify that the components
13456 of the given type are all C interoperable, etc. */
13457 if (sym
->ts
.type
== BT_DERIVED
&&
13458 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13460 /* Make sure the user marked the derived type as BIND(C). If
13461 not, call the verify routine. This could print an error
13462 for the derived type more than once if multiple variables
13463 of that type are declared. */
13464 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13465 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13469 /* Verify the variable itself as C interoperable if it
13470 is BIND(C). It is not possible for this to succeed if
13471 the verify_bind_c_derived_type failed, so don't have to handle
13472 any error returned by verify_bind_c_derived_type. */
13473 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13474 sym
->common_block
);
13479 /* clear the is_bind_c flag to prevent reporting errors more than
13480 once if something failed. */
13481 sym
->attr
.is_bind_c
= 0;
13486 /* If a derived type symbol has reached this point, without its
13487 type being declared, we have an error. Notice that most
13488 conditions that produce undefined derived types have already
13489 been dealt with. However, the likes of:
13490 implicit type(t) (t) ..... call foo (t) will get us here if
13491 the type is not declared in the scope of the implicit
13492 statement. Change the type to BT_UNKNOWN, both because it is so
13493 and to prevent an ICE. */
13494 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13495 && sym
->ts
.u
.derived
->components
== NULL
13496 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13498 gfc_error ("The derived type %qs at %L is of type %qs, "
13499 "which has not been defined", sym
->name
,
13500 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13501 sym
->ts
.type
= BT_UNKNOWN
;
13505 /* Make sure that the derived type has been resolved and that the
13506 derived type is visible in the symbol's namespace, if it is a
13507 module function and is not PRIVATE. */
13508 if (sym
->ts
.type
== BT_DERIVED
13509 && sym
->ts
.u
.derived
->attr
.use_assoc
13510 && sym
->ns
->proc_name
13511 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13512 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13515 /* Unless the derived-type declaration is use associated, Fortran 95
13516 does not allow public entries of private derived types.
13517 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13518 161 in 95-006r3. */
13519 if (sym
->ts
.type
== BT_DERIVED
13520 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13521 && !sym
->ts
.u
.derived
->attr
.use_assoc
13522 && gfc_check_symbol_access (sym
)
13523 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13524 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
13525 "derived type %qs",
13526 (sym
->attr
.flavor
== FL_PARAMETER
)
13527 ? "parameter" : "variable",
13528 sym
->name
, &sym
->declared_at
,
13529 sym
->ts
.u
.derived
->name
))
13532 /* F2008, C1302. */
13533 if (sym
->ts
.type
== BT_DERIVED
13534 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13535 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13536 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13537 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13539 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13540 "type LOCK_TYPE must be a coarray", sym
->name
,
13541 &sym
->declared_at
);
13545 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13546 default initialization is defined (5.1.2.4.4). */
13547 if (sym
->ts
.type
== BT_DERIVED
13549 && sym
->attr
.intent
== INTENT_OUT
13551 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13553 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13555 if (c
->initializer
)
13557 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
13558 "ASSUMED SIZE and so cannot have a default initializer",
13559 sym
->name
, &sym
->declared_at
);
13566 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13567 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13569 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
13570 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13575 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13576 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13577 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13578 || class_attr
.codimension
)
13579 && (sym
->attr
.result
|| sym
->result
== sym
))
13581 gfc_error ("Function result %qs at %L shall not be a coarray or have "
13582 "a coarray component", sym
->name
, &sym
->declared_at
);
13587 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13588 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13590 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13591 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13596 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13597 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13598 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13599 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13600 || class_attr
.allocatable
))
13602 gfc_error ("Variable %qs at %L with coarray component shall be a "
13603 "nonpointer, nonallocatable scalar, which is not a coarray",
13604 sym
->name
, &sym
->declared_at
);
13608 /* F2008, C526. The function-result case was handled above. */
13609 if (class_attr
.codimension
13610 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13611 || sym
->attr
.select_type_temporary
13612 || sym
->ns
->save_all
13613 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13614 || sym
->ns
->proc_name
->attr
.is_main_program
13615 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13617 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
13618 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13622 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13623 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13625 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
13626 "deferred shape", sym
->name
, &sym
->declared_at
);
13629 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13630 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13632 gfc_error ("Allocatable coarray variable %qs at %L must have "
13633 "deferred shape", sym
->name
, &sym
->declared_at
);
13638 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13639 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13640 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13641 || (class_attr
.codimension
&& class_attr
.allocatable
))
13642 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13644 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
13645 "allocatable coarray or have coarray components",
13646 sym
->name
, &sym
->declared_at
);
13650 if (class_attr
.codimension
&& sym
->attr
.dummy
13651 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13653 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
13654 "procedure %qs", sym
->name
, &sym
->declared_at
,
13655 sym
->ns
->proc_name
->name
);
13659 if (sym
->ts
.type
== BT_LOGICAL
13660 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13661 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13662 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13665 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13666 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13668 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13669 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
13670 "%L with non-C_Bool kind in BIND(C) procedure "
13671 "%qs", sym
->name
, &sym
->declared_at
,
13672 sym
->ns
->proc_name
->name
))
13674 else if (!gfc_logical_kinds
[i
].c_bool
13675 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13676 "%qs at %L with non-C_Bool kind in "
13677 "BIND(C) procedure %qs", sym
->name
,
13679 sym
->attr
.function
? sym
->name
13680 : sym
->ns
->proc_name
->name
))
13684 switch (sym
->attr
.flavor
)
13687 if (!resolve_fl_variable (sym
, mp_flag
))
13692 if (!resolve_fl_procedure (sym
, mp_flag
))
13697 if (!resolve_fl_namelist (sym
))
13702 if (!resolve_fl_parameter (sym
))
13710 /* Resolve array specifier. Check as well some constraints
13711 on COMMON blocks. */
13713 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13715 /* Set the formal_arg_flag so that check_conflict will not throw
13716 an error for host associated variables in the specification
13717 expression for an array_valued function. */
13718 if (sym
->attr
.function
&& sym
->as
)
13719 formal_arg_flag
= 1;
13721 saved_specification_expr
= specification_expr
;
13722 specification_expr
= true;
13723 gfc_resolve_array_spec (sym
->as
, check_constant
);
13724 specification_expr
= saved_specification_expr
;
13726 formal_arg_flag
= 0;
13728 /* Resolve formal namespaces. */
13729 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13730 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13731 gfc_resolve (sym
->formal_ns
);
13733 /* Make sure the formal namespace is present. */
13734 if (sym
->formal
&& !sym
->formal_ns
)
13736 gfc_formal_arglist
*formal
= sym
->formal
;
13737 while (formal
&& !formal
->sym
)
13738 formal
= formal
->next
;
13742 sym
->formal_ns
= formal
->sym
->ns
;
13743 if (sym
->ns
!= formal
->sym
->ns
)
13744 sym
->formal_ns
->refs
++;
13748 /* Check threadprivate restrictions. */
13749 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13750 && (!sym
->attr
.in_common
13751 && sym
->module
== NULL
13752 && (sym
->ns
->proc_name
== NULL
13753 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13754 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13756 /* Check omp declare target restrictions. */
13757 if (sym
->attr
.omp_declare_target
13758 && sym
->attr
.flavor
== FL_VARIABLE
13760 && !sym
->ns
->save_all
13761 && (!sym
->attr
.in_common
13762 && sym
->module
== NULL
13763 && (sym
->ns
->proc_name
== NULL
13764 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13765 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
13766 sym
->name
, &sym
->declared_at
);
13768 /* If we have come this far we can apply default-initializers, as
13769 described in 14.7.5, to those variables that have not already
13770 been assigned one. */
13771 if (sym
->ts
.type
== BT_DERIVED
13773 && !sym
->attr
.allocatable
13774 && !sym
->attr
.alloc_comp
)
13776 symbol_attribute
*a
= &sym
->attr
;
13778 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13779 && !a
->in_common
&& !a
->use_assoc
13780 && (a
->referenced
|| a
->result
)
13781 && !(a
->function
&& sym
!= sym
->result
))
13782 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13783 apply_default_init (sym
);
13786 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13787 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13788 && !CLASS_DATA (sym
)->attr
.class_pointer
13789 && !CLASS_DATA (sym
)->attr
.allocatable
)
13790 apply_default_init (sym
);
13792 /* If this symbol has a type-spec, check it. */
13793 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13794 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13795 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13800 /************* Resolve DATA statements *************/
13804 gfc_data_value
*vnode
;
13810 /* Advance the values structure to point to the next value in the data list. */
13813 next_data_value (void)
13815 while (mpz_cmp_ui (values
.left
, 0) == 0)
13818 if (values
.vnode
->next
== NULL
)
13821 values
.vnode
= values
.vnode
->next
;
13822 mpz_set (values
.left
, values
.vnode
->repeat
);
13830 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13836 ar_type mark
= AR_UNKNOWN
;
13838 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13844 if (!gfc_resolve_expr (var
->expr
))
13848 mpz_init_set_si (offset
, 0);
13851 if (e
->expr_type
!= EXPR_VARIABLE
)
13852 gfc_internal_error ("check_data_variable(): Bad expression");
13854 sym
= e
->symtree
->n
.sym
;
13856 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13858 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
13859 sym
->name
, &sym
->declared_at
);
13862 if (e
->ref
== NULL
&& sym
->as
)
13864 gfc_error ("DATA array %qs at %L must be specified in a previous"
13865 " declaration", sym
->name
, where
);
13869 has_pointer
= sym
->attr
.pointer
;
13871 if (gfc_is_coindexed (e
))
13873 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
13878 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13880 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13884 && ref
->type
== REF_ARRAY
13885 && ref
->u
.ar
.type
!= AR_FULL
)
13887 gfc_error ("DATA element %qs at %L is a pointer and so must "
13888 "be a full array", sym
->name
, where
);
13893 if (e
->rank
== 0 || has_pointer
)
13895 mpz_init_set_ui (size
, 1);
13902 /* Find the array section reference. */
13903 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13905 if (ref
->type
!= REF_ARRAY
)
13907 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13913 /* Set marks according to the reference pattern. */
13914 switch (ref
->u
.ar
.type
)
13922 /* Get the start position of array section. */
13923 gfc_get_section_index (ar
, section_index
, &offset
);
13928 gcc_unreachable ();
13931 if (!gfc_array_size (e
, &size
))
13933 gfc_error ("Nonconstant array section at %L in DATA statement",
13935 mpz_clear (offset
);
13942 while (mpz_cmp_ui (size
, 0) > 0)
13944 if (!next_data_value ())
13946 gfc_error ("DATA statement at %L has more variables than values",
13952 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13956 /* If we have more than one element left in the repeat count,
13957 and we have more than one element left in the target variable,
13958 then create a range assignment. */
13959 /* FIXME: Only done for full arrays for now, since array sections
13961 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13962 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13966 if (mpz_cmp (size
, values
.left
) >= 0)
13968 mpz_init_set (range
, values
.left
);
13969 mpz_sub (size
, size
, values
.left
);
13970 mpz_set_ui (values
.left
, 0);
13974 mpz_init_set (range
, size
);
13975 mpz_sub (values
.left
, values
.left
, size
);
13976 mpz_set_ui (size
, 0);
13979 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13982 mpz_add (offset
, offset
, range
);
13989 /* Assign initial value to symbol. */
13992 mpz_sub_ui (values
.left
, values
.left
, 1);
13993 mpz_sub_ui (size
, size
, 1);
13995 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14000 if (mark
== AR_FULL
)
14001 mpz_add_ui (offset
, offset
, 1);
14003 /* Modify the array section indexes and recalculate the offset
14004 for next element. */
14005 else if (mark
== AR_SECTION
)
14006 gfc_advance_section (section_index
, ar
, &offset
);
14010 if (mark
== AR_SECTION
)
14012 for (i
= 0; i
< ar
->dimen
; i
++)
14013 mpz_clear (section_index
[i
]);
14017 mpz_clear (offset
);
14023 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14025 /* Iterate over a list of elements in a DATA statement. */
14028 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14031 iterator_stack frame
;
14032 gfc_expr
*e
, *start
, *end
, *step
;
14033 bool retval
= true;
14035 mpz_init (frame
.value
);
14038 start
= gfc_copy_expr (var
->iter
.start
);
14039 end
= gfc_copy_expr (var
->iter
.end
);
14040 step
= gfc_copy_expr (var
->iter
.step
);
14042 if (!gfc_simplify_expr (start
, 1)
14043 || start
->expr_type
!= EXPR_CONSTANT
)
14045 gfc_error ("start of implied-do loop at %L could not be "
14046 "simplified to a constant value", &start
->where
);
14050 if (!gfc_simplify_expr (end
, 1)
14051 || end
->expr_type
!= EXPR_CONSTANT
)
14053 gfc_error ("end of implied-do loop at %L could not be "
14054 "simplified to a constant value", &start
->where
);
14058 if (!gfc_simplify_expr (step
, 1)
14059 || step
->expr_type
!= EXPR_CONSTANT
)
14061 gfc_error ("step of implied-do loop at %L could not be "
14062 "simplified to a constant value", &start
->where
);
14067 mpz_set (trip
, end
->value
.integer
);
14068 mpz_sub (trip
, trip
, start
->value
.integer
);
14069 mpz_add (trip
, trip
, step
->value
.integer
);
14071 mpz_div (trip
, trip
, step
->value
.integer
);
14073 mpz_set (frame
.value
, start
->value
.integer
);
14075 frame
.prev
= iter_stack
;
14076 frame
.variable
= var
->iter
.var
->symtree
;
14077 iter_stack
= &frame
;
14079 while (mpz_cmp_ui (trip
, 0) > 0)
14081 if (!traverse_data_var (var
->list
, where
))
14087 e
= gfc_copy_expr (var
->expr
);
14088 if (!gfc_simplify_expr (e
, 1))
14095 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14097 mpz_sub_ui (trip
, trip
, 1);
14101 mpz_clear (frame
.value
);
14104 gfc_free_expr (start
);
14105 gfc_free_expr (end
);
14106 gfc_free_expr (step
);
14108 iter_stack
= frame
.prev
;
14113 /* Type resolve variables in the variable list of a DATA statement. */
14116 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14120 for (; var
; var
= var
->next
)
14122 if (var
->expr
== NULL
)
14123 t
= traverse_data_list (var
, where
);
14125 t
= check_data_variable (var
, where
);
14135 /* Resolve the expressions and iterators associated with a data statement.
14136 This is separate from the assignment checking because data lists should
14137 only be resolved once. */
14140 resolve_data_variables (gfc_data_variable
*d
)
14142 for (; d
; d
= d
->next
)
14144 if (d
->list
== NULL
)
14146 if (!gfc_resolve_expr (d
->expr
))
14151 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14154 if (!resolve_data_variables (d
->list
))
14163 /* Resolve a single DATA statement. We implement this by storing a pointer to
14164 the value list into static variables, and then recursively traversing the
14165 variables list, expanding iterators and such. */
14168 resolve_data (gfc_data
*d
)
14171 if (!resolve_data_variables (d
->var
))
14174 values
.vnode
= d
->value
;
14175 if (d
->value
== NULL
)
14176 mpz_set_ui (values
.left
, 0);
14178 mpz_set (values
.left
, d
->value
->repeat
);
14180 if (!traverse_data_var (d
->var
, &d
->where
))
14183 /* At this point, we better not have any values left. */
14185 if (next_data_value ())
14186 gfc_error ("DATA statement at %L has more values than variables",
14191 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14192 accessed by host or use association, is a dummy argument to a pure function,
14193 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14194 is storage associated with any such variable, shall not be used in the
14195 following contexts: (clients of this function). */
14197 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14198 procedure. Returns zero if assignment is OK, nonzero if there is a
14201 gfc_impure_variable (gfc_symbol
*sym
)
14206 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14209 /* Check if the symbol's ns is inside the pure procedure. */
14210 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14214 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14218 proc
= sym
->ns
->proc_name
;
14219 if (sym
->attr
.dummy
14220 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14221 || proc
->attr
.function
))
14224 /* TODO: Sort out what can be storage associated, if anything, and include
14225 it here. In principle equivalences should be scanned but it does not
14226 seem to be possible to storage associate an impure variable this way. */
14231 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14232 current namespace is inside a pure procedure. */
14235 gfc_pure (gfc_symbol
*sym
)
14237 symbol_attribute attr
;
14242 /* Check if the current namespace or one of its parents
14243 belongs to a pure procedure. */
14244 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14246 sym
= ns
->proc_name
;
14250 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14258 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14262 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14263 checks if the current namespace is implicitly pure. Note that this
14264 function returns false for a PURE procedure. */
14267 gfc_implicit_pure (gfc_symbol
*sym
)
14273 /* Check if the current procedure is implicit_pure. Walk up
14274 the procedure list until we find a procedure. */
14275 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14277 sym
= ns
->proc_name
;
14281 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14286 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14287 && !sym
->attr
.pure
;
14292 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14298 /* Check if the current procedure is implicit_pure. Walk up
14299 the procedure list until we find a procedure. */
14300 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14302 sym
= ns
->proc_name
;
14306 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14311 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14312 sym
->attr
.implicit_pure
= 0;
14314 sym
->attr
.pure
= 0;
14318 /* Test whether the current procedure is elemental or not. */
14321 gfc_elemental (gfc_symbol
*sym
)
14323 symbol_attribute attr
;
14326 sym
= gfc_current_ns
->proc_name
;
14331 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14335 /* Warn about unused labels. */
14338 warn_unused_fortran_label (gfc_st_label
*label
)
14343 warn_unused_fortran_label (label
->left
);
14345 if (label
->defined
== ST_LABEL_UNKNOWN
)
14348 switch (label
->referenced
)
14350 case ST_LABEL_UNKNOWN
:
14351 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
14355 case ST_LABEL_BAD_TARGET
:
14356 gfc_warning (0, "Label %d at %L defined but cannot be used",
14357 label
->value
, &label
->where
);
14364 warn_unused_fortran_label (label
->right
);
14368 /* Returns the sequence type of a symbol or sequence. */
14371 sequence_type (gfc_typespec ts
)
14380 if (ts
.u
.derived
->components
== NULL
)
14381 return SEQ_NONDEFAULT
;
14383 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14384 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14385 if (sequence_type (c
->ts
) != result
)
14391 if (ts
.kind
!= gfc_default_character_kind
)
14392 return SEQ_NONDEFAULT
;
14394 return SEQ_CHARACTER
;
14397 if (ts
.kind
!= gfc_default_integer_kind
)
14398 return SEQ_NONDEFAULT
;
14400 return SEQ_NUMERIC
;
14403 if (!(ts
.kind
== gfc_default_real_kind
14404 || ts
.kind
== gfc_default_double_kind
))
14405 return SEQ_NONDEFAULT
;
14407 return SEQ_NUMERIC
;
14410 if (ts
.kind
!= gfc_default_complex_kind
)
14411 return SEQ_NONDEFAULT
;
14413 return SEQ_NUMERIC
;
14416 if (ts
.kind
!= gfc_default_logical_kind
)
14417 return SEQ_NONDEFAULT
;
14419 return SEQ_NUMERIC
;
14422 return SEQ_NONDEFAULT
;
14427 /* Resolve derived type EQUIVALENCE object. */
14430 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14432 gfc_component
*c
= derived
->components
;
14437 /* Shall not be an object of nonsequence derived type. */
14438 if (!derived
->attr
.sequence
)
14440 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14441 "attribute to be an EQUIVALENCE object", sym
->name
,
14446 /* Shall not have allocatable components. */
14447 if (derived
->attr
.alloc_comp
)
14449 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14450 "components to be an EQUIVALENCE object",sym
->name
,
14455 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14457 gfc_error ("Derived type variable %qs at %L with default "
14458 "initialization cannot be in EQUIVALENCE with a variable "
14459 "in COMMON", sym
->name
, &e
->where
);
14463 for (; c
; c
= c
->next
)
14465 if (c
->ts
.type
== BT_DERIVED
14466 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14469 /* Shall not be an object of sequence derived type containing a pointer
14470 in the structure. */
14471 if (c
->attr
.pointer
)
14473 gfc_error ("Derived type variable %qs at %L with pointer "
14474 "component(s) cannot be an EQUIVALENCE object",
14475 sym
->name
, &e
->where
);
14483 /* Resolve equivalence object.
14484 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14485 an allocatable array, an object of nonsequence derived type, an object of
14486 sequence derived type containing a pointer at any level of component
14487 selection, an automatic object, a function name, an entry name, a result
14488 name, a named constant, a structure component, or a subobject of any of
14489 the preceding objects. A substring shall not have length zero. A
14490 derived type shall not have components with default initialization nor
14491 shall two objects of an equivalence group be initialized.
14492 Either all or none of the objects shall have an protected attribute.
14493 The simple constraints are done in symbol.c(check_conflict) and the rest
14494 are implemented here. */
14497 resolve_equivalence (gfc_equiv
*eq
)
14500 gfc_symbol
*first_sym
;
14503 locus
*last_where
= NULL
;
14504 seq_type eq_type
, last_eq_type
;
14505 gfc_typespec
*last_ts
;
14506 int object
, cnt_protected
;
14509 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14511 first_sym
= eq
->expr
->symtree
->n
.sym
;
14515 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14519 e
->ts
= e
->symtree
->n
.sym
->ts
;
14520 /* match_varspec might not know yet if it is seeing
14521 array reference or substring reference, as it doesn't
14523 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14525 gfc_ref
*ref
= e
->ref
;
14526 sym
= e
->symtree
->n
.sym
;
14528 if (sym
->attr
.dimension
)
14530 ref
->u
.ar
.as
= sym
->as
;
14534 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14535 if (e
->ts
.type
== BT_CHARACTER
14537 && ref
->type
== REF_ARRAY
14538 && ref
->u
.ar
.dimen
== 1
14539 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14540 && ref
->u
.ar
.stride
[0] == NULL
)
14542 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14543 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14546 /* Optimize away the (:) reference. */
14547 if (start
== NULL
&& end
== NULL
)
14550 e
->ref
= ref
->next
;
14552 e
->ref
->next
= ref
->next
;
14557 ref
->type
= REF_SUBSTRING
;
14559 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14561 ref
->u
.ss
.start
= start
;
14562 if (end
== NULL
&& e
->ts
.u
.cl
)
14563 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14564 ref
->u
.ss
.end
= end
;
14565 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14572 /* Any further ref is an error. */
14575 gcc_assert (ref
->type
== REF_ARRAY
);
14576 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14582 if (!gfc_resolve_expr (e
))
14585 sym
= e
->symtree
->n
.sym
;
14587 if (sym
->attr
.is_protected
)
14589 if (cnt_protected
> 0 && cnt_protected
!= object
)
14591 gfc_error ("Either all or none of the objects in the "
14592 "EQUIVALENCE set at %L shall have the "
14593 "PROTECTED attribute",
14598 /* Shall not equivalence common block variables in a PURE procedure. */
14599 if (sym
->ns
->proc_name
14600 && sym
->ns
->proc_name
->attr
.pure
14601 && sym
->attr
.in_common
)
14603 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
14604 "object in the pure procedure %qs",
14605 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14609 /* Shall not be a named constant. */
14610 if (e
->expr_type
== EXPR_CONSTANT
)
14612 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
14613 "object", sym
->name
, &e
->where
);
14617 if (e
->ts
.type
== BT_DERIVED
14618 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14621 /* Check that the types correspond correctly:
14623 A numeric sequence structure may be equivalenced to another sequence
14624 structure, an object of default integer type, default real type, double
14625 precision real type, default logical type such that components of the
14626 structure ultimately only become associated to objects of the same
14627 kind. A character sequence structure may be equivalenced to an object
14628 of default character kind or another character sequence structure.
14629 Other objects may be equivalenced only to objects of the same type and
14630 kind parameters. */
14632 /* Identical types are unconditionally OK. */
14633 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14634 goto identical_types
;
14636 last_eq_type
= sequence_type (*last_ts
);
14637 eq_type
= sequence_type (sym
->ts
);
14639 /* Since the pair of objects is not of the same type, mixed or
14640 non-default sequences can be rejected. */
14642 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14643 "statement at %L with different type objects";
14645 && last_eq_type
== SEQ_MIXED
14646 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14647 || (eq_type
== SEQ_MIXED
14648 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14651 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14652 "statement at %L with objects of different type";
14654 && last_eq_type
== SEQ_NONDEFAULT
14655 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14656 || (eq_type
== SEQ_NONDEFAULT
14657 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14660 msg
="Non-CHARACTER object %qs in default CHARACTER "
14661 "EQUIVALENCE statement at %L";
14662 if (last_eq_type
== SEQ_CHARACTER
14663 && eq_type
!= SEQ_CHARACTER
14664 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14667 msg
="Non-NUMERIC object %qs in default NUMERIC "
14668 "EQUIVALENCE statement at %L";
14669 if (last_eq_type
== SEQ_NUMERIC
14670 && eq_type
!= SEQ_NUMERIC
14671 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14676 last_where
= &e
->where
;
14681 /* Shall not be an automatic array. */
14682 if (e
->ref
->type
== REF_ARRAY
14683 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14685 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
14686 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14693 /* Shall not be a structure component. */
14694 if (r
->type
== REF_COMPONENT
)
14696 gfc_error ("Structure component %qs at %L cannot be an "
14697 "EQUIVALENCE object",
14698 r
->u
.c
.component
->name
, &e
->where
);
14702 /* A substring shall not have length zero. */
14703 if (r
->type
== REF_SUBSTRING
)
14705 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14707 gfc_error ("Substring at %L has length zero",
14708 &r
->u
.ss
.start
->where
);
14718 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14721 resolve_fntype (gfc_namespace
*ns
)
14723 gfc_entry_list
*el
;
14726 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14729 /* If there are any entries, ns->proc_name is the entry master
14730 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14732 sym
= ns
->entries
->sym
;
14734 sym
= ns
->proc_name
;
14735 if (sym
->result
== sym
14736 && sym
->ts
.type
== BT_UNKNOWN
14737 && !gfc_set_default_type (sym
, 0, NULL
)
14738 && !sym
->attr
.untyped
)
14740 gfc_error ("Function %qs at %L has no IMPLICIT type",
14741 sym
->name
, &sym
->declared_at
);
14742 sym
->attr
.untyped
= 1;
14745 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14746 && !sym
->attr
.contained
14747 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14748 && gfc_check_symbol_access (sym
))
14750 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
14751 "%L of PRIVATE type %qs", sym
->name
,
14752 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14756 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14758 if (el
->sym
->result
== el
->sym
14759 && el
->sym
->ts
.type
== BT_UNKNOWN
14760 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14761 && !el
->sym
->attr
.untyped
)
14763 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
14764 el
->sym
->name
, &el
->sym
->declared_at
);
14765 el
->sym
->attr
.untyped
= 1;
14771 /* 12.3.2.1.1 Defined operators. */
14774 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14776 gfc_formal_arglist
*formal
;
14778 if (!sym
->attr
.function
)
14780 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
14781 sym
->name
, &where
);
14785 if (sym
->ts
.type
== BT_CHARACTER
14786 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14787 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14788 && sym
->result
->ts
.u
.cl
->length
))
14790 gfc_error ("User operator procedure %qs at %L cannot be assumed "
14791 "character length", sym
->name
, &where
);
14795 formal
= gfc_sym_get_dummy_args (sym
);
14796 if (!formal
|| !formal
->sym
)
14798 gfc_error ("User operator procedure %qs at %L must have at least "
14799 "one argument", sym
->name
, &where
);
14803 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14805 gfc_error ("First argument of operator interface at %L must be "
14806 "INTENT(IN)", &where
);
14810 if (formal
->sym
->attr
.optional
)
14812 gfc_error ("First argument of operator interface at %L cannot be "
14813 "optional", &where
);
14817 formal
= formal
->next
;
14818 if (!formal
|| !formal
->sym
)
14821 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14823 gfc_error ("Second argument of operator interface at %L must be "
14824 "INTENT(IN)", &where
);
14828 if (formal
->sym
->attr
.optional
)
14830 gfc_error ("Second argument of operator interface at %L cannot be "
14831 "optional", &where
);
14837 gfc_error ("Operator interface at %L must have, at most, two "
14838 "arguments", &where
);
14846 gfc_resolve_uops (gfc_symtree
*symtree
)
14848 gfc_interface
*itr
;
14850 if (symtree
== NULL
)
14853 gfc_resolve_uops (symtree
->left
);
14854 gfc_resolve_uops (symtree
->right
);
14856 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14857 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14861 /* Examine all of the expressions associated with a program unit,
14862 assign types to all intermediate expressions, make sure that all
14863 assignments are to compatible types and figure out which names
14864 refer to which functions or subroutines. It doesn't check code
14865 block, which is handled by gfc_resolve_code. */
14868 resolve_types (gfc_namespace
*ns
)
14874 gfc_namespace
* old_ns
= gfc_current_ns
;
14876 /* Check that all IMPLICIT types are ok. */
14877 if (!ns
->seen_implicit_none
)
14880 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14881 if (ns
->set_flag
[letter
]
14882 && !resolve_typespec_used (&ns
->default_type
[letter
],
14883 &ns
->implicit_loc
[letter
], NULL
))
14887 gfc_current_ns
= ns
;
14889 resolve_entries (ns
);
14891 resolve_common_vars (ns
->blank_common
.head
, false);
14892 resolve_common_blocks (ns
->common_root
);
14894 resolve_contained_functions (ns
);
14896 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14897 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14898 resolve_formal_arglist (ns
->proc_name
);
14900 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14902 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14903 resolve_charlen (cl
);
14905 gfc_traverse_ns (ns
, resolve_symbol
);
14907 resolve_fntype (ns
);
14909 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14911 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14912 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
14913 "also be PURE", n
->proc_name
->name
,
14914 &n
->proc_name
->declared_at
);
14920 gfc_do_concurrent_flag
= 0;
14921 gfc_check_interfaces (ns
);
14923 gfc_traverse_ns (ns
, resolve_values
);
14929 for (d
= ns
->data
; d
; d
= d
->next
)
14933 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14935 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14937 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14938 resolve_equivalence (eq
);
14940 /* Warn about unused labels. */
14941 if (warn_unused_label
)
14942 warn_unused_fortran_label (ns
->st_labels
);
14944 gfc_resolve_uops (ns
->uop_root
);
14946 gfc_resolve_omp_declare_simd (ns
);
14948 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
14950 gfc_current_ns
= old_ns
;
14954 /* Call gfc_resolve_code recursively. */
14957 resolve_codes (gfc_namespace
*ns
)
14960 bitmap_obstack old_obstack
;
14962 if (ns
->resolved
== 1)
14965 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14968 gfc_current_ns
= ns
;
14970 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14971 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14974 /* Set to an out of range value. */
14975 current_entry_id
= -1;
14977 old_obstack
= labels_obstack
;
14978 bitmap_obstack_initialize (&labels_obstack
);
14980 gfc_resolve_oacc_declare (ns
);
14981 gfc_resolve_code (ns
->code
, ns
);
14983 bitmap_obstack_release (&labels_obstack
);
14984 labels_obstack
= old_obstack
;
14988 /* This function is called after a complete program unit has been compiled.
14989 Its purpose is to examine all of the expressions associated with a program
14990 unit, assign types to all intermediate expressions, make sure that all
14991 assignments are to compatible types and figure out which names refer to
14992 which functions or subroutines. */
14995 gfc_resolve (gfc_namespace
*ns
)
14997 gfc_namespace
*old_ns
;
14998 code_stack
*old_cs_base
;
15004 old_ns
= gfc_current_ns
;
15005 old_cs_base
= cs_base
;
15007 resolve_types (ns
);
15008 component_assignment_level
= 0;
15009 resolve_codes (ns
);
15011 gfc_current_ns
= old_ns
;
15012 cs_base
= old_cs_base
;
15015 gfc_run_passes (ns
);