1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* Nonzero if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static int formal_arg_flag
= 0;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
217 sym
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
218 sym
->attr
.pointer
= ifc
->result
->attr
.pointer
;
219 sym
->attr
.dimension
= ifc
->result
->attr
.dimension
;
220 sym
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
221 sym
->as
= gfc_copy_array_spec (ifc
->result
->as
);
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
231 sym
->as
= gfc_copy_array_spec (ifc
->as
);
233 sym
->ts
.interface
= ifc
;
234 sym
->attr
.function
= ifc
->attr
.function
;
235 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
237 sym
->attr
.pure
= ifc
->attr
.pure
;
238 sym
->attr
.elemental
= ifc
->attr
.elemental
;
239 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
240 sym
->attr
.recursive
= ifc
->attr
.recursive
;
241 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
242 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
243 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
244 /* Copy char length. */
245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
247 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
248 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
249 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
268 resolve_formal_arglist (gfc_symbol
*proc
)
270 gfc_formal_arglist
*f
;
272 bool saved_specification_expr
;
275 if (proc
->result
!= NULL
)
280 if (gfc_elemental (proc
)
281 || sym
->attr
.pointer
|| sym
->attr
.allocatable
282 || (sym
->as
&& sym
->as
->rank
!= 0))
284 proc
->attr
.always_explicit
= 1;
285 sym
->attr
.always_explicit
= 1;
290 for (f
= proc
->formal
; f
; f
= f
->next
)
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc
))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc
->name
,
303 if (proc
->attr
.function
)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc
->name
,
309 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
310 && !resolve_procedure_interface (sym
))
313 if (strcmp (proc
->name
, sym
->name
) == 0)
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym
->name
,
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 saved_specification_expr
= specification_expr
;
340 specification_expr
= true;
341 gfc_resolve_array_spec (as
, 0);
342 specification_expr
= saved_specification_expr
;
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
347 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
348 && ((sym
->ts
.type
!= BT_CLASS
349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
350 || (sym
->ts
.type
== BT_CLASS
351 && !(CLASS_DATA (sym
)->attr
.class_pointer
352 || CLASS_DATA (sym
)->attr
.allocatable
)))
353 && sym
->attr
.flavor
!= FL_PROCEDURE
)
355 as
->type
= AS_ASSUMED_SHAPE
;
356 for (i
= 0; i
< as
->rank
; i
++)
357 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
360 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
361 || (as
&& as
->type
== AS_ASSUMED_RANK
)
362 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
364 && (CLASS_DATA (sym
)->attr
.class_pointer
365 || CLASS_DATA (sym
)->attr
.allocatable
366 || CLASS_DATA (sym
)->attr
.target
))
367 || sym
->attr
.optional
)
369 proc
->attr
.always_explicit
= 1;
371 proc
->result
->attr
.always_explicit
= 1;
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
377 if (sym
->attr
.flavor
== FL_UNKNOWN
)
378 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
382 if (sym
->attr
.flavor
== FL_PROCEDURE
)
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym
->name
, &sym
->declared_at
);
392 else if (!sym
->attr
.pointer
)
394 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
397 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym
->name
, proc
->name
, &sym
->declared_at
);
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
407 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
410 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym
->name
,
413 proc
->name
, &sym
->declared_at
);
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym
->name
, proc
->name
,
423 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym
->name
, proc
->name
,
432 if (proc
->attr
.implicit_pure
)
434 if (sym
->attr
.flavor
== FL_PROCEDURE
)
437 proc
->attr
.implicit_pure
= 0;
439 else if (!sym
->attr
.pointer
)
441 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
443 proc
->attr
.implicit_pure
= 0;
445 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
447 proc
->attr
.implicit_pure
= 0;
451 if (gfc_elemental (proc
))
454 if (sym
->attr
.codimension
455 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->attr
.codimension
))
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym
->name
, &sym
->declared_at
);
463 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
464 && CLASS_DATA (sym
)->as
))
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym
->name
, &sym
->declared_at
);
471 if (sym
->attr
.allocatable
472 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
473 && CLASS_DATA (sym
)->attr
.allocatable
))
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym
->name
,
481 if (sym
->attr
.pointer
482 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
483 && CLASS_DATA (sym
)->attr
.class_pointer
))
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym
->name
,
491 if (sym
->attr
.flavor
== FL_PROCEDURE
)
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym
->name
, proc
->name
,
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym
->name
, proc
->name
,
510 /* Each dummy shall be specified to be scalar. */
511 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
515 gfc_error ("Argument %qs of statement function at %L must "
516 "be scalar", sym
->name
, &sym
->declared_at
);
520 if (sym
->ts
.type
== BT_CHARACTER
)
522 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
523 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
525 gfc_error ("Character-valued argument %qs of statement "
526 "function at %L must have constant length",
527 sym
->name
, &sym
->declared_at
);
537 /* Work function called when searching for symbols that have argument lists
538 associated with them. */
541 find_arglists (gfc_symbol
*sym
)
543 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
544 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
547 resolve_formal_arglist (sym
);
551 /* Given a namespace, resolve all formal argument lists within the namespace.
555 resolve_formal_arglists (gfc_namespace
*ns
)
560 gfc_traverse_ns (ns
, find_arglists
);
565 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
569 /* If this namespace is not a function or an entry master function,
571 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
572 || sym
->attr
.entry_master
)
575 /* Try to find out of what the return type is. */
576 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
578 t
= gfc_set_default_type (sym
->result
, 0, ns
);
580 if (!t
&& !sym
->result
->attr
.untyped
)
582 if (sym
->result
== sym
)
583 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
584 sym
->name
, &sym
->declared_at
);
585 else if (!sym
->result
->attr
.proc_pointer
)
586 gfc_error ("Result %qs of contained function %qs at %L has "
587 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
588 &sym
->result
->declared_at
);
589 sym
->result
->attr
.untyped
= 1;
593 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
594 type, lists the only ways a character length value of * can be used:
595 dummy arguments of procedures, named constants, and function results
596 in external functions. Internal function results and results of module
597 procedures are not on this list, ergo, not permitted. */
599 if (sym
->result
->ts
.type
== BT_CHARACTER
)
601 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
602 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
604 /* See if this is a module-procedure and adapt error message
607 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
608 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
610 gfc_error ("Character-valued %s %qs at %L must not be"
612 module_proc
? _("module procedure")
613 : _("internal function"),
614 sym
->name
, &sym
->declared_at
);
620 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
621 introduce duplicates. */
624 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
626 gfc_formal_arglist
*f
, *new_arglist
;
629 for (; new_args
!= NULL
; new_args
= new_args
->next
)
631 new_sym
= new_args
->sym
;
632 /* See if this arg is already in the formal argument list. */
633 for (f
= proc
->formal
; f
; f
= f
->next
)
635 if (new_sym
== f
->sym
)
642 /* Add a new argument. Argument order is not important. */
643 new_arglist
= gfc_get_formal_arglist ();
644 new_arglist
->sym
= new_sym
;
645 new_arglist
->next
= proc
->formal
;
646 proc
->formal
= new_arglist
;
651 /* Flag the arguments that are not present in all entries. */
654 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
656 gfc_formal_arglist
*f
, *head
;
659 for (f
= proc
->formal
; f
; f
= f
->next
)
664 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
666 if (new_args
->sym
== f
->sym
)
673 f
->sym
->attr
.not_always_present
= 1;
678 /* Resolve alternate entry points. If a symbol has multiple entry points we
679 create a new master symbol for the main routine, and turn the existing
680 symbol into an entry point. */
683 resolve_entries (gfc_namespace
*ns
)
685 gfc_namespace
*old_ns
;
689 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
690 static int master_count
= 0;
692 if (ns
->proc_name
== NULL
)
695 /* No need to do anything if this procedure doesn't have alternate entry
700 /* We may already have resolved alternate entry points. */
701 if (ns
->proc_name
->attr
.entry_master
)
704 /* If this isn't a procedure something has gone horribly wrong. */
705 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
707 /* Remember the current namespace. */
708 old_ns
= gfc_current_ns
;
712 /* Add the main entry point to the list of entry points. */
713 el
= gfc_get_entry_list ();
714 el
->sym
= ns
->proc_name
;
716 el
->next
= ns
->entries
;
718 ns
->proc_name
->attr
.entry
= 1;
720 /* If it is a module function, it needs to be in the right namespace
721 so that gfc_get_fake_result_decl can gather up the results. The
722 need for this arose in get_proc_name, where these beasts were
723 left in their own namespace, to keep prior references linked to
724 the entry declaration.*/
725 if (ns
->proc_name
->attr
.function
726 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
729 /* Do the same for entries where the master is not a module
730 procedure. These are retained in the module namespace because
731 of the module procedure declaration. */
732 for (el
= el
->next
; el
; el
= el
->next
)
733 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
734 && el
->sym
->attr
.mod_proc
)
738 /* Add an entry statement for it. */
739 c
= gfc_get_code (EXEC_ENTRY
);
744 /* Create a new symbol for the master function. */
745 /* Give the internal function a unique name (within this file).
746 Also include the function name so the user has some hope of figuring
747 out what is going on. */
748 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
749 master_count
++, ns
->proc_name
->name
);
750 gfc_get_ha_symbol (name
, &proc
);
751 gcc_assert (proc
!= NULL
);
753 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
754 if (ns
->proc_name
->attr
.subroutine
)
755 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
759 gfc_typespec
*ts
, *fts
;
760 gfc_array_spec
*as
, *fas
;
761 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
763 fas
= ns
->entries
->sym
->as
;
764 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
765 fts
= &ns
->entries
->sym
->result
->ts
;
766 if (fts
->type
== BT_UNKNOWN
)
767 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
768 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
770 ts
= &el
->sym
->result
->ts
;
772 as
= as
? as
: el
->sym
->result
->as
;
773 if (ts
->type
== BT_UNKNOWN
)
774 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
776 if (! gfc_compare_types (ts
, fts
)
777 || (el
->sym
->result
->attr
.dimension
778 != ns
->entries
->sym
->result
->attr
.dimension
)
779 || (el
->sym
->result
->attr
.pointer
780 != ns
->entries
->sym
->result
->attr
.pointer
))
782 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
783 && gfc_compare_array_spec (as
, fas
) == 0)
784 gfc_error ("Function %s at %L has entries with mismatched "
785 "array specifications", ns
->entries
->sym
->name
,
786 &ns
->entries
->sym
->declared_at
);
787 /* The characteristics need to match and thus both need to have
788 the same string length, i.e. both len=*, or both len=4.
789 Having both len=<variable> is also possible, but difficult to
790 check at compile time. */
791 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
792 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
793 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
795 && ts
->u
.cl
->length
->expr_type
796 != fts
->u
.cl
->length
->expr_type
)
798 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
799 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
800 fts
->u
.cl
->length
->value
.integer
) != 0)))
801 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
802 "entries returning variables of different "
803 "string lengths", ns
->entries
->sym
->name
,
804 &ns
->entries
->sym
->declared_at
);
809 sym
= ns
->entries
->sym
->result
;
810 /* All result types the same. */
812 if (sym
->attr
.dimension
)
813 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
814 if (sym
->attr
.pointer
)
815 gfc_add_pointer (&proc
->attr
, NULL
);
819 /* Otherwise the result will be passed through a union by
821 proc
->attr
.mixed_entry_master
= 1;
822 for (el
= ns
->entries
; el
; el
= el
->next
)
824 sym
= el
->sym
->result
;
825 if (sym
->attr
.dimension
)
827 if (el
== ns
->entries
)
828 gfc_error ("FUNCTION result %s can't be an array in "
829 "FUNCTION %s at %L", sym
->name
,
830 ns
->entries
->sym
->name
, &sym
->declared_at
);
832 gfc_error ("ENTRY result %s can't be an array in "
833 "FUNCTION %s at %L", sym
->name
,
834 ns
->entries
->sym
->name
, &sym
->declared_at
);
836 else if (sym
->attr
.pointer
)
838 if (el
== ns
->entries
)
839 gfc_error ("FUNCTION result %s can't be a POINTER in "
840 "FUNCTION %s at %L", sym
->name
,
841 ns
->entries
->sym
->name
, &sym
->declared_at
);
843 gfc_error ("ENTRY result %s can't be a POINTER in "
844 "FUNCTION %s at %L", sym
->name
,
845 ns
->entries
->sym
->name
, &sym
->declared_at
);
850 if (ts
->type
== BT_UNKNOWN
)
851 ts
= gfc_get_default_type (sym
->name
, NULL
);
855 if (ts
->kind
== gfc_default_integer_kind
)
859 if (ts
->kind
== gfc_default_real_kind
860 || ts
->kind
== gfc_default_double_kind
)
864 if (ts
->kind
== gfc_default_complex_kind
)
868 if (ts
->kind
== gfc_default_logical_kind
)
872 /* We will issue error elsewhere. */
880 if (el
== ns
->entries
)
881 gfc_error ("FUNCTION result %s can't be of type %s "
882 "in FUNCTION %s at %L", sym
->name
,
883 gfc_typename (ts
), ns
->entries
->sym
->name
,
886 gfc_error ("ENTRY result %s can't be of type %s "
887 "in FUNCTION %s at %L", sym
->name
,
888 gfc_typename (ts
), ns
->entries
->sym
->name
,
895 proc
->attr
.access
= ACCESS_PRIVATE
;
896 proc
->attr
.entry_master
= 1;
898 /* Merge all the entry point arguments. */
899 for (el
= ns
->entries
; el
; el
= el
->next
)
900 merge_argument_lists (proc
, el
->sym
->formal
);
902 /* Check the master formal arguments for any that are not
903 present in all entry points. */
904 for (el
= ns
->entries
; el
; el
= el
->next
)
905 check_argument_lists (proc
, el
->sym
->formal
);
907 /* Use the master function for the function body. */
908 ns
->proc_name
= proc
;
910 /* Finalize the new symbols. */
911 gfc_commit_symbols ();
913 /* Restore the original namespace. */
914 gfc_current_ns
= old_ns
;
918 /* Resolve common variables. */
920 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
922 gfc_symbol
*csym
= common_block
->head
;
924 for (; csym
; csym
= csym
->common_next
)
926 /* gfc_add_in_common may have been called before, but the reported errors
927 have been ignored to continue parsing.
928 We do the checks again here. */
929 if (!csym
->attr
.use_assoc
)
930 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
932 if (csym
->value
|| csym
->attr
.data
)
934 if (!csym
->ns
->is_block_data
)
935 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
936 "but only in BLOCK DATA initialization is "
937 "allowed", csym
->name
, &csym
->declared_at
);
938 else if (!named_common
)
939 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
940 "in a blank COMMON but initialization is only "
941 "allowed in named common blocks", csym
->name
,
945 if (UNLIMITED_POLY (csym
))
946 gfc_error_now ("%qs in cannot appear in COMMON at %L "
947 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
949 if (csym
->ts
.type
!= BT_DERIVED
)
952 if (!(csym
->ts
.u
.derived
->attr
.sequence
953 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
954 gfc_error_now ("Derived type variable %qs in COMMON at %L "
955 "has neither the SEQUENCE nor the BIND(C) "
956 "attribute", csym
->name
, &csym
->declared_at
);
957 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
958 gfc_error_now ("Derived type variable %qs in COMMON at %L "
959 "has an ultimate component that is "
960 "allocatable", csym
->name
, &csym
->declared_at
);
961 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
962 gfc_error_now ("Derived type variable %qs in COMMON at %L "
963 "may not have default initializer", csym
->name
,
966 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
967 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
971 /* Resolve common blocks. */
973 resolve_common_blocks (gfc_symtree
*common_root
)
978 if (common_root
== NULL
)
981 if (common_root
->left
)
982 resolve_common_blocks (common_root
->left
);
983 if (common_root
->right
)
984 resolve_common_blocks (common_root
->right
);
986 resolve_common_vars (common_root
->n
.common
, true);
988 /* The common name is a global name - in Fortran 2003 also if it has a
989 C binding name, since Fortran 2008 only the C binding name is a global
991 if (!common_root
->n
.common
->binding_label
992 || gfc_notification_std (GFC_STD_F2008
))
994 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
995 common_root
->n
.common
->name
);
997 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
998 && gsym
->type
== GSYM_COMMON
999 && ((common_root
->n
.common
->binding_label
1000 && (!gsym
->binding_label
1001 || strcmp (common_root
->n
.common
->binding_label
,
1002 gsym
->binding_label
) != 0))
1003 || (!common_root
->n
.common
->binding_label
1004 && gsym
->binding_label
)))
1006 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1007 "identifier and must thus have the same binding name "
1008 "as the same-named COMMON block at %L: %s vs %s",
1009 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1011 common_root
->n
.common
->binding_label
1012 ? common_root
->n
.common
->binding_label
: "(blank)",
1013 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1017 if (gsym
&& gsym
->type
!= GSYM_COMMON
1018 && !common_root
->n
.common
->binding_label
)
1020 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1022 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1026 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1028 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1029 "%L sharing the identifier with global non-COMMON-block "
1030 "entity at %L", common_root
->n
.common
->name
,
1031 &common_root
->n
.common
->where
, &gsym
->where
);
1036 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1037 gsym
->type
= GSYM_COMMON
;
1038 gsym
->where
= common_root
->n
.common
->where
;
1044 if (common_root
->n
.common
->binding_label
)
1046 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1047 common_root
->n
.common
->binding_label
);
1048 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1050 gfc_error ("COMMON block at %L with binding label %s uses the same "
1051 "global identifier as entity at %L",
1052 &common_root
->n
.common
->where
,
1053 common_root
->n
.common
->binding_label
, &gsym
->where
);
1058 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1059 gsym
->type
= GSYM_COMMON
;
1060 gsym
->where
= common_root
->n
.common
->where
;
1066 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1070 if (sym
->attr
.flavor
== FL_PARAMETER
)
1071 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1072 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1074 if (sym
->attr
.external
)
1075 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1076 sym
->name
, &common_root
->n
.common
->where
);
1078 if (sym
->attr
.intrinsic
)
1079 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1080 sym
->name
, &common_root
->n
.common
->where
);
1081 else if (sym
->attr
.result
1082 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1083 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1084 "that is also a function result", sym
->name
,
1085 &common_root
->n
.common
->where
);
1086 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1087 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1088 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1089 "that is also a global procedure", sym
->name
,
1090 &common_root
->n
.common
->where
);
1094 /* Resolve contained function types. Because contained functions can call one
1095 another, they have to be worked out before any of the contained procedures
1098 The good news is that if a function doesn't already have a type, the only
1099 way it can get one is through an IMPLICIT type or a RESULT variable, because
1100 by definition contained functions are contained namespace they're contained
1101 in, not in a sibling or parent namespace. */
1104 resolve_contained_functions (gfc_namespace
*ns
)
1106 gfc_namespace
*child
;
1109 resolve_formal_arglists (ns
);
1111 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1113 /* Resolve alternate entry points first. */
1114 resolve_entries (child
);
1116 /* Then check function return types. */
1117 resolve_contained_fntype (child
->proc_name
, child
);
1118 for (el
= child
->entries
; el
; el
= el
->next
)
1119 resolve_contained_fntype (el
->sym
, child
);
1124 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1125 static bool resolve_fl_struct (gfc_symbol
*sym
);
1128 /* Resolve all of the elements of a structure constructor and make sure that
1129 the types are correct. The 'init' flag indicates that the given
1130 constructor is an initializer. */
1133 resolve_structure_cons (gfc_expr
*expr
, int init
)
1135 gfc_constructor
*cons
;
1136 gfc_component
*comp
;
1142 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1144 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1145 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1147 resolve_fl_struct (expr
->ts
.u
.derived
);
1150 cons
= gfc_constructor_first (expr
->value
.constructor
);
1152 /* A constructor may have references if it is the result of substituting a
1153 parameter variable. In this case we just pull out the component we
1156 comp
= expr
->ref
->u
.c
.sym
->components
;
1158 comp
= expr
->ts
.u
.derived
->components
;
1160 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1167 /* Unions use an EXPR_NULL contrived expression to tell the translation
1168 phase to generate an initializer of the appropriate length.
1170 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1173 if (!gfc_resolve_expr (cons
->expr
))
1179 rank
= comp
->as
? comp
->as
->rank
: 0;
1180 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1181 rank
= CLASS_DATA (comp
)->as
->rank
;
1183 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1184 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1186 gfc_error ("The rank of the element in the structure "
1187 "constructor at %L does not match that of the "
1188 "component (%d/%d)", &cons
->expr
->where
,
1189 cons
->expr
->rank
, rank
);
1193 /* If we don't have the right type, try to convert it. */
1195 if (!comp
->attr
.proc_pointer
&&
1196 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1198 if (strcmp (comp
->name
, "_extends") == 0)
1200 /* Can afford to be brutal with the _extends initializer.
1201 The derived type can get lost because it is PRIVATE
1202 but it is not usage constrained by the standard. */
1203 cons
->expr
->ts
= comp
->ts
;
1205 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1207 gfc_error ("The element in the structure constructor at %L, "
1208 "for pointer component %qs, is %s but should be %s",
1209 &cons
->expr
->where
, comp
->name
,
1210 gfc_basic_typename (cons
->expr
->ts
.type
),
1211 gfc_basic_typename (comp
->ts
.type
));
1216 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1222 /* For strings, the length of the constructor should be the same as
1223 the one of the structure, ensure this if the lengths are known at
1224 compile time and when we are dealing with PARAMETER or structure
1226 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1227 && comp
->ts
.u
.cl
->length
1228 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1229 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1230 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1231 && cons
->expr
->rank
!= 0
1232 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1233 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1235 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1236 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1238 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1239 to make use of the gfc_resolve_character_array_constructor
1240 machinery. The expression is later simplified away to
1241 an array of string literals. */
1242 gfc_expr
*para
= cons
->expr
;
1243 cons
->expr
= gfc_get_expr ();
1244 cons
->expr
->ts
= para
->ts
;
1245 cons
->expr
->where
= para
->where
;
1246 cons
->expr
->expr_type
= EXPR_ARRAY
;
1247 cons
->expr
->rank
= para
->rank
;
1248 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1249 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1250 para
, &cons
->expr
->where
);
1252 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1255 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1256 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1258 gfc_charlen
*cl
, *cl2
;
1261 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1263 if (cl
== cons
->expr
->ts
.u
.cl
)
1271 cl2
->next
= cl
->next
;
1273 gfc_free_expr (cl
->length
);
1277 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1278 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1279 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1280 gfc_resolve_character_array_constructor (cons
->expr
);
1284 if (cons
->expr
->expr_type
== EXPR_NULL
1285 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1286 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1287 || (comp
->ts
.type
== BT_CLASS
1288 && (CLASS_DATA (comp
)->attr
.class_pointer
1289 || CLASS_DATA (comp
)->attr
.allocatable
))))
1292 gfc_error ("The NULL in the structure constructor at %L is "
1293 "being applied to component %qs, which is neither "
1294 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1298 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1300 /* Check procedure pointer interface. */
1301 gfc_symbol
*s2
= NULL
;
1306 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1309 s2
= c2
->ts
.interface
;
1312 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1314 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1315 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1317 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1319 s2
= cons
->expr
->symtree
->n
.sym
;
1320 name
= cons
->expr
->symtree
->n
.sym
->name
;
1323 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1324 err
, sizeof (err
), NULL
, NULL
))
1326 gfc_error (OPT_Wargument_mismatch
,
1327 "Interface mismatch for procedure-pointer component "
1328 "%qs in structure constructor at %L: %s",
1329 comp
->name
, &cons
->expr
->where
, err
);
1334 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1335 || cons
->expr
->expr_type
== EXPR_NULL
)
1338 a
= gfc_expr_attr (cons
->expr
);
1340 if (!a
.pointer
&& !a
.target
)
1343 gfc_error ("The element in the structure constructor at %L, "
1344 "for pointer component %qs should be a POINTER or "
1345 "a TARGET", &cons
->expr
->where
, comp
->name
);
1350 /* F08:C461. Additional checks for pointer initialization. */
1354 gfc_error ("Pointer initialization target at %L "
1355 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1360 gfc_error ("Pointer initialization target at %L "
1361 "must have the SAVE attribute", &cons
->expr
->where
);
1365 /* F2003, C1272 (3). */
1366 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1367 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1368 || gfc_is_coindexed (cons
->expr
));
1369 if (impure
&& gfc_pure (NULL
))
1372 gfc_error ("Invalid expression in the structure constructor for "
1373 "pointer component %qs at %L in PURE procedure",
1374 comp
->name
, &cons
->expr
->where
);
1378 gfc_unset_implicit_pure (NULL
);
1385 /****************** Expression name resolution ******************/
1387 /* Returns 0 if a symbol was not declared with a type or
1388 attribute declaration statement, nonzero otherwise. */
1391 was_declared (gfc_symbol
*sym
)
1397 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1400 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1401 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1402 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1403 || a
.asynchronous
|| a
.codimension
)
1410 /* Determine if a symbol is generic or not. */
1413 generic_sym (gfc_symbol
*sym
)
1417 if (sym
->attr
.generic
||
1418 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1421 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1424 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1431 return generic_sym (s
);
1438 /* Determine if a symbol is specific or not. */
1441 specific_sym (gfc_symbol
*sym
)
1445 if (sym
->attr
.if_source
== IFSRC_IFBODY
1446 || sym
->attr
.proc
== PROC_MODULE
1447 || sym
->attr
.proc
== PROC_INTERNAL
1448 || sym
->attr
.proc
== PROC_ST_FUNCTION
1449 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1450 || sym
->attr
.external
)
1453 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1456 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1458 return (s
== NULL
) ? 0 : specific_sym (s
);
1462 /* Figure out if the procedure is specific, generic or unknown. */
1465 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1468 procedure_kind (gfc_symbol
*sym
)
1470 if (generic_sym (sym
))
1471 return PTYPE_GENERIC
;
1473 if (specific_sym (sym
))
1474 return PTYPE_SPECIFIC
;
1476 return PTYPE_UNKNOWN
;
1479 /* Check references to assumed size arrays. The flag need_full_assumed_size
1480 is nonzero when matching actual arguments. */
1482 static int need_full_assumed_size
= 0;
1485 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1487 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1490 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1491 What should it be? */
1492 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1493 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1494 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1496 gfc_error ("The upper bound in the last dimension must "
1497 "appear in the reference to the assumed size "
1498 "array %qs at %L", sym
->name
, &e
->where
);
1505 /* Look for bad assumed size array references in argument expressions
1506 of elemental and array valued intrinsic procedures. Since this is
1507 called from procedure resolution functions, it only recurses at
1511 resolve_assumed_size_actual (gfc_expr
*e
)
1516 switch (e
->expr_type
)
1519 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1524 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1525 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1536 /* Check a generic procedure, passed as an actual argument, to see if
1537 there is a matching specific name. If none, it is an error, and if
1538 more than one, the reference is ambiguous. */
1540 count_specific_procs (gfc_expr
*e
)
1547 sym
= e
->symtree
->n
.sym
;
1549 for (p
= sym
->generic
; p
; p
= p
->next
)
1550 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1552 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1558 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1562 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1563 "argument at %L", sym
->name
, &e
->where
);
1569 /* See if a call to sym could possibly be a not allowed RECURSION because of
1570 a missing RECURSIVE declaration. This means that either sym is the current
1571 context itself, or sym is the parent of a contained procedure calling its
1572 non-RECURSIVE containing procedure.
1573 This also works if sym is an ENTRY. */
1576 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1578 gfc_symbol
* proc_sym
;
1579 gfc_symbol
* context_proc
;
1580 gfc_namespace
* real_context
;
1582 if (sym
->attr
.flavor
== FL_PROGRAM
1583 || gfc_fl_struct (sym
->attr
.flavor
))
1586 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1588 /* If we've got an ENTRY, find real procedure. */
1589 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1590 proc_sym
= sym
->ns
->entries
->sym
;
1594 /* If sym is RECURSIVE, all is well of course. */
1595 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1598 /* Find the context procedure's "real" symbol if it has entries.
1599 We look for a procedure symbol, so recurse on the parents if we don't
1600 find one (like in case of a BLOCK construct). */
1601 for (real_context
= context
; ; real_context
= real_context
->parent
)
1603 /* We should find something, eventually! */
1604 gcc_assert (real_context
);
1606 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1607 : real_context
->proc_name
);
1609 /* In some special cases, there may not be a proc_name, like for this
1611 real(bad_kind()) function foo () ...
1612 when checking the call to bad_kind ().
1613 In these cases, we simply return here and assume that the
1618 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1622 /* A call from sym's body to itself is recursion, of course. */
1623 if (context_proc
== proc_sym
)
1626 /* The same is true if context is a contained procedure and sym the
1628 if (context_proc
->attr
.contained
)
1630 gfc_symbol
* parent_proc
;
1632 gcc_assert (context
->parent
);
1633 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1634 : context
->parent
->proc_name
);
1636 if (parent_proc
== proc_sym
)
1644 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1645 its typespec and formal argument list. */
1648 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1650 gfc_intrinsic_sym
* isym
= NULL
;
1656 /* Already resolved. */
1657 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1660 /* We already know this one is an intrinsic, so we don't call
1661 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1662 gfc_find_subroutine directly to check whether it is a function or
1665 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1667 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1668 isym
= gfc_intrinsic_subroutine_by_id (id
);
1670 else if (sym
->intmod_sym_id
)
1672 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1673 isym
= gfc_intrinsic_function_by_id (id
);
1675 else if (!sym
->attr
.subroutine
)
1676 isym
= gfc_find_function (sym
->name
);
1678 if (isym
&& !sym
->attr
.subroutine
)
1680 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1681 && !sym
->attr
.implicit_type
)
1682 gfc_warning (OPT_Wsurprising
,
1683 "Type specified for intrinsic function %qs at %L is"
1684 " ignored", sym
->name
, &sym
->declared_at
);
1686 if (!sym
->attr
.function
&&
1687 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1692 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1694 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1696 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1697 " specifier", sym
->name
, &sym
->declared_at
);
1701 if (!sym
->attr
.subroutine
&&
1702 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1707 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1712 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1714 sym
->attr
.pure
= isym
->pure
;
1715 sym
->attr
.elemental
= isym
->elemental
;
1717 /* Check it is actually available in the standard settings. */
1718 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1720 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1721 "available in the current standard settings but %s. Use "
1722 "an appropriate %<-std=*%> option or enable "
1723 "%<-fall-intrinsics%> in order to use it.",
1724 sym
->name
, &sym
->declared_at
, symstd
);
1732 /* Resolve a procedure expression, like passing it to a called procedure or as
1733 RHS for a procedure pointer assignment. */
1736 resolve_procedure_expression (gfc_expr
* expr
)
1740 if (expr
->expr_type
!= EXPR_VARIABLE
)
1742 gcc_assert (expr
->symtree
);
1744 sym
= expr
->symtree
->n
.sym
;
1746 if (sym
->attr
.intrinsic
)
1747 gfc_resolve_intrinsic (sym
, &expr
->where
);
1749 if (sym
->attr
.flavor
!= FL_PROCEDURE
1750 || (sym
->attr
.function
&& sym
->result
== sym
))
1753 /* A non-RECURSIVE procedure that is used as procedure expression within its
1754 own body is in danger of being called recursively. */
1755 if (is_illegal_recursion (sym
, gfc_current_ns
))
1756 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1757 " itself recursively. Declare it RECURSIVE or use"
1758 " %<-frecursive%>", sym
->name
, &expr
->where
);
1764 /* Resolve an actual argument list. Most of the time, this is just
1765 resolving the expressions in the list.
1766 The exception is that we sometimes have to decide whether arguments
1767 that look like procedure arguments are really simple variable
1771 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1772 bool no_formal_args
)
1775 gfc_symtree
*parent_st
;
1777 gfc_component
*comp
;
1778 int save_need_full_assumed_size
;
1779 bool return_value
= false;
1780 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1783 first_actual_arg
= true;
1785 for (; arg
; arg
= arg
->next
)
1790 /* Check the label is a valid branching target. */
1793 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1795 gfc_error ("Label %d referenced at %L is never defined",
1796 arg
->label
->value
, &arg
->label
->where
);
1800 first_actual_arg
= false;
1804 if (e
->expr_type
== EXPR_VARIABLE
1805 && e
->symtree
->n
.sym
->attr
.generic
1807 && count_specific_procs (e
) != 1)
1810 if (e
->ts
.type
!= BT_PROCEDURE
)
1812 save_need_full_assumed_size
= need_full_assumed_size
;
1813 if (e
->expr_type
!= EXPR_VARIABLE
)
1814 need_full_assumed_size
= 0;
1815 if (!gfc_resolve_expr (e
))
1817 need_full_assumed_size
= save_need_full_assumed_size
;
1821 /* See if the expression node should really be a variable reference. */
1823 sym
= e
->symtree
->n
.sym
;
1825 if (sym
->attr
.flavor
== FL_PROCEDURE
1826 || sym
->attr
.intrinsic
1827 || sym
->attr
.external
)
1831 /* If a procedure is not already determined to be something else
1832 check if it is intrinsic. */
1833 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1834 sym
->attr
.intrinsic
= 1;
1836 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1838 gfc_error ("Statement function %qs at %L is not allowed as an "
1839 "actual argument", sym
->name
, &e
->where
);
1842 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1843 sym
->attr
.subroutine
);
1844 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1846 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1847 "actual argument", sym
->name
, &e
->where
);
1850 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1851 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1853 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1854 " used as actual argument at %L",
1855 sym
->name
, &e
->where
))
1859 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1861 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1862 "allowed as an actual argument at %L", sym
->name
,
1866 /* Check if a generic interface has a specific procedure
1867 with the same name before emitting an error. */
1868 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1871 /* Just in case a specific was found for the expression. */
1872 sym
= e
->symtree
->n
.sym
;
1874 /* If the symbol is the function that names the current (or
1875 parent) scope, then we really have a variable reference. */
1877 if (gfc_is_function_return_value (sym
, sym
->ns
))
1880 /* If all else fails, see if we have a specific intrinsic. */
1881 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1883 gfc_intrinsic_sym
*isym
;
1885 isym
= gfc_find_function (sym
->name
);
1886 if (isym
== NULL
|| !isym
->specific
)
1888 gfc_error ("Unable to find a specific INTRINSIC procedure "
1889 "for the reference %qs at %L", sym
->name
,
1894 sym
->attr
.intrinsic
= 1;
1895 sym
->attr
.function
= 1;
1898 if (!gfc_resolve_expr (e
))
1903 /* See if the name is a module procedure in a parent unit. */
1905 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1908 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1910 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1914 if (parent_st
== NULL
)
1917 sym
= parent_st
->n
.sym
;
1918 e
->symtree
= parent_st
; /* Point to the right thing. */
1920 if (sym
->attr
.flavor
== FL_PROCEDURE
1921 || sym
->attr
.intrinsic
1922 || sym
->attr
.external
)
1924 if (!gfc_resolve_expr (e
))
1930 e
->expr_type
= EXPR_VARIABLE
;
1932 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1933 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1934 && CLASS_DATA (sym
)->as
))
1936 e
->rank
= sym
->ts
.type
== BT_CLASS
1937 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1938 e
->ref
= gfc_get_ref ();
1939 e
->ref
->type
= REF_ARRAY
;
1940 e
->ref
->u
.ar
.type
= AR_FULL
;
1941 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1942 ? CLASS_DATA (sym
)->as
: sym
->as
;
1945 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1946 primary.c (match_actual_arg). If above code determines that it
1947 is a variable instead, it needs to be resolved as it was not
1948 done at the beginning of this function. */
1949 save_need_full_assumed_size
= need_full_assumed_size
;
1950 if (e
->expr_type
!= EXPR_VARIABLE
)
1951 need_full_assumed_size
= 0;
1952 if (!gfc_resolve_expr (e
))
1954 need_full_assumed_size
= save_need_full_assumed_size
;
1957 /* Check argument list functions %VAL, %LOC and %REF. There is
1958 nothing to do for %REF. */
1959 if (arg
->name
&& arg
->name
[0] == '%')
1961 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1963 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1965 gfc_error ("By-value argument at %L is not of numeric "
1972 gfc_error ("By-value argument at %L cannot be an array or "
1973 "an array section", &e
->where
);
1977 /* Intrinsics are still PROC_UNKNOWN here. However,
1978 since same file external procedures are not resolvable
1979 in gfortran, it is a good deal easier to leave them to
1981 if (ptype
!= PROC_UNKNOWN
1982 && ptype
!= PROC_DUMMY
1983 && ptype
!= PROC_EXTERNAL
1984 && ptype
!= PROC_MODULE
)
1986 gfc_error ("By-value argument at %L is not allowed "
1987 "in this context", &e
->where
);
1992 /* Statement functions have already been excluded above. */
1993 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1994 && e
->ts
.type
== BT_PROCEDURE
)
1996 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1998 gfc_error ("Passing internal procedure at %L by location "
1999 "not allowed", &e
->where
);
2005 comp
= gfc_get_proc_ptr_comp(e
);
2006 if (e
->expr_type
== EXPR_VARIABLE
2007 && comp
&& comp
->attr
.elemental
)
2009 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2010 "allowed as an actual argument at %L", comp
->name
,
2014 /* Fortran 2008, C1237. */
2015 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2016 && gfc_has_ultimate_pointer (e
))
2018 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2019 "component", &e
->where
);
2023 first_actual_arg
= false;
2026 return_value
= true;
2029 actual_arg
= actual_arg_sav
;
2030 first_actual_arg
= first_actual_arg_sav
;
2032 return return_value
;
2036 /* Do the checks of the actual argument list that are specific to elemental
2037 procedures. If called with c == NULL, we have a function, otherwise if
2038 expr == NULL, we have a subroutine. */
2041 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2043 gfc_actual_arglist
*arg0
;
2044 gfc_actual_arglist
*arg
;
2045 gfc_symbol
*esym
= NULL
;
2046 gfc_intrinsic_sym
*isym
= NULL
;
2048 gfc_intrinsic_arg
*iformal
= NULL
;
2049 gfc_formal_arglist
*eformal
= NULL
;
2050 bool formal_optional
= false;
2051 bool set_by_optional
= false;
2055 /* Is this an elemental procedure? */
2056 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2058 if (expr
->value
.function
.esym
!= NULL
2059 && expr
->value
.function
.esym
->attr
.elemental
)
2061 arg0
= expr
->value
.function
.actual
;
2062 esym
= expr
->value
.function
.esym
;
2064 else if (expr
->value
.function
.isym
!= NULL
2065 && expr
->value
.function
.isym
->elemental
)
2067 arg0
= expr
->value
.function
.actual
;
2068 isym
= expr
->value
.function
.isym
;
2073 else if (c
&& c
->ext
.actual
!= NULL
)
2075 arg0
= c
->ext
.actual
;
2077 if (c
->resolved_sym
)
2078 esym
= c
->resolved_sym
;
2080 esym
= c
->symtree
->n
.sym
;
2083 if (!esym
->attr
.elemental
)
2089 /* The rank of an elemental is the rank of its array argument(s). */
2090 for (arg
= arg0
; arg
; arg
= arg
->next
)
2092 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2094 rank
= arg
->expr
->rank
;
2095 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2096 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2097 set_by_optional
= true;
2099 /* Function specific; set the result rank and shape. */
2103 if (!expr
->shape
&& arg
->expr
->shape
)
2105 expr
->shape
= gfc_get_shape (rank
);
2106 for (i
= 0; i
< rank
; i
++)
2107 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2114 /* If it is an array, it shall not be supplied as an actual argument
2115 to an elemental procedure unless an array of the same rank is supplied
2116 as an actual argument corresponding to a nonoptional dummy argument of
2117 that elemental procedure(12.4.1.5). */
2118 formal_optional
= false;
2120 iformal
= isym
->formal
;
2122 eformal
= esym
->formal
;
2124 for (arg
= arg0
; arg
; arg
= arg
->next
)
2128 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2129 formal_optional
= true;
2130 eformal
= eformal
->next
;
2132 else if (isym
&& iformal
)
2134 if (iformal
->optional
)
2135 formal_optional
= true;
2136 iformal
= iformal
->next
;
2139 formal_optional
= true;
2141 if (pedantic
&& arg
->expr
!= NULL
2142 && arg
->expr
->expr_type
== EXPR_VARIABLE
2143 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2146 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2147 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2149 gfc_warning (OPT_Wpedantic
,
2150 "%qs at %L is an array and OPTIONAL; IF IT IS "
2151 "MISSING, it cannot be the actual argument of an "
2152 "ELEMENTAL procedure unless there is a non-optional "
2153 "argument with the same rank (12.4.1.5)",
2154 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2158 for (arg
= arg0
; arg
; arg
= arg
->next
)
2160 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2163 /* Being elemental, the last upper bound of an assumed size array
2164 argument must be present. */
2165 if (resolve_assumed_size_actual (arg
->expr
))
2168 /* Elemental procedure's array actual arguments must conform. */
2171 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2178 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2179 is an array, the intent inout/out variable needs to be also an array. */
2180 if (rank
> 0 && esym
&& expr
== NULL
)
2181 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2182 arg
= arg
->next
, eformal
= eformal
->next
)
2183 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2184 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2185 && arg
->expr
&& arg
->expr
->rank
== 0)
2187 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2188 "ELEMENTAL subroutine %qs is a scalar, but another "
2189 "actual argument is an array", &arg
->expr
->where
,
2190 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2191 : "INOUT", eformal
->sym
->name
, esym
->name
);
2198 /* This function does the checking of references to global procedures
2199 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2200 77 and 95 standards. It checks for a gsymbol for the name, making
2201 one if it does not already exist. If it already exists, then the
2202 reference being resolved must correspond to the type of gsymbol.
2203 Otherwise, the new symbol is equipped with the attributes of the
2204 reference. The corresponding code that is called in creating
2205 global entities is parse.c.
2207 In addition, for all but -std=legacy, the gsymbols are used to
2208 check the interfaces of external procedures from the same file.
2209 The namespace of the gsymbol is resolved and then, once this is
2210 done the interface is checked. */
2214 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2216 if (!gsym_ns
->proc_name
->attr
.recursive
)
2219 if (sym
->ns
== gsym_ns
)
2222 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2229 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2231 if (gsym_ns
->entries
)
2233 gfc_entry_list
*entry
= gsym_ns
->entries
;
2235 for (; entry
; entry
= entry
->next
)
2237 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2239 if (strcmp (gsym_ns
->proc_name
->name
,
2240 sym
->ns
->proc_name
->name
) == 0)
2244 && strcmp (gsym_ns
->proc_name
->name
,
2245 sym
->ns
->parent
->proc_name
->name
) == 0)
2254 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2257 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2259 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2261 for ( ; arg
; arg
= arg
->next
)
2266 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2268 strncpy (errmsg
, _("allocatable argument"), err_len
);
2271 else if (arg
->sym
->attr
.asynchronous
)
2273 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2276 else if (arg
->sym
->attr
.optional
)
2278 strncpy (errmsg
, _("optional argument"), err_len
);
2281 else if (arg
->sym
->attr
.pointer
)
2283 strncpy (errmsg
, _("pointer argument"), err_len
);
2286 else if (arg
->sym
->attr
.target
)
2288 strncpy (errmsg
, _("target argument"), err_len
);
2291 else if (arg
->sym
->attr
.value
)
2293 strncpy (errmsg
, _("value argument"), err_len
);
2296 else if (arg
->sym
->attr
.volatile_
)
2298 strncpy (errmsg
, _("volatile argument"), err_len
);
2301 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2303 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2306 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2308 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2311 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2313 strncpy (errmsg
, _("coarray argument"), err_len
);
2316 else if (false) /* (2d) TODO: parametrized derived type */
2318 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2321 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2323 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2326 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2328 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2331 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2333 /* As assumed-type is unlimited polymorphic (cf. above).
2334 See also TS 29113, Note 6.1. */
2335 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2340 if (sym
->attr
.function
)
2342 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2344 if (res
->attr
.dimension
) /* (3a) */
2346 strncpy (errmsg
, _("array result"), err_len
);
2349 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2351 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2354 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2355 && res
->ts
.u
.cl
->length
2356 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2358 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2363 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2365 strncpy (errmsg
, _("elemental procedure"), err_len
);
2368 else if (sym
->attr
.is_bind_c
) /* (5) */
2370 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2379 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2380 gfc_actual_arglist
**actual
, int sub
)
2384 enum gfc_symbol_type type
;
2387 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2389 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2391 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2392 gfc_global_used (gsym
, where
);
2394 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2395 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2396 && gsym
->type
!= GSYM_UNKNOWN
2397 && !gsym
->binding_label
2399 && gsym
->ns
->resolved
!= -1
2400 && gsym
->ns
->proc_name
2401 && not_in_recursive (sym
, gsym
->ns
)
2402 && not_entry_self_reference (sym
, gsym
->ns
))
2404 gfc_symbol
*def_sym
;
2406 /* Resolve the gsymbol namespace if needed. */
2407 if (!gsym
->ns
->resolved
)
2409 gfc_dt_list
*old_dt_list
;
2411 /* Stash away derived types so that the backend_decls do not
2413 old_dt_list
= gfc_derived_types
;
2414 gfc_derived_types
= NULL
;
2416 gfc_resolve (gsym
->ns
);
2418 /* Store the new derived types with the global namespace. */
2419 if (gfc_derived_types
)
2420 gsym
->ns
->derived_types
= gfc_derived_types
;
2422 /* Restore the derived types of this namespace. */
2423 gfc_derived_types
= old_dt_list
;
2426 /* Make sure that translation for the gsymbol occurs before
2427 the procedure currently being resolved. */
2428 ns
= gfc_global_ns_list
;
2429 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2431 if (ns
->sibling
== gsym
->ns
)
2433 ns
->sibling
= gsym
->ns
->sibling
;
2434 gsym
->ns
->sibling
= gfc_global_ns_list
;
2435 gfc_global_ns_list
= gsym
->ns
;
2440 def_sym
= gsym
->ns
->proc_name
;
2442 /* This can happen if a binding name has been specified. */
2443 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2444 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2446 if (def_sym
->attr
.entry_master
)
2448 gfc_entry_list
*entry
;
2449 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2450 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2452 def_sym
= entry
->sym
;
2457 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2459 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2460 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2461 gfc_typename (&def_sym
->ts
));
2465 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2466 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2468 gfc_error ("Explicit interface required for %qs at %L: %s",
2469 sym
->name
, &sym
->declared_at
, reason
);
2473 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2474 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2475 gfc_errors_to_warnings (true);
2477 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2478 reason
, sizeof(reason
), NULL
, NULL
))
2480 gfc_error (OPT_Wargument_mismatch
,
2481 "Interface mismatch in global procedure %qs at %L: %s ",
2482 sym
->name
, &sym
->declared_at
, reason
);
2487 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2488 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2489 gfc_errors_to_warnings (true);
2491 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2492 gfc_procedure_use (def_sym
, actual
, where
);
2496 gfc_errors_to_warnings (false);
2498 if (gsym
->type
== GSYM_UNKNOWN
)
2501 gsym
->where
= *where
;
2508 /************* Function resolution *************/
2510 /* Resolve a function call known to be generic.
2511 Section 14.1.2.4.1. */
2514 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2518 if (sym
->attr
.generic
)
2520 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2523 expr
->value
.function
.name
= s
->name
;
2524 expr
->value
.function
.esym
= s
;
2526 if (s
->ts
.type
!= BT_UNKNOWN
)
2528 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2529 expr
->ts
= s
->result
->ts
;
2532 expr
->rank
= s
->as
->rank
;
2533 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2534 expr
->rank
= s
->result
->as
->rank
;
2536 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2541 /* TODO: Need to search for elemental references in generic
2545 if (sym
->attr
.intrinsic
)
2546 return gfc_intrinsic_func_interface (expr
, 0);
2553 resolve_generic_f (gfc_expr
*expr
)
2557 gfc_interface
*intr
= NULL
;
2559 sym
= expr
->symtree
->n
.sym
;
2563 m
= resolve_generic_f0 (expr
, sym
);
2566 else if (m
== MATCH_ERROR
)
2571 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2572 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2575 if (sym
->ns
->parent
== NULL
)
2577 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2581 if (!generic_sym (sym
))
2585 /* Last ditch attempt. See if the reference is to an intrinsic
2586 that possesses a matching interface. 14.1.2.4 */
2587 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2589 if (gfc_init_expr_flag
)
2590 gfc_error ("Function %qs in initialization expression at %L "
2591 "must be an intrinsic function",
2592 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2594 gfc_error ("There is no specific function for the generic %qs "
2595 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2601 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2604 return resolve_structure_cons (expr
, 0);
2607 m
= gfc_intrinsic_func_interface (expr
, 0);
2612 gfc_error ("Generic function %qs at %L is not consistent with a "
2613 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2620 /* Resolve a function call known to be specific. */
2623 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2627 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2629 if (sym
->attr
.dummy
)
2631 sym
->attr
.proc
= PROC_DUMMY
;
2635 sym
->attr
.proc
= PROC_EXTERNAL
;
2639 if (sym
->attr
.proc
== PROC_MODULE
2640 || sym
->attr
.proc
== PROC_ST_FUNCTION
2641 || sym
->attr
.proc
== PROC_INTERNAL
)
2644 if (sym
->attr
.intrinsic
)
2646 m
= gfc_intrinsic_func_interface (expr
, 1);
2650 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2651 "with an intrinsic", sym
->name
, &expr
->where
);
2659 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2662 expr
->ts
= sym
->result
->ts
;
2665 expr
->value
.function
.name
= sym
->name
;
2666 expr
->value
.function
.esym
= sym
;
2667 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2669 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2671 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2672 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2673 else if (sym
->as
!= NULL
)
2674 expr
->rank
= sym
->as
->rank
;
2681 resolve_specific_f (gfc_expr
*expr
)
2686 sym
= expr
->symtree
->n
.sym
;
2690 m
= resolve_specific_f0 (sym
, expr
);
2693 if (m
== MATCH_ERROR
)
2696 if (sym
->ns
->parent
== NULL
)
2699 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2705 gfc_error ("Unable to resolve the specific function %qs at %L",
2706 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2712 /* Resolve a procedure call not known to be generic nor specific. */
2715 resolve_unknown_f (gfc_expr
*expr
)
2720 sym
= expr
->symtree
->n
.sym
;
2722 if (sym
->attr
.dummy
)
2724 sym
->attr
.proc
= PROC_DUMMY
;
2725 expr
->value
.function
.name
= sym
->name
;
2729 /* See if we have an intrinsic function reference. */
2731 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2733 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2738 /* The reference is to an external name. */
2740 sym
->attr
.proc
= PROC_EXTERNAL
;
2741 expr
->value
.function
.name
= sym
->name
;
2742 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2744 if (sym
->as
!= NULL
)
2745 expr
->rank
= sym
->as
->rank
;
2747 /* Type of the expression is either the type of the symbol or the
2748 default type of the symbol. */
2751 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2753 if (sym
->ts
.type
!= BT_UNKNOWN
)
2757 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2759 if (ts
->type
== BT_UNKNOWN
)
2761 gfc_error ("Function %qs at %L has no IMPLICIT type",
2762 sym
->name
, &expr
->where
);
2773 /* Return true, if the symbol is an external procedure. */
2775 is_external_proc (gfc_symbol
*sym
)
2777 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2778 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2779 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2780 && !sym
->attr
.proc_pointer
2781 && !sym
->attr
.use_assoc
2789 /* Figure out if a function reference is pure or not. Also set the name
2790 of the function for a potential error message. Return nonzero if the
2791 function is PURE, zero if not. */
2793 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2796 pure_function (gfc_expr
*e
, const char **name
)
2799 gfc_component
*comp
;
2803 if (e
->symtree
!= NULL
2804 && e
->symtree
->n
.sym
!= NULL
2805 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2806 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2808 comp
= gfc_get_proc_ptr_comp (e
);
2811 pure
= gfc_pure (comp
->ts
.interface
);
2814 else if (e
->value
.function
.esym
)
2816 pure
= gfc_pure (e
->value
.function
.esym
);
2817 *name
= e
->value
.function
.esym
->name
;
2819 else if (e
->value
.function
.isym
)
2821 pure
= e
->value
.function
.isym
->pure
2822 || e
->value
.function
.isym
->elemental
;
2823 *name
= e
->value
.function
.isym
->name
;
2827 /* Implicit functions are not pure. */
2829 *name
= e
->value
.function
.name
;
2837 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2838 int *f ATTRIBUTE_UNUSED
)
2842 /* Don't bother recursing into other statement functions
2843 since they will be checked individually for purity. */
2844 if (e
->expr_type
!= EXPR_FUNCTION
2846 || e
->symtree
->n
.sym
== sym
2847 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2850 return pure_function (e
, &name
) ? false : true;
2855 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2857 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2861 /* Check if an impure function is allowed in the current context. */
2863 static bool check_pure_function (gfc_expr
*e
)
2865 const char *name
= NULL
;
2866 if (!pure_function (e
, &name
) && name
)
2870 gfc_error ("Reference to impure function %qs at %L inside a "
2871 "FORALL %s", name
, &e
->where
,
2872 forall_flag
== 2 ? "mask" : "block");
2875 else if (gfc_do_concurrent_flag
)
2877 gfc_error ("Reference to impure function %qs at %L inside a "
2878 "DO CONCURRENT %s", name
, &e
->where
,
2879 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2882 else if (gfc_pure (NULL
))
2884 gfc_error ("Reference to impure function %qs at %L "
2885 "within a PURE procedure", name
, &e
->where
);
2888 gfc_unset_implicit_pure (NULL
);
2894 /* Update current procedure's array_outer_dependency flag, considering
2895 a call to procedure SYM. */
2898 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2900 /* Check to see if this is a sibling function that has not yet
2902 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2903 for (; sibling
; sibling
= sibling
->sibling
)
2905 if (sibling
->proc_name
== sym
)
2907 gfc_resolve (sibling
);
2912 /* If SYM has references to outer arrays, so has the procedure calling
2913 SYM. If SYM is a procedure pointer, we can assume the worst. */
2914 if (sym
->attr
.array_outer_dependency
2915 || sym
->attr
.proc_pointer
)
2916 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2920 /* Resolve a function call, which means resolving the arguments, then figuring
2921 out which entity the name refers to. */
2924 resolve_function (gfc_expr
*expr
)
2926 gfc_actual_arglist
*arg
;
2930 procedure_type p
= PROC_INTRINSIC
;
2931 bool no_formal_args
;
2935 sym
= expr
->symtree
->n
.sym
;
2937 /* If this is a procedure pointer component, it has already been resolved. */
2938 if (gfc_is_proc_ptr_comp (expr
))
2941 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
2943 if (sym
&& sym
->attr
.intrinsic
2944 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
2945 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
2948 if (sym
&& sym
->attr
.intrinsic
2949 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2952 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2954 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2958 /* If this ia a deferred TBP with an abstract interface (which may
2959 of course be referenced), expr->value.function.esym will be set. */
2960 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2962 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2963 sym
->name
, &expr
->where
);
2967 /* Switch off assumed size checking and do this again for certain kinds
2968 of procedure, once the procedure itself is resolved. */
2969 need_full_assumed_size
++;
2971 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2972 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2974 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2975 inquiry_argument
= true;
2976 no_formal_args
= sym
&& is_external_proc (sym
)
2977 && gfc_sym_get_dummy_args (sym
) == NULL
;
2979 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2982 inquiry_argument
= false;
2986 inquiry_argument
= false;
2988 /* Resume assumed_size checking. */
2989 need_full_assumed_size
--;
2991 /* If the procedure is external, check for usage. */
2992 if (sym
&& is_external_proc (sym
))
2993 resolve_global_procedure (sym
, &expr
->where
,
2994 &expr
->value
.function
.actual
, 0);
2996 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2998 && sym
->ts
.u
.cl
->length
== NULL
3000 && !sym
->ts
.deferred
3001 && expr
->value
.function
.esym
== NULL
3002 && !sym
->attr
.contained
)
3004 /* Internal procedures are taken care of in resolve_contained_fntype. */
3005 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3006 "be used at %L since it is not a dummy argument",
3007 sym
->name
, &expr
->where
);
3011 /* See if function is already resolved. */
3013 if (expr
->value
.function
.name
!= NULL
3014 || expr
->value
.function
.isym
!= NULL
)
3016 if (expr
->ts
.type
== BT_UNKNOWN
)
3022 /* Apply the rules of section 14.1.2. */
3024 switch (procedure_kind (sym
))
3027 t
= resolve_generic_f (expr
);
3030 case PTYPE_SPECIFIC
:
3031 t
= resolve_specific_f (expr
);
3035 t
= resolve_unknown_f (expr
);
3039 gfc_internal_error ("resolve_function(): bad function type");
3043 /* If the expression is still a function (it might have simplified),
3044 then we check to see if we are calling an elemental function. */
3046 if (expr
->expr_type
!= EXPR_FUNCTION
)
3049 temp
= need_full_assumed_size
;
3050 need_full_assumed_size
= 0;
3052 if (!resolve_elemental_actual (expr
, NULL
))
3055 if (omp_workshare_flag
3056 && expr
->value
.function
.esym
3057 && ! gfc_elemental (expr
->value
.function
.esym
))
3059 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3060 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3065 #define GENERIC_ID expr->value.function.isym->id
3066 else if (expr
->value
.function
.actual
!= NULL
3067 && expr
->value
.function
.isym
!= NULL
3068 && GENERIC_ID
!= GFC_ISYM_LBOUND
3069 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3070 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3071 && GENERIC_ID
!= GFC_ISYM_LEN
3072 && GENERIC_ID
!= GFC_ISYM_LOC
3073 && GENERIC_ID
!= GFC_ISYM_C_LOC
3074 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3076 /* Array intrinsics must also have the last upper bound of an
3077 assumed size array argument. UBOUND and SIZE have to be
3078 excluded from the check if the second argument is anything
3081 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3083 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3084 && arg
== expr
->value
.function
.actual
3085 && arg
->next
!= NULL
&& arg
->next
->expr
)
3087 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3090 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3093 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3098 if (arg
->expr
!= NULL
3099 && arg
->expr
->rank
> 0
3100 && resolve_assumed_size_actual (arg
->expr
))
3106 need_full_assumed_size
= temp
;
3108 if (!check_pure_function(expr
))
3111 /* Functions without the RECURSIVE attribution are not allowed to
3112 * call themselves. */
3113 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3116 esym
= expr
->value
.function
.esym
;
3118 if (is_illegal_recursion (esym
, gfc_current_ns
))
3120 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3121 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3122 " function %qs is not RECURSIVE",
3123 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3125 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3126 " is not RECURSIVE", esym
->name
, &expr
->where
);
3132 /* Character lengths of use associated functions may contains references to
3133 symbols not referenced from the current program unit otherwise. Make sure
3134 those symbols are marked as referenced. */
3136 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3137 && expr
->value
.function
.esym
->attr
.use_assoc
)
3139 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3142 /* Make sure that the expression has a typespec that works. */
3143 if (expr
->ts
.type
== BT_UNKNOWN
)
3145 if (expr
->symtree
->n
.sym
->result
3146 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3147 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3148 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3151 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3153 if (expr
->value
.function
.esym
)
3154 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3156 update_current_proc_array_outer_dependency (sym
);
3159 /* typebound procedure: Assume the worst. */
3160 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3166 /************* Subroutine resolution *************/
3169 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3176 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3180 else if (gfc_do_concurrent_flag
)
3182 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3186 else if (gfc_pure (NULL
))
3188 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3192 gfc_unset_implicit_pure (NULL
);
3198 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3202 if (sym
->attr
.generic
)
3204 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3207 c
->resolved_sym
= s
;
3208 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3213 /* TODO: Need to search for elemental references in generic interface. */
3216 if (sym
->attr
.intrinsic
)
3217 return gfc_intrinsic_sub_interface (c
, 0);
3224 resolve_generic_s (gfc_code
*c
)
3229 sym
= c
->symtree
->n
.sym
;
3233 m
= resolve_generic_s0 (c
, sym
);
3236 else if (m
== MATCH_ERROR
)
3240 if (sym
->ns
->parent
== NULL
)
3242 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3246 if (!generic_sym (sym
))
3250 /* Last ditch attempt. See if the reference is to an intrinsic
3251 that possesses a matching interface. 14.1.2.4 */
3252 sym
= c
->symtree
->n
.sym
;
3254 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3256 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3257 sym
->name
, &c
->loc
);
3261 m
= gfc_intrinsic_sub_interface (c
, 0);
3265 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3266 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3272 /* Resolve a subroutine call known to be specific. */
3275 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3279 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3281 if (sym
->attr
.dummy
)
3283 sym
->attr
.proc
= PROC_DUMMY
;
3287 sym
->attr
.proc
= PROC_EXTERNAL
;
3291 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3294 if (sym
->attr
.intrinsic
)
3296 m
= gfc_intrinsic_sub_interface (c
, 1);
3300 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3301 "with an intrinsic", sym
->name
, &c
->loc
);
3309 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3311 c
->resolved_sym
= sym
;
3312 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3320 resolve_specific_s (gfc_code
*c
)
3325 sym
= c
->symtree
->n
.sym
;
3329 m
= resolve_specific_s0 (c
, sym
);
3332 if (m
== MATCH_ERROR
)
3335 if (sym
->ns
->parent
== NULL
)
3338 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3344 sym
= c
->symtree
->n
.sym
;
3345 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3346 sym
->name
, &c
->loc
);
3352 /* Resolve a subroutine call not known to be generic nor specific. */
3355 resolve_unknown_s (gfc_code
*c
)
3359 sym
= c
->symtree
->n
.sym
;
3361 if (sym
->attr
.dummy
)
3363 sym
->attr
.proc
= PROC_DUMMY
;
3367 /* See if we have an intrinsic function reference. */
3369 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3371 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3376 /* The reference is to an external name. */
3379 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3381 c
->resolved_sym
= sym
;
3383 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3387 /* Resolve a subroutine call. Although it was tempting to use the same code
3388 for functions, subroutines and functions are stored differently and this
3389 makes things awkward. */
3392 resolve_call (gfc_code
*c
)
3395 procedure_type ptype
= PROC_INTRINSIC
;
3396 gfc_symbol
*csym
, *sym
;
3397 bool no_formal_args
;
3399 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3401 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3403 gfc_error ("%qs at %L has a type, which is not consistent with "
3404 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3408 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3411 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3412 sym
= st
? st
->n
.sym
: NULL
;
3413 if (sym
&& csym
!= sym
3414 && sym
->ns
== gfc_current_ns
3415 && sym
->attr
.flavor
== FL_PROCEDURE
3416 && sym
->attr
.contained
)
3419 if (csym
->attr
.generic
)
3420 c
->symtree
->n
.sym
= sym
;
3423 csym
= c
->symtree
->n
.sym
;
3427 /* If this ia a deferred TBP, c->expr1 will be set. */
3428 if (!c
->expr1
&& csym
)
3430 if (csym
->attr
.abstract
)
3432 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3433 csym
->name
, &c
->loc
);
3437 /* Subroutines without the RECURSIVE attribution are not allowed to
3439 if (is_illegal_recursion (csym
, gfc_current_ns
))
3441 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3442 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3443 "as subroutine %qs is not RECURSIVE",
3444 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3446 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3447 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3453 /* Switch off assumed size checking and do this again for certain kinds
3454 of procedure, once the procedure itself is resolved. */
3455 need_full_assumed_size
++;
3458 ptype
= csym
->attr
.proc
;
3460 no_formal_args
= csym
&& is_external_proc (csym
)
3461 && gfc_sym_get_dummy_args (csym
) == NULL
;
3462 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3465 /* Resume assumed_size checking. */
3466 need_full_assumed_size
--;
3468 /* If external, check for usage. */
3469 if (csym
&& is_external_proc (csym
))
3470 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3473 if (c
->resolved_sym
== NULL
)
3475 c
->resolved_isym
= NULL
;
3476 switch (procedure_kind (csym
))
3479 t
= resolve_generic_s (c
);
3482 case PTYPE_SPECIFIC
:
3483 t
= resolve_specific_s (c
);
3487 t
= resolve_unknown_s (c
);
3491 gfc_internal_error ("resolve_subroutine(): bad function type");
3495 /* Some checks of elemental subroutine actual arguments. */
3496 if (!resolve_elemental_actual (NULL
, c
))
3500 update_current_proc_array_outer_dependency (csym
);
3502 /* Typebound procedure: Assume the worst. */
3503 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3509 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3510 op1->shape and op2->shape are non-NULL return true if their shapes
3511 match. If both op1->shape and op2->shape are non-NULL return false
3512 if their shapes do not match. If either op1->shape or op2->shape is
3513 NULL, return true. */
3516 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3523 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3525 for (i
= 0; i
< op1
->rank
; i
++)
3527 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3529 gfc_error ("Shapes for operands at %L and %L are not conformable",
3530 &op1
->where
, &op2
->where
);
3540 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3541 For example A .AND. B becomes IAND(A, B). */
3543 logical_to_bitwise (gfc_expr
*e
)
3545 gfc_expr
*tmp
, *op1
, *op2
;
3547 gfc_actual_arglist
*args
= NULL
;
3549 gcc_assert (e
->expr_type
== EXPR_OP
);
3551 isym
= GFC_ISYM_NONE
;
3552 op1
= e
->value
.op
.op1
;
3553 op2
= e
->value
.op
.op2
;
3555 switch (e
->value
.op
.op
)
3558 isym
= GFC_ISYM_NOT
;
3561 isym
= GFC_ISYM_IAND
;
3564 isym
= GFC_ISYM_IOR
;
3566 case INTRINSIC_NEQV
:
3567 isym
= GFC_ISYM_IEOR
;
3570 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3571 Change the old expression to NEQV, which will get replaced by IEOR,
3572 and wrap it in NOT. */
3573 tmp
= gfc_copy_expr (e
);
3574 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3575 tmp
= logical_to_bitwise (tmp
);
3576 isym
= GFC_ISYM_NOT
;
3581 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3584 /* Inherit the original operation's operands as arguments. */
3585 args
= gfc_get_actual_arglist ();
3589 args
->next
= gfc_get_actual_arglist ();
3590 args
->next
->expr
= op2
;
3593 /* Convert the expression to a function call. */
3594 e
->expr_type
= EXPR_FUNCTION
;
3595 e
->value
.function
.actual
= args
;
3596 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3597 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3598 e
->value
.function
.esym
= NULL
;
3600 /* Make up a pre-resolved function call symtree if we need to. */
3601 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3604 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3605 sym
= e
->symtree
->n
.sym
;
3607 sym
->attr
.flavor
= FL_PROCEDURE
;
3608 sym
->attr
.function
= 1;
3609 sym
->attr
.elemental
= 1;
3611 sym
->attr
.referenced
= 1;
3612 gfc_intrinsic_symbol (sym
);
3613 gfc_commit_symbol (sym
);
3616 args
->name
= e
->value
.function
.isym
->formal
->name
;
3617 if (e
->value
.function
.isym
->formal
->next
)
3618 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3623 /* Resolve an operator expression node. This can involve replacing the
3624 operation with a user defined function call. */
3627 resolve_operator (gfc_expr
*e
)
3629 gfc_expr
*op1
, *op2
;
3631 bool dual_locus_error
;
3634 /* Resolve all subnodes-- give them types. */
3636 switch (e
->value
.op
.op
)
3639 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3645 case INTRINSIC_UPLUS
:
3646 case INTRINSIC_UMINUS
:
3647 case INTRINSIC_PARENTHESES
:
3648 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3653 /* Typecheck the new node. */
3655 op1
= e
->value
.op
.op1
;
3656 op2
= e
->value
.op
.op2
;
3657 dual_locus_error
= false;
3659 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3660 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3662 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3666 switch (e
->value
.op
.op
)
3668 case INTRINSIC_UPLUS
:
3669 case INTRINSIC_UMINUS
:
3670 if (op1
->ts
.type
== BT_INTEGER
3671 || op1
->ts
.type
== BT_REAL
3672 || op1
->ts
.type
== BT_COMPLEX
)
3678 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3679 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3682 case INTRINSIC_PLUS
:
3683 case INTRINSIC_MINUS
:
3684 case INTRINSIC_TIMES
:
3685 case INTRINSIC_DIVIDE
:
3686 case INTRINSIC_POWER
:
3687 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3689 gfc_type_convert_binary (e
, 1);
3694 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3695 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3696 gfc_typename (&op2
->ts
));
3699 case INTRINSIC_CONCAT
:
3700 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3701 && op1
->ts
.kind
== op2
->ts
.kind
)
3703 e
->ts
.type
= BT_CHARACTER
;
3704 e
->ts
.kind
= op1
->ts
.kind
;
3709 _("Operands of string concatenation operator at %%L are %s/%s"),
3710 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3716 case INTRINSIC_NEQV
:
3717 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3719 e
->ts
.type
= BT_LOGICAL
;
3720 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3721 if (op1
->ts
.kind
< e
->ts
.kind
)
3722 gfc_convert_type (op1
, &e
->ts
, 2);
3723 else if (op2
->ts
.kind
< e
->ts
.kind
)
3724 gfc_convert_type (op2
, &e
->ts
, 2);
3728 /* Logical ops on integers become bitwise ops with -fdec. */
3730 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
3732 e
->ts
.type
= BT_INTEGER
;
3733 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3734 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
3735 gfc_convert_type (op1
, &e
->ts
, 1);
3736 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
3737 gfc_convert_type (op2
, &e
->ts
, 1);
3738 e
= logical_to_bitwise (e
);
3739 return resolve_function (e
);
3742 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3743 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3744 gfc_typename (&op2
->ts
));
3749 /* Logical ops on integers become bitwise ops with -fdec. */
3750 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
3752 e
->ts
.type
= BT_INTEGER
;
3753 e
->ts
.kind
= op1
->ts
.kind
;
3754 e
= logical_to_bitwise (e
);
3755 return resolve_function (e
);
3758 if (op1
->ts
.type
== BT_LOGICAL
)
3760 e
->ts
.type
= BT_LOGICAL
;
3761 e
->ts
.kind
= op1
->ts
.kind
;
3765 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3766 gfc_typename (&op1
->ts
));
3770 case INTRINSIC_GT_OS
:
3772 case INTRINSIC_GE_OS
:
3774 case INTRINSIC_LT_OS
:
3776 case INTRINSIC_LE_OS
:
3777 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3779 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3786 case INTRINSIC_EQ_OS
:
3788 case INTRINSIC_NE_OS
:
3789 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3790 && op1
->ts
.kind
== op2
->ts
.kind
)
3792 e
->ts
.type
= BT_LOGICAL
;
3793 e
->ts
.kind
= gfc_default_logical_kind
;
3797 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3799 gfc_type_convert_binary (e
, 1);
3801 e
->ts
.type
= BT_LOGICAL
;
3802 e
->ts
.kind
= gfc_default_logical_kind
;
3804 if (warn_compare_reals
)
3806 gfc_intrinsic_op op
= e
->value
.op
.op
;
3808 /* Type conversion has made sure that the types of op1 and op2
3809 agree, so it is only necessary to check the first one. */
3810 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3811 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3812 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3816 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3817 msg
= "Equality comparison for %s at %L";
3819 msg
= "Inequality comparison for %s at %L";
3821 gfc_warning (OPT_Wcompare_reals
, msg
,
3822 gfc_typename (&op1
->ts
), &op1
->where
);
3829 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3831 _("Logicals at %%L must be compared with %s instead of %s"),
3832 (e
->value
.op
.op
== INTRINSIC_EQ
3833 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3834 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3837 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
3838 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3839 gfc_typename (&op2
->ts
));
3843 case INTRINSIC_USER
:
3844 if (e
->value
.op
.uop
->op
== NULL
)
3845 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"),
3846 e
->value
.op
.uop
->name
);
3847 else if (op2
== NULL
)
3848 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
3849 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3852 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
3853 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3854 gfc_typename (&op2
->ts
));
3855 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3860 case INTRINSIC_PARENTHESES
:
3862 if (e
->ts
.type
== BT_CHARACTER
)
3863 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3867 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3870 /* Deal with arrayness of an operand through an operator. */
3874 switch (e
->value
.op
.op
)
3876 case INTRINSIC_PLUS
:
3877 case INTRINSIC_MINUS
:
3878 case INTRINSIC_TIMES
:
3879 case INTRINSIC_DIVIDE
:
3880 case INTRINSIC_POWER
:
3881 case INTRINSIC_CONCAT
:
3885 case INTRINSIC_NEQV
:
3887 case INTRINSIC_EQ_OS
:
3889 case INTRINSIC_NE_OS
:
3891 case INTRINSIC_GT_OS
:
3893 case INTRINSIC_GE_OS
:
3895 case INTRINSIC_LT_OS
:
3897 case INTRINSIC_LE_OS
:
3899 if (op1
->rank
== 0 && op2
->rank
== 0)
3902 if (op1
->rank
== 0 && op2
->rank
!= 0)
3904 e
->rank
= op2
->rank
;
3906 if (e
->shape
== NULL
)
3907 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3910 if (op1
->rank
!= 0 && op2
->rank
== 0)
3912 e
->rank
= op1
->rank
;
3914 if (e
->shape
== NULL
)
3915 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3918 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3920 if (op1
->rank
== op2
->rank
)
3922 e
->rank
= op1
->rank
;
3923 if (e
->shape
== NULL
)
3925 t
= compare_shapes (op1
, op2
);
3929 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3934 /* Allow higher level expressions to work. */
3937 /* Try user-defined operators, and otherwise throw an error. */
3938 dual_locus_error
= true;
3940 _("Inconsistent ranks for operator at %%L and %%L"));
3947 case INTRINSIC_PARENTHESES
:
3949 case INTRINSIC_UPLUS
:
3950 case INTRINSIC_UMINUS
:
3951 /* Simply copy arrayness attribute */
3952 e
->rank
= op1
->rank
;
3954 if (e
->shape
== NULL
)
3955 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3963 /* Attempt to simplify the expression. */
3966 t
= gfc_simplify_expr (e
, 0);
3967 /* Some calls do not succeed in simplification and return false
3968 even though there is no error; e.g. variable references to
3969 PARAMETER arrays. */
3970 if (!gfc_is_constant_expr (e
))
3978 match m
= gfc_extend_expr (e
);
3981 if (m
== MATCH_ERROR
)
3985 if (dual_locus_error
)
3986 gfc_error (msg
, &op1
->where
, &op2
->where
);
3988 gfc_error (msg
, &e
->where
);
3994 /************** Array resolution subroutines **************/
3997 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
3999 /* Compare two integer expressions. */
4001 static compare_result
4002 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4006 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4007 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4010 /* If either of the types isn't INTEGER, we must have
4011 raised an error earlier. */
4013 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4016 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4026 /* Compare an integer expression with an integer. */
4028 static compare_result
4029 compare_bound_int (gfc_expr
*a
, int b
)
4033 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4036 if (a
->ts
.type
!= BT_INTEGER
)
4037 gfc_internal_error ("compare_bound_int(): Bad expression");
4039 i
= mpz_cmp_si (a
->value
.integer
, b
);
4049 /* Compare an integer expression with a mpz_t. */
4051 static compare_result
4052 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4056 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4059 if (a
->ts
.type
!= BT_INTEGER
)
4060 gfc_internal_error ("compare_bound_int(): Bad expression");
4062 i
= mpz_cmp (a
->value
.integer
, b
);
4072 /* Compute the last value of a sequence given by a triplet.
4073 Return 0 if it wasn't able to compute the last value, or if the
4074 sequence if empty, and 1 otherwise. */
4077 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4078 gfc_expr
*stride
, mpz_t last
)
4082 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4083 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4084 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4087 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4088 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4091 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4093 if (compare_bound (start
, end
) == CMP_GT
)
4095 mpz_set (last
, end
->value
.integer
);
4099 if (compare_bound_int (stride
, 0) == CMP_GT
)
4101 /* Stride is positive */
4102 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4107 /* Stride is negative */
4108 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4113 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4114 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4115 mpz_sub (last
, end
->value
.integer
, rem
);
4122 /* Compare a single dimension of an array reference to the array
4126 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4130 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4132 gcc_assert (ar
->stride
[i
] == NULL
);
4133 /* This implies [*] as [*:] and [*:3] are not possible. */
4134 if (ar
->start
[i
] == NULL
)
4136 gcc_assert (ar
->end
[i
] == NULL
);
4141 /* Given start, end and stride values, calculate the minimum and
4142 maximum referenced indexes. */
4144 switch (ar
->dimen_type
[i
])
4147 case DIMEN_THIS_IMAGE
:
4152 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4155 gfc_warning (0, "Array reference at %L is out of bounds "
4156 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4157 mpz_get_si (ar
->start
[i
]->value
.integer
),
4158 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4160 gfc_warning (0, "Array reference at %L is out of bounds "
4161 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4162 mpz_get_si (ar
->start
[i
]->value
.integer
),
4163 mpz_get_si (as
->lower
[i
]->value
.integer
),
4167 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4170 gfc_warning (0, "Array reference at %L is out of bounds "
4171 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4172 mpz_get_si (ar
->start
[i
]->value
.integer
),
4173 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4175 gfc_warning (0, "Array reference at %L is out of bounds "
4176 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4177 mpz_get_si (ar
->start
[i
]->value
.integer
),
4178 mpz_get_si (as
->upper
[i
]->value
.integer
),
4187 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4188 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4190 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4192 /* Check for zero stride, which is not allowed. */
4193 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4195 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4199 /* if start == len || (stride > 0 && start < len)
4200 || (stride < 0 && start > len),
4201 then the array section contains at least one element. In this
4202 case, there is an out-of-bounds access if
4203 (start < lower || start > upper). */
4204 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4205 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4206 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4207 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4208 && comp_start_end
== CMP_GT
))
4210 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4212 gfc_warning (0, "Lower array reference at %L is out of bounds "
4213 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4214 mpz_get_si (AR_START
->value
.integer
),
4215 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4218 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4220 gfc_warning (0, "Lower array reference at %L is out of bounds "
4221 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4222 mpz_get_si (AR_START
->value
.integer
),
4223 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4228 /* If we can compute the highest index of the array section,
4229 then it also has to be between lower and upper. */
4230 mpz_init (last_value
);
4231 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4234 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4236 gfc_warning (0, "Upper array reference at %L is out of bounds "
4237 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4238 mpz_get_si (last_value
),
4239 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4240 mpz_clear (last_value
);
4243 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4245 gfc_warning (0, "Upper array reference at %L is out of bounds "
4246 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4247 mpz_get_si (last_value
),
4248 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4249 mpz_clear (last_value
);
4253 mpz_clear (last_value
);
4261 gfc_internal_error ("check_dimension(): Bad array reference");
4268 /* Compare an array reference with an array specification. */
4271 compare_spec_to_ref (gfc_array_ref
*ar
)
4278 /* TODO: Full array sections are only allowed as actual parameters. */
4279 if (as
->type
== AS_ASSUMED_SIZE
4280 && (/*ar->type == AR_FULL
4281 ||*/ (ar
->type
== AR_SECTION
4282 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4284 gfc_error ("Rightmost upper bound of assumed size array section "
4285 "not specified at %L", &ar
->where
);
4289 if (ar
->type
== AR_FULL
)
4292 if (as
->rank
!= ar
->dimen
)
4294 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4295 &ar
->where
, ar
->dimen
, as
->rank
);
4299 /* ar->codimen == 0 is a local array. */
4300 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4302 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4303 &ar
->where
, ar
->codimen
, as
->corank
);
4307 for (i
= 0; i
< as
->rank
; i
++)
4308 if (!check_dimension (i
, ar
, as
))
4311 /* Local access has no coarray spec. */
4312 if (ar
->codimen
!= 0)
4313 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4315 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4316 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4318 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4319 i
+ 1 - as
->rank
, &ar
->where
);
4322 if (!check_dimension (i
, ar
, as
))
4330 /* Resolve one part of an array index. */
4333 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4334 int force_index_integer_kind
)
4341 if (!gfc_resolve_expr (index
))
4344 if (check_scalar
&& index
->rank
!= 0)
4346 gfc_error ("Array index at %L must be scalar", &index
->where
);
4350 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4352 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4353 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4357 if (index
->ts
.type
== BT_REAL
)
4358 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4362 if ((index
->ts
.kind
!= gfc_index_integer_kind
4363 && force_index_integer_kind
)
4364 || index
->ts
.type
!= BT_INTEGER
)
4367 ts
.type
= BT_INTEGER
;
4368 ts
.kind
= gfc_index_integer_kind
;
4370 gfc_convert_type_warn (index
, &ts
, 2, 0);
4376 /* Resolve one part of an array index. */
4379 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4381 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4384 /* Resolve a dim argument to an intrinsic function. */
4387 gfc_resolve_dim_arg (gfc_expr
*dim
)
4392 if (!gfc_resolve_expr (dim
))
4397 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4402 if (dim
->ts
.type
!= BT_INTEGER
)
4404 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4408 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4413 ts
.type
= BT_INTEGER
;
4414 ts
.kind
= gfc_index_integer_kind
;
4416 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4422 /* Given an expression that contains array references, update those array
4423 references to point to the right array specifications. While this is
4424 filled in during matching, this information is difficult to save and load
4425 in a module, so we take care of it here.
4427 The idea here is that the original array reference comes from the
4428 base symbol. We traverse the list of reference structures, setting
4429 the stored reference to references. Component references can
4430 provide an additional array specification. */
4433 find_array_spec (gfc_expr
*e
)
4439 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4440 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4442 as
= e
->symtree
->n
.sym
->as
;
4444 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4449 gfc_internal_error ("find_array_spec(): Missing spec");
4456 c
= ref
->u
.c
.component
;
4457 if (c
->attr
.dimension
)
4460 gfc_internal_error ("find_array_spec(): unused as(1)");
4471 gfc_internal_error ("find_array_spec(): unused as(2)");
4475 /* Resolve an array reference. */
4478 resolve_array_ref (gfc_array_ref
*ar
)
4480 int i
, check_scalar
;
4483 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4485 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4487 /* Do not force gfc_index_integer_kind for the start. We can
4488 do fine with any integer kind. This avoids temporary arrays
4489 created for indexing with a vector. */
4490 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4492 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4494 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4499 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4503 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4507 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4508 if (e
->expr_type
== EXPR_VARIABLE
4509 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4510 ar
->start
[i
] = gfc_get_parentheses (e
);
4514 gfc_error ("Array index at %L is an array of rank %d",
4515 &ar
->c_where
[i
], e
->rank
);
4519 /* Fill in the upper bound, which may be lower than the
4520 specified one for something like a(2:10:5), which is
4521 identical to a(2:7:5). Only relevant for strides not equal
4522 to one. Don't try a division by zero. */
4523 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4524 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4525 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4526 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4530 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4532 if (ar
->end
[i
] == NULL
)
4535 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4537 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4539 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4540 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4542 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4553 if (ar
->type
== AR_FULL
)
4555 if (ar
->as
->rank
== 0)
4556 ar
->type
= AR_ELEMENT
;
4558 /* Make sure array is the same as array(:,:), this way
4559 we don't need to special case all the time. */
4560 ar
->dimen
= ar
->as
->rank
;
4561 for (i
= 0; i
< ar
->dimen
; i
++)
4563 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4565 gcc_assert (ar
->start
[i
] == NULL
);
4566 gcc_assert (ar
->end
[i
] == NULL
);
4567 gcc_assert (ar
->stride
[i
] == NULL
);
4571 /* If the reference type is unknown, figure out what kind it is. */
4573 if (ar
->type
== AR_UNKNOWN
)
4575 ar
->type
= AR_ELEMENT
;
4576 for (i
= 0; i
< ar
->dimen
; i
++)
4577 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4578 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4580 ar
->type
= AR_SECTION
;
4585 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4588 if (ar
->as
->corank
&& ar
->codimen
== 0)
4591 ar
->codimen
= ar
->as
->corank
;
4592 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4593 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4601 resolve_substring (gfc_ref
*ref
)
4603 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4605 if (ref
->u
.ss
.start
!= NULL
)
4607 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4610 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4612 gfc_error ("Substring start index at %L must be of type INTEGER",
4613 &ref
->u
.ss
.start
->where
);
4617 if (ref
->u
.ss
.start
->rank
!= 0)
4619 gfc_error ("Substring start index at %L must be scalar",
4620 &ref
->u
.ss
.start
->where
);
4624 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4625 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4626 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4628 gfc_error ("Substring start index at %L is less than one",
4629 &ref
->u
.ss
.start
->where
);
4634 if (ref
->u
.ss
.end
!= NULL
)
4636 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4639 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4641 gfc_error ("Substring end index at %L must be of type INTEGER",
4642 &ref
->u
.ss
.end
->where
);
4646 if (ref
->u
.ss
.end
->rank
!= 0)
4648 gfc_error ("Substring end index at %L must be scalar",
4649 &ref
->u
.ss
.end
->where
);
4653 if (ref
->u
.ss
.length
!= NULL
4654 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4655 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4656 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4658 gfc_error ("Substring end index at %L exceeds the string length",
4659 &ref
->u
.ss
.start
->where
);
4663 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4664 gfc_integer_kinds
[k
].huge
) == CMP_GT
4665 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4666 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4668 gfc_error ("Substring end index at %L is too large",
4669 &ref
->u
.ss
.end
->where
);
4678 /* This function supplies missing substring charlens. */
4681 gfc_resolve_substring_charlen (gfc_expr
*e
)
4684 gfc_expr
*start
, *end
;
4685 gfc_typespec
*ts
= NULL
;
4687 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4689 if (char_ref
->type
== REF_SUBSTRING
)
4691 if (char_ref
->type
== REF_COMPONENT
)
4692 ts
= &char_ref
->u
.c
.component
->ts
;
4698 gcc_assert (char_ref
->next
== NULL
);
4702 if (e
->ts
.u
.cl
->length
)
4703 gfc_free_expr (e
->ts
.u
.cl
->length
);
4704 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4708 e
->ts
.type
= BT_CHARACTER
;
4709 e
->ts
.kind
= gfc_default_character_kind
;
4712 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4714 if (char_ref
->u
.ss
.start
)
4715 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4717 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4719 if (char_ref
->u
.ss
.end
)
4720 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4721 else if (e
->expr_type
== EXPR_VARIABLE
)
4724 ts
= &e
->symtree
->n
.sym
->ts
;
4725 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4732 gfc_free_expr (start
);
4733 gfc_free_expr (end
);
4737 /* Length = (end - start + 1). */
4738 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4739 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4740 gfc_get_int_expr (gfc_default_integer_kind
,
4743 /* F2008, 6.4.1: Both the starting point and the ending point shall
4744 be within the range 1, 2, ..., n unless the starting point exceeds
4745 the ending point, in which case the substring has length zero. */
4747 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4748 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4750 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4751 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4753 /* Make sure that the length is simplified. */
4754 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4755 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4759 /* Resolve subtype references. */
4762 resolve_ref (gfc_expr
*expr
)
4764 int current_part_dimension
, n_components
, seen_part_dimension
;
4767 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4768 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4770 find_array_spec (expr
);
4774 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4778 if (!resolve_array_ref (&ref
->u
.ar
))
4786 if (!resolve_substring (ref
))
4791 /* Check constraints on part references. */
4793 current_part_dimension
= 0;
4794 seen_part_dimension
= 0;
4797 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4802 switch (ref
->u
.ar
.type
)
4805 /* Coarray scalar. */
4806 if (ref
->u
.ar
.as
->rank
== 0)
4808 current_part_dimension
= 0;
4813 current_part_dimension
= 1;
4817 current_part_dimension
= 0;
4821 gfc_internal_error ("resolve_ref(): Bad array reference");
4827 if (current_part_dimension
|| seen_part_dimension
)
4830 if (ref
->u
.c
.component
->attr
.pointer
4831 || ref
->u
.c
.component
->attr
.proc_pointer
4832 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4833 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4835 gfc_error ("Component to the right of a part reference "
4836 "with nonzero rank must not have the POINTER "
4837 "attribute at %L", &expr
->where
);
4840 else if (ref
->u
.c
.component
->attr
.allocatable
4841 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4842 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4845 gfc_error ("Component to the right of a part reference "
4846 "with nonzero rank must not have the ALLOCATABLE "
4847 "attribute at %L", &expr
->where
);
4859 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4860 || ref
->next
== NULL
)
4861 && current_part_dimension
4862 && seen_part_dimension
)
4864 gfc_error ("Two or more part references with nonzero rank must "
4865 "not be specified at %L", &expr
->where
);
4869 if (ref
->type
== REF_COMPONENT
)
4871 if (current_part_dimension
)
4872 seen_part_dimension
= 1;
4874 /* reset to make sure */
4875 current_part_dimension
= 0;
4883 /* Given an expression, determine its shape. This is easier than it sounds.
4884 Leaves the shape array NULL if it is not possible to determine the shape. */
4887 expression_shape (gfc_expr
*e
)
4889 mpz_t array
[GFC_MAX_DIMENSIONS
];
4892 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4895 for (i
= 0; i
< e
->rank
; i
++)
4896 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4899 e
->shape
= gfc_get_shape (e
->rank
);
4901 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4906 for (i
--; i
>= 0; i
--)
4907 mpz_clear (array
[i
]);
4911 /* Given a variable expression node, compute the rank of the expression by
4912 examining the base symbol and any reference structures it may have. */
4915 expression_rank (gfc_expr
*e
)
4920 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4921 could lead to serious confusion... */
4922 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4926 if (e
->expr_type
== EXPR_ARRAY
)
4928 /* Constructors can have a rank different from one via RESHAPE(). */
4930 if (e
->symtree
== NULL
)
4936 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4937 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4943 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4945 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4946 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4947 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4949 if (ref
->type
!= REF_ARRAY
)
4952 if (ref
->u
.ar
.type
== AR_FULL
)
4954 rank
= ref
->u
.ar
.as
->rank
;
4958 if (ref
->u
.ar
.type
== AR_SECTION
)
4960 /* Figure out the rank of the section. */
4962 gfc_internal_error ("expression_rank(): Two array specs");
4964 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4965 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4966 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4976 expression_shape (e
);
4981 add_caf_get_intrinsic (gfc_expr
*e
)
4983 gfc_expr
*wrapper
, *tmp_expr
;
4987 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4988 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4993 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4994 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4997 tmp_expr
= XCNEW (gfc_expr
);
4999 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5000 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5001 wrapper
->ts
= e
->ts
;
5002 wrapper
->rank
= e
->rank
;
5004 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5011 remove_caf_get_intrinsic (gfc_expr
*e
)
5013 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5014 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5015 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5016 e
->value
.function
.actual
->expr
= NULL
;
5017 gfc_free_actual_arglist (e
->value
.function
.actual
);
5018 gfc_free_shape (&e
->shape
, e
->rank
);
5024 /* Resolve a variable expression. */
5027 resolve_variable (gfc_expr
*e
)
5034 if (e
->symtree
== NULL
)
5036 sym
= e
->symtree
->n
.sym
;
5038 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5039 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5040 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5042 if (!actual_arg
|| inquiry_argument
)
5044 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5045 "be used as actual argument", sym
->name
, &e
->where
);
5049 /* TS 29113, 407b. */
5050 else if (e
->ts
.type
== BT_ASSUMED
)
5054 gfc_error ("Assumed-type variable %s at %L may only be used "
5055 "as actual argument", sym
->name
, &e
->where
);
5058 else if (inquiry_argument
&& !first_actual_arg
)
5060 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5061 for all inquiry functions in resolve_function; the reason is
5062 that the function-name resolution happens too late in that
5064 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5065 "an inquiry function shall be the first argument",
5066 sym
->name
, &e
->where
);
5070 /* TS 29113, C535b. */
5071 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5072 && CLASS_DATA (sym
)->as
5073 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5074 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5075 && sym
->as
->type
== AS_ASSUMED_RANK
))
5079 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5080 "actual argument", sym
->name
, &e
->where
);
5083 else if (inquiry_argument
&& !first_actual_arg
)
5085 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5086 for all inquiry functions in resolve_function; the reason is
5087 that the function-name resolution happens too late in that
5089 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5090 "to an inquiry function shall be the first argument",
5091 sym
->name
, &e
->where
);
5096 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5097 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5098 && e
->ref
->next
== NULL
))
5100 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5101 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5104 /* TS 29113, 407b. */
5105 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5106 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5107 && e
->ref
->next
== NULL
))
5109 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5110 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5114 /* TS 29113, C535b. */
5115 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5116 && CLASS_DATA (sym
)->as
5117 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5118 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5119 && sym
->as
->type
== AS_ASSUMED_RANK
))
5121 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5122 && e
->ref
->next
== NULL
))
5124 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5125 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5129 /* For variables that are used in an associate (target => object) where
5130 the object's basetype is array valued while the target is scalar,
5131 the ts' type of the component refs is still array valued, which
5132 can't be translated that way. */
5133 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5134 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5135 && CLASS_DATA (sym
->assoc
->target
)->as
)
5137 gfc_ref
*ref
= e
->ref
;
5143 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5144 /* Stop the loop. */
5154 /* If this is an associate-name, it may be parsed with an array reference
5155 in error even though the target is scalar. Fail directly in this case.
5156 TODO Understand why class scalar expressions must be excluded. */
5157 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5159 if (sym
->ts
.type
== BT_CLASS
)
5160 gfc_fix_class_refs (e
);
5161 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5165 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5166 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5168 /* On the other hand, the parser may not have known this is an array;
5169 in this case, we have to add a FULL reference. */
5170 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5172 e
->ref
= gfc_get_ref ();
5173 e
->ref
->type
= REF_ARRAY
;
5174 e
->ref
->u
.ar
.type
= AR_FULL
;
5175 e
->ref
->u
.ar
.dimen
= 0;
5178 /* Like above, but for class types, where the checking whether an array
5179 ref is present is more complicated. Furthermore make sure not to add
5180 the full array ref to _vptr or _len refs. */
5181 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5182 && CLASS_DATA (sym
)->attr
.dimension
5183 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5185 gfc_ref
*ref
, *newref
;
5187 newref
= gfc_get_ref ();
5188 newref
->type
= REF_ARRAY
;
5189 newref
->u
.ar
.type
= AR_FULL
;
5190 newref
->u
.ar
.dimen
= 0;
5191 /* Because this is an associate var and the first ref either is a ref to
5192 the _data component or not, no traversal of the ref chain is
5193 needed. The array ref needs to be inserted after the _data ref,
5194 or when that is not present, which may happend for polymorphic
5195 types, then at the first position. */
5199 else if (ref
->type
== REF_COMPONENT
5200 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5202 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5204 newref
->next
= ref
->next
;
5208 /* Array ref present already. */
5209 gfc_free_ref_list (newref
);
5211 else if (ref
->type
== REF_ARRAY
)
5212 /* Array ref present already. */
5213 gfc_free_ref_list (newref
);
5221 if (e
->ref
&& !resolve_ref (e
))
5224 if (sym
->attr
.flavor
== FL_PROCEDURE
5225 && (!sym
->attr
.function
5226 || (sym
->attr
.function
&& sym
->result
5227 && sym
->result
->attr
.proc_pointer
5228 && !sym
->result
->attr
.function
)))
5230 e
->ts
.type
= BT_PROCEDURE
;
5231 goto resolve_procedure
;
5234 if (sym
->ts
.type
!= BT_UNKNOWN
)
5235 gfc_variable_attr (e
, &e
->ts
);
5236 else if (sym
->attr
.flavor
== FL_PROCEDURE
5237 && sym
->attr
.function
&& sym
->result
5238 && sym
->result
->ts
.type
!= BT_UNKNOWN
5239 && sym
->result
->attr
.proc_pointer
)
5240 e
->ts
= sym
->result
->ts
;
5243 /* Must be a simple variable reference. */
5244 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5249 if (check_assumed_size_reference (sym
, e
))
5252 /* Deal with forward references to entries during gfc_resolve_code, to
5253 satisfy, at least partially, 12.5.2.5. */
5254 if (gfc_current_ns
->entries
5255 && current_entry_id
== sym
->entry_id
5258 && cs_base
->current
->op
!= EXEC_ENTRY
)
5260 gfc_entry_list
*entry
;
5261 gfc_formal_arglist
*formal
;
5263 bool seen
, saved_specification_expr
;
5265 /* If the symbol is a dummy... */
5266 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5268 entry
= gfc_current_ns
->entries
;
5271 /* ...test if the symbol is a parameter of previous entries. */
5272 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5273 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5275 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5282 /* If it has not been seen as a dummy, this is an error. */
5285 if (specification_expr
)
5286 gfc_error ("Variable %qs, used in a specification expression"
5287 ", is referenced at %L before the ENTRY statement "
5288 "in which it is a parameter",
5289 sym
->name
, &cs_base
->current
->loc
);
5291 gfc_error ("Variable %qs is used at %L before the ENTRY "
5292 "statement in which it is a parameter",
5293 sym
->name
, &cs_base
->current
->loc
);
5298 /* Now do the same check on the specification expressions. */
5299 saved_specification_expr
= specification_expr
;
5300 specification_expr
= true;
5301 if (sym
->ts
.type
== BT_CHARACTER
5302 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5306 for (n
= 0; n
< sym
->as
->rank
; n
++)
5308 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5310 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5313 specification_expr
= saved_specification_expr
;
5316 /* Update the symbol's entry level. */
5317 sym
->entry_id
= current_entry_id
+ 1;
5320 /* If a symbol has been host_associated mark it. This is used latter,
5321 to identify if aliasing is possible via host association. */
5322 if (sym
->attr
.flavor
== FL_VARIABLE
5323 && gfc_current_ns
->parent
5324 && (gfc_current_ns
->parent
== sym
->ns
5325 || (gfc_current_ns
->parent
->parent
5326 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5327 sym
->attr
.host_assoc
= 1;
5329 if (gfc_current_ns
->proc_name
5330 && sym
->attr
.dimension
5331 && (sym
->ns
!= gfc_current_ns
5332 || sym
->attr
.use_assoc
5333 || sym
->attr
.in_common
))
5334 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5337 if (t
&& !resolve_procedure_expression (e
))
5340 /* F2008, C617 and C1229. */
5341 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5342 && gfc_is_coindexed (e
))
5344 gfc_ref
*ref
, *ref2
= NULL
;
5346 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5348 if (ref
->type
== REF_COMPONENT
)
5350 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5354 for ( ; ref
; ref
= ref
->next
)
5355 if (ref
->type
== REF_COMPONENT
)
5358 /* Expression itself is not coindexed object. */
5359 if (ref
&& e
->ts
.type
== BT_CLASS
)
5361 gfc_error ("Polymorphic subobject of coindexed object at %L",
5366 /* Expression itself is coindexed object. */
5370 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5371 for ( ; c
; c
= c
->next
)
5372 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5374 gfc_error ("Coindexed object with polymorphic allocatable "
5375 "subcomponent at %L", &e
->where
);
5383 expression_rank (e
);
5385 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5386 add_caf_get_intrinsic (e
);
5392 /* Checks to see that the correct symbol has been host associated.
5393 The only situation where this arises is that in which a twice
5394 contained function is parsed after the host association is made.
5395 Therefore, on detecting this, change the symbol in the expression
5396 and convert the array reference into an actual arglist if the old
5397 symbol is a variable. */
5399 check_host_association (gfc_expr
*e
)
5401 gfc_symbol
*sym
, *old_sym
;
5405 gfc_actual_arglist
*arg
, *tail
= NULL
;
5406 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5408 /* If the expression is the result of substitution in
5409 interface.c(gfc_extend_expr) because there is no way in
5410 which the host association can be wrong. */
5411 if (e
->symtree
== NULL
5412 || e
->symtree
->n
.sym
== NULL
5413 || e
->user_operator
)
5416 old_sym
= e
->symtree
->n
.sym
;
5418 if (gfc_current_ns
->parent
5419 && old_sym
->ns
!= gfc_current_ns
)
5421 /* Use the 'USE' name so that renamed module symbols are
5422 correctly handled. */
5423 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5425 if (sym
&& old_sym
!= sym
5426 && sym
->ts
.type
== old_sym
->ts
.type
5427 && sym
->attr
.flavor
== FL_PROCEDURE
5428 && sym
->attr
.contained
)
5430 /* Clear the shape, since it might not be valid. */
5431 gfc_free_shape (&e
->shape
, e
->rank
);
5433 /* Give the expression the right symtree! */
5434 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5435 gcc_assert (st
!= NULL
);
5437 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5438 || e
->expr_type
== EXPR_FUNCTION
)
5440 /* Original was function so point to the new symbol, since
5441 the actual argument list is already attached to the
5443 e
->value
.function
.esym
= NULL
;
5448 /* Original was variable so convert array references into
5449 an actual arglist. This does not need any checking now
5450 since resolve_function will take care of it. */
5451 e
->value
.function
.actual
= NULL
;
5452 e
->expr_type
= EXPR_FUNCTION
;
5455 /* Ambiguity will not arise if the array reference is not
5456 the last reference. */
5457 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5458 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5461 gcc_assert (ref
->type
== REF_ARRAY
);
5463 /* Grab the start expressions from the array ref and
5464 copy them into actual arguments. */
5465 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5467 arg
= gfc_get_actual_arglist ();
5468 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5469 if (e
->value
.function
.actual
== NULL
)
5470 tail
= e
->value
.function
.actual
= arg
;
5478 /* Dump the reference list and set the rank. */
5479 gfc_free_ref_list (e
->ref
);
5481 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5484 gfc_resolve_expr (e
);
5488 /* This might have changed! */
5489 return e
->expr_type
== EXPR_FUNCTION
;
5494 gfc_resolve_character_operator (gfc_expr
*e
)
5496 gfc_expr
*op1
= e
->value
.op
.op1
;
5497 gfc_expr
*op2
= e
->value
.op
.op2
;
5498 gfc_expr
*e1
= NULL
;
5499 gfc_expr
*e2
= NULL
;
5501 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5503 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5504 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5505 else if (op1
->expr_type
== EXPR_CONSTANT
)
5506 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5507 op1
->value
.character
.length
);
5509 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5510 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5511 else if (op2
->expr_type
== EXPR_CONSTANT
)
5512 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5513 op2
->value
.character
.length
);
5515 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5525 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5526 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5527 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5528 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5529 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5535 /* Ensure that an character expression has a charlen and, if possible, a
5536 length expression. */
5539 fixup_charlen (gfc_expr
*e
)
5541 /* The cases fall through so that changes in expression type and the need
5542 for multiple fixes are picked up. In all circumstances, a charlen should
5543 be available for the middle end to hang a backend_decl on. */
5544 switch (e
->expr_type
)
5547 gfc_resolve_character_operator (e
);
5551 if (e
->expr_type
== EXPR_ARRAY
)
5552 gfc_resolve_character_array_constructor (e
);
5555 case EXPR_SUBSTRING
:
5556 if (!e
->ts
.u
.cl
&& e
->ref
)
5557 gfc_resolve_substring_charlen (e
);
5562 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5569 /* Update an actual argument to include the passed-object for type-bound
5570 procedures at the right position. */
5572 static gfc_actual_arglist
*
5573 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5576 gcc_assert (argpos
> 0);
5580 gfc_actual_arglist
* result
;
5582 result
= gfc_get_actual_arglist ();
5586 result
->name
= name
;
5592 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5594 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5599 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5602 extract_compcall_passed_object (gfc_expr
* e
)
5606 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5608 if (e
->value
.compcall
.base_object
)
5609 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5612 po
= gfc_get_expr ();
5613 po
->expr_type
= EXPR_VARIABLE
;
5614 po
->symtree
= e
->symtree
;
5615 po
->ref
= gfc_copy_ref (e
->ref
);
5616 po
->where
= e
->where
;
5619 if (!gfc_resolve_expr (po
))
5626 /* Update the arglist of an EXPR_COMPCALL expression to include the
5630 update_compcall_arglist (gfc_expr
* e
)
5633 gfc_typebound_proc
* tbp
;
5635 tbp
= e
->value
.compcall
.tbp
;
5640 po
= extract_compcall_passed_object (e
);
5644 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5650 gcc_assert (tbp
->pass_arg_num
> 0);
5651 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5659 /* Extract the passed object from a PPC call (a copy of it). */
5662 extract_ppc_passed_object (gfc_expr
*e
)
5667 po
= gfc_get_expr ();
5668 po
->expr_type
= EXPR_VARIABLE
;
5669 po
->symtree
= e
->symtree
;
5670 po
->ref
= gfc_copy_ref (e
->ref
);
5671 po
->where
= e
->where
;
5673 /* Remove PPC reference. */
5675 while ((*ref
)->next
)
5676 ref
= &(*ref
)->next
;
5677 gfc_free_ref_list (*ref
);
5680 if (!gfc_resolve_expr (po
))
5687 /* Update the actual arglist of a procedure pointer component to include the
5691 update_ppc_arglist (gfc_expr
* e
)
5695 gfc_typebound_proc
* tb
;
5697 ppc
= gfc_get_proc_ptr_comp (e
);
5705 else if (tb
->nopass
)
5708 po
= extract_ppc_passed_object (e
);
5715 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5720 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5722 gfc_error ("Base object for procedure-pointer component call at %L is of"
5723 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5727 gcc_assert (tb
->pass_arg_num
> 0);
5728 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5736 /* Check that the object a TBP is called on is valid, i.e. it must not be
5737 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5740 check_typebound_baseobject (gfc_expr
* e
)
5743 bool return_value
= false;
5745 base
= extract_compcall_passed_object (e
);
5749 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5751 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5755 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5757 gfc_error ("Base object for type-bound procedure call at %L is of"
5758 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5762 /* F08:C1230. If the procedure called is NOPASS,
5763 the base object must be scalar. */
5764 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5766 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5767 " be scalar", &e
->where
);
5771 return_value
= true;
5774 gfc_free_expr (base
);
5775 return return_value
;
5779 /* Resolve a call to a type-bound procedure, either function or subroutine,
5780 statically from the data in an EXPR_COMPCALL expression. The adapted
5781 arglist and the target-procedure symtree are returned. */
5784 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5785 gfc_actual_arglist
** actual
)
5787 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5788 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5790 /* Update the actual arglist for PASS. */
5791 if (!update_compcall_arglist (e
))
5794 *actual
= e
->value
.compcall
.actual
;
5795 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5797 gfc_free_ref_list (e
->ref
);
5799 e
->value
.compcall
.actual
= NULL
;
5801 /* If we find a deferred typebound procedure, check for derived types
5802 that an overriding typebound procedure has not been missed. */
5803 if (e
->value
.compcall
.name
5804 && !e
->value
.compcall
.tbp
->non_overridable
5805 && e
->value
.compcall
.base_object
5806 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5809 gfc_symbol
*derived
;
5811 /* Use the derived type of the base_object. */
5812 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5815 /* If necessary, go through the inheritance chain. */
5816 while (!st
&& derived
)
5818 /* Look for the typebound procedure 'name'. */
5819 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5820 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5821 e
->value
.compcall
.name
);
5823 derived
= gfc_get_derived_super_type (derived
);
5826 /* Now find the specific name in the derived type namespace. */
5827 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5828 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5829 derived
->ns
, 1, &st
);
5837 /* Get the ultimate declared type from an expression. In addition,
5838 return the last class/derived type reference and the copy of the
5839 reference list. If check_types is set true, derived types are
5840 identified as well as class references. */
5842 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5843 gfc_expr
*e
, bool check_types
)
5845 gfc_symbol
*declared
;
5852 *new_ref
= gfc_copy_ref (e
->ref
);
5854 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5856 if (ref
->type
!= REF_COMPONENT
)
5859 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5860 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
5861 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5863 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5869 if (declared
== NULL
)
5870 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5876 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5877 which of the specific bindings (if any) matches the arglist and transform
5878 the expression into a call of that binding. */
5881 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5883 gfc_typebound_proc
* genproc
;
5884 const char* genname
;
5886 gfc_symbol
*derived
;
5888 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5889 genname
= e
->value
.compcall
.name
;
5890 genproc
= e
->value
.compcall
.tbp
;
5892 if (!genproc
->is_generic
)
5895 /* Try the bindings on this type and in the inheritance hierarchy. */
5896 for (; genproc
; genproc
= genproc
->overridden
)
5900 gcc_assert (genproc
->is_generic
);
5901 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5904 gfc_actual_arglist
* args
;
5907 gcc_assert (g
->specific
);
5909 if (g
->specific
->error
)
5912 target
= g
->specific
->u
.specific
->n
.sym
;
5914 /* Get the right arglist by handling PASS/NOPASS. */
5915 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5916 if (!g
->specific
->nopass
)
5919 po
= extract_compcall_passed_object (e
);
5922 gfc_free_actual_arglist (args
);
5926 gcc_assert (g
->specific
->pass_arg_num
> 0);
5927 gcc_assert (!g
->specific
->error
);
5928 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5929 g
->specific
->pass_arg
);
5931 resolve_actual_arglist (args
, target
->attr
.proc
,
5932 is_external_proc (target
)
5933 && gfc_sym_get_dummy_args (target
) == NULL
);
5935 /* Check if this arglist matches the formal. */
5936 matches
= gfc_arglist_matches_symbol (&args
, target
);
5938 /* Clean up and break out of the loop if we've found it. */
5939 gfc_free_actual_arglist (args
);
5942 e
->value
.compcall
.tbp
= g
->specific
;
5943 genname
= g
->specific_st
->name
;
5944 /* Pass along the name for CLASS methods, where the vtab
5945 procedure pointer component has to be referenced. */
5953 /* Nothing matching found! */
5954 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5955 " %qs at %L", genname
, &e
->where
);
5959 /* Make sure that we have the right specific instance for the name. */
5960 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5962 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5964 e
->value
.compcall
.tbp
= st
->n
.tb
;
5970 /* Resolve a call to a type-bound subroutine. */
5973 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5975 gfc_actual_arglist
* newactual
;
5976 gfc_symtree
* target
;
5978 /* Check that's really a SUBROUTINE. */
5979 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5981 gfc_error ("%qs at %L should be a SUBROUTINE",
5982 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5986 if (!check_typebound_baseobject (c
->expr1
))
5989 /* Pass along the name for CLASS methods, where the vtab
5990 procedure pointer component has to be referenced. */
5992 *name
= c
->expr1
->value
.compcall
.name
;
5994 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5997 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5999 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6001 /* Transform into an ordinary EXEC_CALL for now. */
6003 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6006 c
->ext
.actual
= newactual
;
6007 c
->symtree
= target
;
6008 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6010 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6012 gfc_free_expr (c
->expr1
);
6013 c
->expr1
= gfc_get_expr ();
6014 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6015 c
->expr1
->symtree
= target
;
6016 c
->expr1
->where
= c
->loc
;
6018 return resolve_call (c
);
6022 /* Resolve a component-call expression. */
6024 resolve_compcall (gfc_expr
* e
, const char **name
)
6026 gfc_actual_arglist
* newactual
;
6027 gfc_symtree
* target
;
6029 /* Check that's really a FUNCTION. */
6030 if (!e
->value
.compcall
.tbp
->function
)
6032 gfc_error ("%qs at %L should be a FUNCTION",
6033 e
->value
.compcall
.name
, &e
->where
);
6037 /* These must not be assign-calls! */
6038 gcc_assert (!e
->value
.compcall
.assign
);
6040 if (!check_typebound_baseobject (e
))
6043 /* Pass along the name for CLASS methods, where the vtab
6044 procedure pointer component has to be referenced. */
6046 *name
= e
->value
.compcall
.name
;
6048 if (!resolve_typebound_generic_call (e
, name
))
6050 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6052 /* Take the rank from the function's symbol. */
6053 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6054 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6056 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6057 arglist to the TBP's binding target. */
6059 if (!resolve_typebound_static (e
, &target
, &newactual
))
6062 e
->value
.function
.actual
= newactual
;
6063 e
->value
.function
.name
= NULL
;
6064 e
->value
.function
.esym
= target
->n
.sym
;
6065 e
->value
.function
.isym
= NULL
;
6066 e
->symtree
= target
;
6067 e
->ts
= target
->n
.sym
->ts
;
6068 e
->expr_type
= EXPR_FUNCTION
;
6070 /* Resolution is not necessary if this is a class subroutine; this
6071 function only has to identify the specific proc. Resolution of
6072 the call will be done next in resolve_typebound_call. */
6073 return gfc_resolve_expr (e
);
6077 static bool resolve_fl_derived (gfc_symbol
*sym
);
6080 /* Resolve a typebound function, or 'method'. First separate all
6081 the non-CLASS references by calling resolve_compcall directly. */
6084 resolve_typebound_function (gfc_expr
* e
)
6086 gfc_symbol
*declared
;
6098 /* Deal with typebound operators for CLASS objects. */
6099 expr
= e
->value
.compcall
.base_object
;
6100 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6101 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6103 /* If the base_object is not a variable, the corresponding actual
6104 argument expression must be stored in e->base_expression so
6105 that the corresponding tree temporary can be used as the base
6106 object in gfc_conv_procedure_call. */
6107 if (expr
->expr_type
!= EXPR_VARIABLE
)
6109 gfc_actual_arglist
*args
;
6111 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6113 if (expr
== args
->expr
)
6118 /* Since the typebound operators are generic, we have to ensure
6119 that any delays in resolution are corrected and that the vtab
6122 declared
= ts
.u
.derived
;
6123 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6124 if (c
->ts
.u
.derived
== NULL
)
6125 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6127 if (!resolve_compcall (e
, &name
))
6130 /* Use the generic name if it is there. */
6131 name
= name
? name
: e
->value
.function
.esym
->name
;
6132 e
->symtree
= expr
->symtree
;
6133 e
->ref
= gfc_copy_ref (expr
->ref
);
6134 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6136 /* Trim away the extraneous references that emerge from nested
6137 use of interface.c (extend_expr). */
6138 if (class_ref
&& class_ref
->next
)
6140 gfc_free_ref_list (class_ref
->next
);
6141 class_ref
->next
= NULL
;
6143 else if (e
->ref
&& !class_ref
)
6145 gfc_free_ref_list (e
->ref
);
6149 gfc_add_vptr_component (e
);
6150 gfc_add_component_ref (e
, name
);
6151 e
->value
.function
.esym
= NULL
;
6152 if (expr
->expr_type
!= EXPR_VARIABLE
)
6153 e
->base_expr
= expr
;
6158 return resolve_compcall (e
, NULL
);
6160 if (!resolve_ref (e
))
6163 /* Get the CLASS declared type. */
6164 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6166 if (!resolve_fl_derived (declared
))
6169 /* Weed out cases of the ultimate component being a derived type. */
6170 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6171 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6173 gfc_free_ref_list (new_ref
);
6174 return resolve_compcall (e
, NULL
);
6177 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6178 declared
= c
->ts
.u
.derived
;
6180 /* Treat the call as if it is a typebound procedure, in order to roll
6181 out the correct name for the specific function. */
6182 if (!resolve_compcall (e
, &name
))
6184 gfc_free_ref_list (new_ref
);
6191 /* Convert the expression to a procedure pointer component call. */
6192 e
->value
.function
.esym
= NULL
;
6198 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6199 gfc_add_vptr_component (e
);
6200 gfc_add_component_ref (e
, name
);
6202 /* Recover the typespec for the expression. This is really only
6203 necessary for generic procedures, where the additional call
6204 to gfc_add_component_ref seems to throw the collection of the
6205 correct typespec. */
6209 gfc_free_ref_list (new_ref
);
6214 /* Resolve a typebound subroutine, or 'method'. First separate all
6215 the non-CLASS references by calling resolve_typebound_call
6219 resolve_typebound_subroutine (gfc_code
*code
)
6221 gfc_symbol
*declared
;
6231 st
= code
->expr1
->symtree
;
6233 /* Deal with typebound operators for CLASS objects. */
6234 expr
= code
->expr1
->value
.compcall
.base_object
;
6235 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6236 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6238 /* If the base_object is not a variable, the corresponding actual
6239 argument expression must be stored in e->base_expression so
6240 that the corresponding tree temporary can be used as the base
6241 object in gfc_conv_procedure_call. */
6242 if (expr
->expr_type
!= EXPR_VARIABLE
)
6244 gfc_actual_arglist
*args
;
6246 args
= code
->expr1
->value
.function
.actual
;
6247 for (; args
; args
= args
->next
)
6248 if (expr
== args
->expr
)
6252 /* Since the typebound operators are generic, we have to ensure
6253 that any delays in resolution are corrected and that the vtab
6255 declared
= expr
->ts
.u
.derived
;
6256 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6257 if (c
->ts
.u
.derived
== NULL
)
6258 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6260 if (!resolve_typebound_call (code
, &name
, NULL
))
6263 /* Use the generic name if it is there. */
6264 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6265 code
->expr1
->symtree
= expr
->symtree
;
6266 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6268 /* Trim away the extraneous references that emerge from nested
6269 use of interface.c (extend_expr). */
6270 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6271 if (class_ref
&& class_ref
->next
)
6273 gfc_free_ref_list (class_ref
->next
);
6274 class_ref
->next
= NULL
;
6276 else if (code
->expr1
->ref
&& !class_ref
)
6278 gfc_free_ref_list (code
->expr1
->ref
);
6279 code
->expr1
->ref
= NULL
;
6282 /* Now use the procedure in the vtable. */
6283 gfc_add_vptr_component (code
->expr1
);
6284 gfc_add_component_ref (code
->expr1
, name
);
6285 code
->expr1
->value
.function
.esym
= NULL
;
6286 if (expr
->expr_type
!= EXPR_VARIABLE
)
6287 code
->expr1
->base_expr
= expr
;
6292 return resolve_typebound_call (code
, NULL
, NULL
);
6294 if (!resolve_ref (code
->expr1
))
6297 /* Get the CLASS declared type. */
6298 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6300 /* Weed out cases of the ultimate component being a derived type. */
6301 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6302 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6304 gfc_free_ref_list (new_ref
);
6305 return resolve_typebound_call (code
, NULL
, NULL
);
6308 if (!resolve_typebound_call (code
, &name
, &overridable
))
6310 gfc_free_ref_list (new_ref
);
6313 ts
= code
->expr1
->ts
;
6317 /* Convert the expression to a procedure pointer component call. */
6318 code
->expr1
->value
.function
.esym
= NULL
;
6319 code
->expr1
->symtree
= st
;
6322 code
->expr1
->ref
= new_ref
;
6324 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6325 gfc_add_vptr_component (code
->expr1
);
6326 gfc_add_component_ref (code
->expr1
, name
);
6328 /* Recover the typespec for the expression. This is really only
6329 necessary for generic procedures, where the additional call
6330 to gfc_add_component_ref seems to throw the collection of the
6331 correct typespec. */
6332 code
->expr1
->ts
= ts
;
6335 gfc_free_ref_list (new_ref
);
6341 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6344 resolve_ppc_call (gfc_code
* c
)
6346 gfc_component
*comp
;
6348 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6349 gcc_assert (comp
!= NULL
);
6351 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6352 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6354 if (!comp
->attr
.subroutine
)
6355 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6357 if (!resolve_ref (c
->expr1
))
6360 if (!update_ppc_arglist (c
->expr1
))
6363 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6365 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6366 !(comp
->ts
.interface
6367 && comp
->ts
.interface
->formal
)))
6370 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6373 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6379 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6382 resolve_expr_ppc (gfc_expr
* e
)
6384 gfc_component
*comp
;
6386 comp
= gfc_get_proc_ptr_comp (e
);
6387 gcc_assert (comp
!= NULL
);
6389 /* Convert to EXPR_FUNCTION. */
6390 e
->expr_type
= EXPR_FUNCTION
;
6391 e
->value
.function
.isym
= NULL
;
6392 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6394 if (comp
->as
!= NULL
)
6395 e
->rank
= comp
->as
->rank
;
6397 if (!comp
->attr
.function
)
6398 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6400 if (!resolve_ref (e
))
6403 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6404 !(comp
->ts
.interface
6405 && comp
->ts
.interface
->formal
)))
6408 if (!update_ppc_arglist (e
))
6411 if (!check_pure_function(e
))
6414 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6421 gfc_is_expandable_expr (gfc_expr
*e
)
6423 gfc_constructor
*con
;
6425 if (e
->expr_type
== EXPR_ARRAY
)
6427 /* Traverse the constructor looking for variables that are flavor
6428 parameter. Parameters must be expanded since they are fully used at
6430 con
= gfc_constructor_first (e
->value
.constructor
);
6431 for (; con
; con
= gfc_constructor_next (con
))
6433 if (con
->expr
->expr_type
== EXPR_VARIABLE
6434 && con
->expr
->symtree
6435 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6436 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6438 if (con
->expr
->expr_type
== EXPR_ARRAY
6439 && gfc_is_expandable_expr (con
->expr
))
6447 /* Resolve an expression. That is, make sure that types of operands agree
6448 with their operators, intrinsic operators are converted to function calls
6449 for overloaded types and unresolved function references are resolved. */
6452 gfc_resolve_expr (gfc_expr
*e
)
6455 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6460 /* inquiry_argument only applies to variables. */
6461 inquiry_save
= inquiry_argument
;
6462 actual_arg_save
= actual_arg
;
6463 first_actual_arg_save
= first_actual_arg
;
6465 if (e
->expr_type
!= EXPR_VARIABLE
)
6467 inquiry_argument
= false;
6469 first_actual_arg
= false;
6472 switch (e
->expr_type
)
6475 t
= resolve_operator (e
);
6481 if (check_host_association (e
))
6482 t
= resolve_function (e
);
6484 t
= resolve_variable (e
);
6486 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6487 && e
->ref
->type
!= REF_SUBSTRING
)
6488 gfc_resolve_substring_charlen (e
);
6493 t
= resolve_typebound_function (e
);
6496 case EXPR_SUBSTRING
:
6497 t
= resolve_ref (e
);
6506 t
= resolve_expr_ppc (e
);
6511 if (!resolve_ref (e
))
6514 t
= gfc_resolve_array_constructor (e
);
6515 /* Also try to expand a constructor. */
6518 expression_rank (e
);
6519 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6520 gfc_expand_constructor (e
, false);
6523 /* This provides the opportunity for the length of constructors with
6524 character valued function elements to propagate the string length
6525 to the expression. */
6526 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6528 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6529 here rather then add a duplicate test for it above. */
6530 gfc_expand_constructor (e
, false);
6531 t
= gfc_resolve_character_array_constructor (e
);
6536 case EXPR_STRUCTURE
:
6537 t
= resolve_ref (e
);
6541 t
= resolve_structure_cons (e
, 0);
6545 t
= gfc_simplify_expr (e
, 0);
6549 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6552 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6555 inquiry_argument
= inquiry_save
;
6556 actual_arg
= actual_arg_save
;
6557 first_actual_arg
= first_actual_arg_save
;
6563 /* Resolve an expression from an iterator. They must be scalar and have
6564 INTEGER or (optionally) REAL type. */
6567 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6568 const char *name_msgid
)
6570 if (!gfc_resolve_expr (expr
))
6573 if (expr
->rank
!= 0)
6575 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6579 if (expr
->ts
.type
!= BT_INTEGER
)
6581 if (expr
->ts
.type
== BT_REAL
)
6584 return gfc_notify_std (GFC_STD_F95_DEL
,
6585 "%s at %L must be integer",
6586 _(name_msgid
), &expr
->where
);
6589 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6596 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6604 /* Resolve the expressions in an iterator structure. If REAL_OK is
6605 false allow only INTEGER type iterators, otherwise allow REAL types.
6606 Set own_scope to true for ac-implied-do and data-implied-do as those
6607 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6610 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6612 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6615 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6616 _("iterator variable")))
6619 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6620 "Start expression in DO loop"))
6623 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6624 "End expression in DO loop"))
6627 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6628 "Step expression in DO loop"))
6631 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6633 if ((iter
->step
->ts
.type
== BT_INTEGER
6634 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6635 || (iter
->step
->ts
.type
== BT_REAL
6636 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6638 gfc_error ("Step expression in DO loop at %L cannot be zero",
6639 &iter
->step
->where
);
6644 /* Convert start, end, and step to the same type as var. */
6645 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6646 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6647 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6649 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6650 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6651 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6653 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6654 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6655 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
6657 if (iter
->start
->expr_type
== EXPR_CONSTANT
6658 && iter
->end
->expr_type
== EXPR_CONSTANT
6659 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6662 if (iter
->start
->ts
.type
== BT_INTEGER
)
6664 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6665 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6669 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6670 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6672 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6673 gfc_warning (OPT_Wzerotrip
,
6674 "DO loop at %L will be executed zero times",
6675 &iter
->step
->where
);
6678 if (iter
->end
->expr_type
== EXPR_CONSTANT
6679 && iter
->end
->ts
.type
== BT_INTEGER
6680 && iter
->step
->expr_type
== EXPR_CONSTANT
6681 && iter
->step
->ts
.type
== BT_INTEGER
6682 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
6683 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
6685 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
6686 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
6688 if (is_step_positive
6689 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
6690 gfc_warning (OPT_Wundefined_do_loop
,
6691 "DO loop at %L is undefined as it overflows",
6692 &iter
->step
->where
);
6693 else if (!is_step_positive
6694 && mpz_cmp (iter
->end
->value
.integer
,
6695 gfc_integer_kinds
[k
].min_int
) == 0)
6696 gfc_warning (OPT_Wundefined_do_loop
,
6697 "DO loop at %L is undefined as it underflows",
6698 &iter
->step
->where
);
6705 /* Traversal function for find_forall_index. f == 2 signals that
6706 that variable itself is not to be checked - only the references. */
6709 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6711 if (expr
->expr_type
!= EXPR_VARIABLE
)
6714 /* A scalar assignment */
6715 if (!expr
->ref
|| *f
== 1)
6717 if (expr
->symtree
->n
.sym
== sym
)
6729 /* Check whether the FORALL index appears in the expression or not.
6730 Returns true if SYM is found in EXPR. */
6733 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6735 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6742 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6743 to be a scalar INTEGER variable. The subscripts and stride are scalar
6744 INTEGERs, and if stride is a constant it must be nonzero.
6745 Furthermore "A subscript or stride in a forall-triplet-spec shall
6746 not contain a reference to any index-name in the
6747 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6750 resolve_forall_iterators (gfc_forall_iterator
*it
)
6752 gfc_forall_iterator
*iter
, *iter2
;
6754 for (iter
= it
; iter
; iter
= iter
->next
)
6756 if (gfc_resolve_expr (iter
->var
)
6757 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6758 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6761 if (gfc_resolve_expr (iter
->start
)
6762 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6763 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6764 &iter
->start
->where
);
6765 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6766 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6768 if (gfc_resolve_expr (iter
->end
)
6769 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6770 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6772 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6773 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6775 if (gfc_resolve_expr (iter
->stride
))
6777 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6778 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6779 &iter
->stride
->where
, "INTEGER");
6781 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6782 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6783 gfc_error ("FORALL stride expression at %L cannot be zero",
6784 &iter
->stride
->where
);
6786 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6787 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6790 for (iter
= it
; iter
; iter
= iter
->next
)
6791 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6793 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6794 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6795 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6796 gfc_error ("FORALL index %qs may not appear in triplet "
6797 "specification at %L", iter
->var
->symtree
->name
,
6798 &iter2
->start
->where
);
6803 /* Given a pointer to a symbol that is a derived type, see if it's
6804 inaccessible, i.e. if it's defined in another module and the components are
6805 PRIVATE. The search is recursive if necessary. Returns zero if no
6806 inaccessible components are found, nonzero otherwise. */
6809 derived_inaccessible (gfc_symbol
*sym
)
6813 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6816 for (c
= sym
->components
; c
; c
= c
->next
)
6818 /* Prevent an infinite loop through this function. */
6819 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
6820 && sym
== c
->ts
.u
.derived
)
6823 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6831 /* Resolve the argument of a deallocate expression. The expression must be
6832 a pointer or a full array. */
6835 resolve_deallocate_expr (gfc_expr
*e
)
6837 symbol_attribute attr
;
6838 int allocatable
, pointer
;
6844 if (!gfc_resolve_expr (e
))
6847 if (e
->expr_type
!= EXPR_VARIABLE
)
6850 sym
= e
->symtree
->n
.sym
;
6851 unlimited
= UNLIMITED_POLY(sym
);
6853 if (sym
->ts
.type
== BT_CLASS
)
6855 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6856 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6860 allocatable
= sym
->attr
.allocatable
;
6861 pointer
= sym
->attr
.pointer
;
6863 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6868 if (ref
->u
.ar
.type
!= AR_FULL
6869 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6870 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6875 c
= ref
->u
.c
.component
;
6876 if (c
->ts
.type
== BT_CLASS
)
6878 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6879 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6883 allocatable
= c
->attr
.allocatable
;
6884 pointer
= c
->attr
.pointer
;
6894 attr
= gfc_expr_attr (e
);
6896 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6899 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6905 if (gfc_is_coindexed (e
))
6907 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6912 && !gfc_check_vardef_context (e
, true, true, false,
6913 _("DEALLOCATE object")))
6915 if (!gfc_check_vardef_context (e
, false, true, false,
6916 _("DEALLOCATE object")))
6923 /* Returns true if the expression e contains a reference to the symbol sym. */
6925 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6927 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6934 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6936 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6940 /* Given the expression node e for an allocatable/pointer of derived type to be
6941 allocated, get the expression node to be initialized afterwards (needed for
6942 derived types with default initializers, and derived types with allocatable
6943 components that need nullification.) */
6946 gfc_expr_to_initialize (gfc_expr
*e
)
6952 result
= gfc_copy_expr (e
);
6954 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6955 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6956 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6958 ref
->u
.ar
.type
= AR_FULL
;
6960 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6961 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6966 gfc_free_shape (&result
->shape
, result
->rank
);
6968 /* Recalculate rank, shape, etc. */
6969 gfc_resolve_expr (result
);
6974 /* If the last ref of an expression is an array ref, return a copy of the
6975 expression with that one removed. Otherwise, a copy of the original
6976 expression. This is used for allocate-expressions and pointer assignment
6977 LHS, where there may be an array specification that needs to be stripped
6978 off when using gfc_check_vardef_context. */
6981 remove_last_array_ref (gfc_expr
* e
)
6986 e2
= gfc_copy_expr (e
);
6987 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6988 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6990 gfc_free_ref_list (*r
);
6999 /* Used in resolve_allocate_expr to check that a allocation-object and
7000 a source-expr are conformable. This does not catch all possible
7001 cases; in particular a runtime checking is needed. */
7004 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7007 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7009 /* First compare rank. */
7010 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7011 || (!tail
&& e1
->rank
!= e2
->rank
))
7013 gfc_error ("Source-expr at %L must be scalar or have the "
7014 "same rank as the allocate-object at %L",
7015 &e1
->where
, &e2
->where
);
7026 for (i
= 0; i
< e1
->rank
; i
++)
7028 if (tail
->u
.ar
.start
[i
] == NULL
)
7031 if (tail
->u
.ar
.end
[i
])
7033 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7034 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7035 mpz_add_ui (s
, s
, 1);
7039 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7042 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7044 gfc_error ("Source-expr at %L and allocate-object at %L must "
7045 "have the same shape", &e1
->where
, &e2
->where
);
7058 /* Resolve the expression in an ALLOCATE statement, doing the additional
7059 checks to see whether the expression is OK or not. The expression must
7060 have a trailing array reference that gives the size of the array. */
7063 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7065 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7069 symbol_attribute attr
;
7070 gfc_ref
*ref
, *ref2
;
7073 gfc_symbol
*sym
= NULL
;
7078 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7079 checking of coarrays. */
7080 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7081 if (ref
->next
== NULL
)
7084 if (ref
&& ref
->type
== REF_ARRAY
)
7085 ref
->u
.ar
.in_allocate
= true;
7087 if (!gfc_resolve_expr (e
))
7090 /* Make sure the expression is allocatable or a pointer. If it is
7091 pointer, the next-to-last reference must be a pointer. */
7095 sym
= e
->symtree
->n
.sym
;
7097 /* Check whether ultimate component is abstract and CLASS. */
7100 /* Is the allocate-object unlimited polymorphic? */
7101 unlimited
= UNLIMITED_POLY(e
);
7103 if (e
->expr_type
!= EXPR_VARIABLE
)
7106 attr
= gfc_expr_attr (e
);
7107 pointer
= attr
.pointer
;
7108 dimension
= attr
.dimension
;
7109 codimension
= attr
.codimension
;
7113 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7115 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7116 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7117 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7118 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7119 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7123 allocatable
= sym
->attr
.allocatable
;
7124 pointer
= sym
->attr
.pointer
;
7125 dimension
= sym
->attr
.dimension
;
7126 codimension
= sym
->attr
.codimension
;
7131 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7136 if (ref
->u
.ar
.codimen
> 0)
7139 for (n
= ref
->u
.ar
.dimen
;
7140 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7141 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7148 if (ref
->next
!= NULL
)
7156 gfc_error ("Coindexed allocatable object at %L",
7161 c
= ref
->u
.c
.component
;
7162 if (c
->ts
.type
== BT_CLASS
)
7164 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7165 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7166 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7167 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7168 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7172 allocatable
= c
->attr
.allocatable
;
7173 pointer
= c
->attr
.pointer
;
7174 dimension
= c
->attr
.dimension
;
7175 codimension
= c
->attr
.codimension
;
7176 is_abstract
= c
->attr
.abstract
;
7188 /* Check for F08:C628. */
7189 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7191 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7196 /* Some checks for the SOURCE tag. */
7199 /* Check F03:C631. */
7200 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7202 gfc_error ("Type of entity at %L is type incompatible with "
7203 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7207 /* Check F03:C632 and restriction following Note 6.18. */
7208 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7211 /* Check F03:C633. */
7212 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7214 gfc_error ("The allocate-object at %L and the source-expr at %L "
7215 "shall have the same kind type parameter",
7216 &e
->where
, &code
->expr3
->where
);
7220 /* Check F2008, C642. */
7221 if (code
->expr3
->ts
.type
== BT_DERIVED
7222 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7223 || (code
->expr3
->ts
.u
.derived
->from_intmod
7224 == INTMOD_ISO_FORTRAN_ENV
7225 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7226 == ISOFORTRAN_LOCK_TYPE
)))
7228 gfc_error ("The source-expr at %L shall neither be of type "
7229 "LOCK_TYPE nor have a LOCK_TYPE component if "
7230 "allocate-object at %L is a coarray",
7231 &code
->expr3
->where
, &e
->where
);
7235 /* Check TS18508, C702/C703. */
7236 if (code
->expr3
->ts
.type
== BT_DERIVED
7237 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7238 || (code
->expr3
->ts
.u
.derived
->from_intmod
7239 == INTMOD_ISO_FORTRAN_ENV
7240 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7241 == ISOFORTRAN_EVENT_TYPE
)))
7243 gfc_error ("The source-expr at %L shall neither be of type "
7244 "EVENT_TYPE nor have a EVENT_TYPE component if "
7245 "allocate-object at %L is a coarray",
7246 &code
->expr3
->where
, &e
->where
);
7251 /* Check F08:C629. */
7252 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7255 gcc_assert (e
->ts
.type
== BT_CLASS
);
7256 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7257 "type-spec or source-expr", sym
->name
, &e
->where
);
7261 /* Check F08:C632. */
7262 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7263 && !UNLIMITED_POLY (e
))
7265 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7266 code
->ext
.alloc
.ts
.u
.cl
->length
);
7267 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7269 gfc_error ("Allocating %s at %L with type-spec requires the same "
7270 "character-length parameter as in the declaration",
7271 sym
->name
, &e
->where
);
7276 /* In the variable definition context checks, gfc_expr_attr is used
7277 on the expression. This is fooled by the array specification
7278 present in e, thus we have to eliminate that one temporarily. */
7279 e2
= remove_last_array_ref (e
);
7282 t
= gfc_check_vardef_context (e2
, true, true, false,
7283 _("ALLOCATE object"));
7285 t
= gfc_check_vardef_context (e2
, false, true, false,
7286 _("ALLOCATE object"));
7291 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7292 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7294 /* For class arrays, the initialization with SOURCE is done
7295 using _copy and trans_call. It is convenient to exploit that
7296 when the allocated type is different from the declared type but
7297 no SOURCE exists by setting expr3. */
7298 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7300 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7301 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7302 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7304 /* We have to zero initialize the integer variable. */
7305 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7308 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7310 /* Make sure the vtab symbol is present when
7311 the module variables are generated. */
7312 gfc_typespec ts
= e
->ts
;
7314 ts
= code
->expr3
->ts
;
7315 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7316 ts
= code
->ext
.alloc
.ts
;
7318 /* Finding the vtab also publishes the type's symbol. Therefore this
7319 statement is necessary. */
7320 gfc_find_derived_vtab (ts
.u
.derived
);
7322 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7324 /* Again, make sure the vtab symbol is present when
7325 the module variables are generated. */
7326 gfc_typespec
*ts
= NULL
;
7328 ts
= &code
->expr3
->ts
;
7330 ts
= &code
->ext
.alloc
.ts
;
7334 /* Finding the vtab also publishes the type's symbol. Therefore this
7335 statement is necessary. */
7339 if (dimension
== 0 && codimension
== 0)
7342 /* Make sure the last reference node is an array specification. */
7344 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7345 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7350 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7351 "in ALLOCATE statement at %L", &e
->where
))
7353 if (code
->expr3
->rank
!= 0)
7354 *array_alloc_wo_spec
= true;
7357 gfc_error ("Array specification or array-valued SOURCE= "
7358 "expression required in ALLOCATE statement at %L",
7365 gfc_error ("Array specification required in ALLOCATE statement "
7366 "at %L", &e
->where
);
7371 /* Make sure that the array section reference makes sense in the
7372 context of an ALLOCATE specification. */
7377 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7378 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7380 gfc_error ("Coarray specification required in ALLOCATE statement "
7381 "at %L", &e
->where
);
7385 for (i
= 0; i
< ar
->dimen
; i
++)
7387 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7390 switch (ar
->dimen_type
[i
])
7396 if (ar
->start
[i
] != NULL
7397 && ar
->end
[i
] != NULL
7398 && ar
->stride
[i
] == NULL
)
7406 case DIMEN_THIS_IMAGE
:
7407 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7413 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7415 sym
= a
->expr
->symtree
->n
.sym
;
7417 /* TODO - check derived type components. */
7418 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7421 if ((ar
->start
[i
] != NULL
7422 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7423 || (ar
->end
[i
] != NULL
7424 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7426 gfc_error ("%qs must not appear in the array specification at "
7427 "%L in the same ALLOCATE statement where it is "
7428 "itself allocated", sym
->name
, &ar
->where
);
7434 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7436 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7437 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7439 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7441 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7442 "statement at %L", &e
->where
);
7448 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7449 && ar
->stride
[i
] == NULL
)
7452 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7466 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7468 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7469 gfc_alloc
*a
, *p
, *q
;
7472 errmsg
= code
->expr2
;
7474 /* Check the stat variable. */
7477 gfc_check_vardef_context (stat
, false, false, false,
7478 _("STAT variable"));
7480 if ((stat
->ts
.type
!= BT_INTEGER
7481 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7482 || stat
->ref
->type
== REF_COMPONENT
)))
7484 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7485 "variable", &stat
->where
);
7487 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7488 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7490 gfc_ref
*ref1
, *ref2
;
7493 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7494 ref1
= ref1
->next
, ref2
= ref2
->next
)
7496 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7498 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7507 gfc_error ("Stat-variable at %L shall not be %sd within "
7508 "the same %s statement", &stat
->where
, fcn
, fcn
);
7514 /* Check the errmsg variable. */
7518 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7521 gfc_check_vardef_context (errmsg
, false, false, false,
7522 _("ERRMSG variable"));
7524 if ((errmsg
->ts
.type
!= BT_CHARACTER
7526 && (errmsg
->ref
->type
== REF_ARRAY
7527 || errmsg
->ref
->type
== REF_COMPONENT
)))
7528 || errmsg
->rank
> 0 )
7529 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7530 "variable", &errmsg
->where
);
7532 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7533 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7535 gfc_ref
*ref1
, *ref2
;
7538 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7539 ref1
= ref1
->next
, ref2
= ref2
->next
)
7541 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7543 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7552 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7553 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7559 /* Check that an allocate-object appears only once in the statement. */
7561 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7564 for (q
= p
->next
; q
; q
= q
->next
)
7567 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7569 /* This is a potential collision. */
7570 gfc_ref
*pr
= pe
->ref
;
7571 gfc_ref
*qr
= qe
->ref
;
7573 /* Follow the references until
7574 a) They start to differ, in which case there is no error;
7575 you can deallocate a%b and a%c in a single statement
7576 b) Both of them stop, which is an error
7577 c) One of them stops, which is also an error. */
7580 if (pr
== NULL
&& qr
== NULL
)
7582 gfc_error ("Allocate-object at %L also appears at %L",
7583 &pe
->where
, &qe
->where
);
7586 else if (pr
!= NULL
&& qr
== NULL
)
7588 gfc_error ("Allocate-object at %L is subobject of"
7589 " object at %L", &pe
->where
, &qe
->where
);
7592 else if (pr
== NULL
&& qr
!= NULL
)
7594 gfc_error ("Allocate-object at %L is subobject of"
7595 " object at %L", &qe
->where
, &pe
->where
);
7598 /* Here, pr != NULL && qr != NULL */
7599 gcc_assert(pr
->type
== qr
->type
);
7600 if (pr
->type
== REF_ARRAY
)
7602 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7604 gcc_assert (qr
->type
== REF_ARRAY
);
7606 if (pr
->next
&& qr
->next
)
7609 gfc_array_ref
*par
= &(pr
->u
.ar
);
7610 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7612 for (i
=0; i
<par
->dimen
; i
++)
7614 if ((par
->start
[i
] != NULL
7615 || qar
->start
[i
] != NULL
)
7616 && gfc_dep_compare_expr (par
->start
[i
],
7617 qar
->start
[i
]) != 0)
7624 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7637 if (strcmp (fcn
, "ALLOCATE") == 0)
7639 bool arr_alloc_wo_spec
= false;
7641 /* Resolving the expr3 in the loop over all objects to allocate would
7642 execute loop invariant code for each loop item. Therefore do it just
7644 if (code
->expr3
&& code
->expr3
->mold
7645 && code
->expr3
->ts
.type
== BT_DERIVED
)
7647 /* Default initialization via MOLD (non-polymorphic). */
7648 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7651 gfc_resolve_expr (rhs
);
7652 gfc_free_expr (code
->expr3
);
7656 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7657 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7659 if (arr_alloc_wo_spec
&& code
->expr3
)
7661 /* Mark the allocate to have to take the array specification
7663 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7668 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7669 resolve_deallocate_expr (a
->expr
);
7674 /************ SELECT CASE resolution subroutines ************/
7676 /* Callback function for our mergesort variant. Determines interval
7677 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7678 op1 > op2. Assumes we're not dealing with the default case.
7679 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7680 There are nine situations to check. */
7683 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7687 if (op1
->low
== NULL
) /* op1 = (:L) */
7689 /* op2 = (:N), so overlap. */
7691 /* op2 = (M:) or (M:N), L < M */
7692 if (op2
->low
!= NULL
7693 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7696 else if (op1
->high
== NULL
) /* op1 = (K:) */
7698 /* op2 = (M:), so overlap. */
7700 /* op2 = (:N) or (M:N), K > N */
7701 if (op2
->high
!= NULL
7702 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7705 else /* op1 = (K:L) */
7707 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7708 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7710 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7711 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7713 else /* op2 = (M:N) */
7717 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7720 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7729 /* Merge-sort a double linked case list, detecting overlap in the
7730 process. LIST is the head of the double linked case list before it
7731 is sorted. Returns the head of the sorted list if we don't see any
7732 overlap, or NULL otherwise. */
7735 check_case_overlap (gfc_case
*list
)
7737 gfc_case
*p
, *q
, *e
, *tail
;
7738 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7740 /* If the passed list was empty, return immediately. */
7747 /* Loop unconditionally. The only exit from this loop is a return
7748 statement, when we've finished sorting the case list. */
7755 /* Count the number of merges we do in this pass. */
7758 /* Loop while there exists a merge to be done. */
7763 /* Count this merge. */
7766 /* Cut the list in two pieces by stepping INSIZE places
7767 forward in the list, starting from P. */
7770 for (i
= 0; i
< insize
; i
++)
7779 /* Now we have two lists. Merge them! */
7780 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7782 /* See from which the next case to merge comes from. */
7785 /* P is empty so the next case must come from Q. */
7790 else if (qsize
== 0 || q
== NULL
)
7799 cmp
= compare_cases (p
, q
);
7802 /* The whole case range for P is less than the
7810 /* The whole case range for Q is greater than
7811 the case range for P. */
7818 /* The cases overlap, or they are the same
7819 element in the list. Either way, we must
7820 issue an error and get the next case from P. */
7821 /* FIXME: Sort P and Q by line number. */
7822 gfc_error ("CASE label at %L overlaps with CASE "
7823 "label at %L", &p
->where
, &q
->where
);
7831 /* Add the next element to the merged list. */
7840 /* P has now stepped INSIZE places along, and so has Q. So
7841 they're the same. */
7846 /* If we have done only one merge or none at all, we've
7847 finished sorting the cases. */
7856 /* Otherwise repeat, merging lists twice the size. */
7862 /* Check to see if an expression is suitable for use in a CASE statement.
7863 Makes sure that all case expressions are scalar constants of the same
7864 type. Return false if anything is wrong. */
7867 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7869 if (e
== NULL
) return true;
7871 if (e
->ts
.type
!= case_expr
->ts
.type
)
7873 gfc_error ("Expression in CASE statement at %L must be of type %s",
7874 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7878 /* C805 (R808) For a given case-construct, each case-value shall be of
7879 the same type as case-expr. For character type, length differences
7880 are allowed, but the kind type parameters shall be the same. */
7882 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7884 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7885 &e
->where
, case_expr
->ts
.kind
);
7889 /* Convert the case value kind to that of case expression kind,
7892 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7893 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7897 gfc_error ("Expression in CASE statement at %L must be scalar",
7906 /* Given a completely parsed select statement, we:
7908 - Validate all expressions and code within the SELECT.
7909 - Make sure that the selection expression is not of the wrong type.
7910 - Make sure that no case ranges overlap.
7911 - Eliminate unreachable cases and unreachable code resulting from
7912 removing case labels.
7914 The standard does allow unreachable cases, e.g. CASE (5:3). But
7915 they are a hassle for code generation, and to prevent that, we just
7916 cut them out here. This is not necessary for overlapping cases
7917 because they are illegal and we never even try to generate code.
7919 We have the additional caveat that a SELECT construct could have
7920 been a computed GOTO in the source code. Fortunately we can fairly
7921 easily work around that here: The case_expr for a "real" SELECT CASE
7922 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7923 we have to do is make sure that the case_expr is a scalar integer
7927 resolve_select (gfc_code
*code
, bool select_type
)
7930 gfc_expr
*case_expr
;
7931 gfc_case
*cp
, *default_case
, *tail
, *head
;
7932 int seen_unreachable
;
7938 if (code
->expr1
== NULL
)
7940 /* This was actually a computed GOTO statement. */
7941 case_expr
= code
->expr2
;
7942 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7943 gfc_error ("Selection expression in computed GOTO statement "
7944 "at %L must be a scalar integer expression",
7947 /* Further checking is not necessary because this SELECT was built
7948 by the compiler, so it should always be OK. Just move the
7949 case_expr from expr2 to expr so that we can handle computed
7950 GOTOs as normal SELECTs from here on. */
7951 code
->expr1
= code
->expr2
;
7956 case_expr
= code
->expr1
;
7957 type
= case_expr
->ts
.type
;
7960 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7962 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7963 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7965 /* Punt. Going on here just produce more garbage error messages. */
7970 if (!select_type
&& case_expr
->rank
!= 0)
7972 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7973 "expression", &case_expr
->where
);
7979 /* Raise a warning if an INTEGER case value exceeds the range of
7980 the case-expr. Later, all expressions will be promoted to the
7981 largest kind of all case-labels. */
7983 if (type
== BT_INTEGER
)
7984 for (body
= code
->block
; body
; body
= body
->block
)
7985 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7988 && gfc_check_integer_range (cp
->low
->value
.integer
,
7989 case_expr
->ts
.kind
) != ARITH_OK
)
7990 gfc_warning (0, "Expression in CASE statement at %L is "
7991 "not in the range of %s", &cp
->low
->where
,
7992 gfc_typename (&case_expr
->ts
));
7995 && cp
->low
!= cp
->high
7996 && gfc_check_integer_range (cp
->high
->value
.integer
,
7997 case_expr
->ts
.kind
) != ARITH_OK
)
7998 gfc_warning (0, "Expression in CASE statement at %L is "
7999 "not in the range of %s", &cp
->high
->where
,
8000 gfc_typename (&case_expr
->ts
));
8003 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8004 of the SELECT CASE expression and its CASE values. Walk the lists
8005 of case values, and if we find a mismatch, promote case_expr to
8006 the appropriate kind. */
8008 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8010 for (body
= code
->block
; body
; body
= body
->block
)
8012 /* Walk the case label list. */
8013 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8015 /* Intercept the DEFAULT case. It does not have a kind. */
8016 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8019 /* Unreachable case ranges are discarded, so ignore. */
8020 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8021 && cp
->low
!= cp
->high
8022 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8026 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8027 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8029 if (cp
->high
!= NULL
8030 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8031 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8036 /* Assume there is no DEFAULT case. */
8037 default_case
= NULL
;
8042 for (body
= code
->block
; body
; body
= body
->block
)
8044 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8046 seen_unreachable
= 0;
8048 /* Walk the case label list, making sure that all case labels
8050 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8052 /* Count the number of cases in the whole construct. */
8055 /* Intercept the DEFAULT case. */
8056 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8058 if (default_case
!= NULL
)
8060 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8061 "by a second DEFAULT CASE at %L",
8062 &default_case
->where
, &cp
->where
);
8073 /* Deal with single value cases and case ranges. Errors are
8074 issued from the validation function. */
8075 if (!validate_case_label_expr (cp
->low
, case_expr
)
8076 || !validate_case_label_expr (cp
->high
, case_expr
))
8082 if (type
== BT_LOGICAL
8083 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8084 || cp
->low
!= cp
->high
))
8086 gfc_error ("Logical range in CASE statement at %L is not "
8087 "allowed", &cp
->low
->where
);
8092 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8095 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8096 if (value
& seen_logical
)
8098 gfc_error ("Constant logical value in CASE statement "
8099 "is repeated at %L",
8104 seen_logical
|= value
;
8107 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8108 && cp
->low
!= cp
->high
8109 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8111 if (warn_surprising
)
8112 gfc_warning (OPT_Wsurprising
,
8113 "Range specification at %L can never be matched",
8116 cp
->unreachable
= 1;
8117 seen_unreachable
= 1;
8121 /* If the case range can be matched, it can also overlap with
8122 other cases. To make sure it does not, we put it in a
8123 double linked list here. We sort that with a merge sort
8124 later on to detect any overlapping cases. */
8128 head
->right
= head
->left
= NULL
;
8133 tail
->right
->left
= tail
;
8140 /* It there was a failure in the previous case label, give up
8141 for this case label list. Continue with the next block. */
8145 /* See if any case labels that are unreachable have been seen.
8146 If so, we eliminate them. This is a bit of a kludge because
8147 the case lists for a single case statement (label) is a
8148 single forward linked lists. */
8149 if (seen_unreachable
)
8151 /* Advance until the first case in the list is reachable. */
8152 while (body
->ext
.block
.case_list
!= NULL
8153 && body
->ext
.block
.case_list
->unreachable
)
8155 gfc_case
*n
= body
->ext
.block
.case_list
;
8156 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8158 gfc_free_case_list (n
);
8161 /* Strip all other unreachable cases. */
8162 if (body
->ext
.block
.case_list
)
8164 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8166 if (cp
->next
->unreachable
)
8168 gfc_case
*n
= cp
->next
;
8169 cp
->next
= cp
->next
->next
;
8171 gfc_free_case_list (n
);
8178 /* See if there were overlapping cases. If the check returns NULL,
8179 there was overlap. In that case we don't do anything. If head
8180 is non-NULL, we prepend the DEFAULT case. The sorted list can
8181 then used during code generation for SELECT CASE constructs with
8182 a case expression of a CHARACTER type. */
8185 head
= check_case_overlap (head
);
8187 /* Prepend the default_case if it is there. */
8188 if (head
!= NULL
&& default_case
)
8190 default_case
->left
= NULL
;
8191 default_case
->right
= head
;
8192 head
->left
= default_case
;
8196 /* Eliminate dead blocks that may be the result if we've seen
8197 unreachable case labels for a block. */
8198 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8200 if (body
->block
->ext
.block
.case_list
== NULL
)
8202 /* Cut the unreachable block from the code chain. */
8203 gfc_code
*c
= body
->block
;
8204 body
->block
= c
->block
;
8206 /* Kill the dead block, but not the blocks below it. */
8208 gfc_free_statements (c
);
8212 /* More than two cases is legal but insane for logical selects.
8213 Issue a warning for it. */
8214 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8215 gfc_warning (OPT_Wsurprising
,
8216 "Logical SELECT CASE block at %L has more that two cases",
8221 /* Check if a derived type is extensible. */
8224 gfc_type_is_extensible (gfc_symbol
*sym
)
8226 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8227 || (sym
->attr
.is_class
8228 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8233 resolve_types (gfc_namespace
*ns
);
8235 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8236 correct as well as possibly the array-spec. */
8239 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8243 gcc_assert (sym
->assoc
);
8244 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8246 /* If this is for SELECT TYPE, the target may not yet be set. In that
8247 case, return. Resolution will be called later manually again when
8249 target
= sym
->assoc
->target
;
8252 gcc_assert (!sym
->assoc
->dangling
);
8254 if (resolve_target
&& !gfc_resolve_expr (target
))
8257 /* For variable targets, we get some attributes from the target. */
8258 if (target
->expr_type
== EXPR_VARIABLE
)
8262 gcc_assert (target
->symtree
);
8263 tsym
= target
->symtree
->n
.sym
;
8265 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8266 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8268 sym
->attr
.target
= tsym
->attr
.target
8269 || gfc_expr_attr (target
).pointer
;
8270 if (is_subref_array (target
))
8271 sym
->attr
.subref_array_pointer
= 1;
8274 /* Get type if this was not already set. Note that it can be
8275 some other type than the target in case this is a SELECT TYPE
8276 selector! So we must not update when the type is already there. */
8277 if (sym
->ts
.type
== BT_UNKNOWN
)
8278 sym
->ts
= target
->ts
;
8279 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8281 /* See if this is a valid association-to-variable. */
8282 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8283 && !gfc_has_vector_subscript (target
));
8285 /* Finally resolve if this is an array or not. */
8286 if (sym
->attr
.dimension
&& target
->rank
== 0)
8288 /* primary.c makes the assumption that a reference to an associate
8289 name followed by a left parenthesis is an array reference. */
8290 if (sym
->ts
.type
!= BT_CHARACTER
)
8291 gfc_error ("Associate-name %qs at %L is used as array",
8292 sym
->name
, &sym
->declared_at
);
8293 sym
->attr
.dimension
= 0;
8298 /* We cannot deal with class selectors that need temporaries. */
8299 if (target
->ts
.type
== BT_CLASS
8300 && gfc_ref_needs_temporary_p (target
->ref
))
8302 gfc_error ("CLASS selector at %L needs a temporary which is not "
8303 "yet implemented", &target
->where
);
8307 if (target
->ts
.type
== BT_CLASS
)
8308 gfc_fix_class_refs (target
);
8310 if (target
->rank
!= 0)
8313 /* The rank may be incorrectly guessed at parsing, therefore make sure
8314 it is corrected now. */
8315 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8318 sym
->as
= gfc_get_array_spec ();
8320 as
->rank
= target
->rank
;
8321 as
->type
= AS_DEFERRED
;
8322 as
->corank
= gfc_get_corank (target
);
8323 sym
->attr
.dimension
= 1;
8324 if (as
->corank
!= 0)
8325 sym
->attr
.codimension
= 1;
8330 /* target's rank is 0, but the type of the sym is still array valued,
8331 which has to be corrected. */
8332 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8335 symbol_attribute attr
;
8336 /* The associated variable's type is still the array type
8337 correct this now. */
8338 gfc_typespec
*ts
= &target
->ts
;
8341 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8346 ts
= &ref
->u
.c
.component
->ts
;
8349 if (ts
->type
== BT_CLASS
)
8350 ts
= &ts
->u
.derived
->components
->ts
;
8356 /* Create a scalar instance of the current class type. Because the
8357 rank of a class array goes into its name, the type has to be
8358 rebuild. The alternative of (re-)setting just the attributes
8359 and as in the current type, destroys the type also in other
8363 sym
->ts
.type
= BT_CLASS
;
8364 attr
= CLASS_DATA (sym
)->attr
;
8366 attr
.associate_var
= 1;
8367 attr
.dimension
= attr
.codimension
= 0;
8368 attr
.class_pointer
= 1;
8369 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8371 /* Make sure the _vptr is set. */
8372 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8373 if (c
->ts
.u
.derived
== NULL
)
8374 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8375 CLASS_DATA (sym
)->attr
.pointer
= 1;
8376 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8377 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8378 gfc_commit_symbol (sym
->ts
.u
.derived
);
8379 /* _vptr now has the _vtab in it, change it to the _vtype. */
8380 if (c
->ts
.u
.derived
->attr
.vtab
)
8381 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8382 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8383 resolve_types (c
->ts
.u
.derived
->ns
);
8387 /* Mark this as an associate variable. */
8388 sym
->attr
.associate_var
= 1;
8390 /* Fix up the type-spec for CHARACTER types. */
8391 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8394 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8396 if (!sym
->ts
.u
.cl
->length
)
8397 sym
->ts
.u
.cl
->length
8398 = gfc_get_int_expr (gfc_default_integer_kind
,
8399 NULL
, target
->value
.character
.length
);
8402 /* If the target is a good class object, so is the associate variable. */
8403 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8404 sym
->attr
.class_ok
= 1;
8408 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8409 array reference, where necessary. The symbols are artificial and so
8410 the dimension attribute and arrayspec can also be set. In addition,
8411 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8412 This is corrected here as well.*/
8415 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8416 int rank
, gfc_ref
*ref
)
8418 gfc_ref
*nref
= (*expr1
)->ref
;
8419 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8420 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8421 (*expr1
)->rank
= rank
;
8422 if (sym1
->ts
.type
== BT_CLASS
)
8424 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8425 (*expr1
)->ts
= sym1
->ts
;
8427 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8428 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8429 CLASS_DATA (sym1
)->as
8430 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8434 sym1
->attr
.dimension
= 1;
8435 if (sym1
->as
== NULL
&& sym2
)
8436 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8439 for (; nref
; nref
= nref
->next
)
8440 if (nref
->next
== NULL
)
8443 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8444 nref
->next
= gfc_copy_ref (ref
);
8445 else if (ref
&& !nref
)
8446 (*expr1
)->ref
= gfc_copy_ref (ref
);
8451 build_loc_call (gfc_expr
*sym_expr
)
8454 loc_call
= gfc_get_expr ();
8455 loc_call
->expr_type
= EXPR_FUNCTION
;
8456 gfc_get_sym_tree ("loc", gfc_current_ns
, &loc_call
->symtree
, false);
8457 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8458 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8459 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8460 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8461 loc_call
->ts
.type
= BT_INTEGER
;
8462 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8463 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8464 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8465 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8466 loc_call
->where
= sym_expr
->where
;
8470 /* Resolve a SELECT TYPE statement. */
8473 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8475 gfc_symbol
*selector_type
;
8476 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8477 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8480 char name
[GFC_MAX_SYMBOL_LEN
];
8485 gfc_ref
* ref
= NULL
;
8486 gfc_expr
*selector_expr
= NULL
;
8488 ns
= code
->ext
.block
.ns
;
8491 /* Check for F03:C813. */
8492 if (code
->expr1
->ts
.type
!= BT_CLASS
8493 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8495 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8496 "at %L", &code
->loc
);
8500 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8505 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8506 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8507 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8509 /* F2008: C803 The selector expression must not be coindexed. */
8510 if (gfc_is_coindexed (code
->expr2
))
8512 gfc_error ("Selector at %L must not be coindexed",
8513 &code
->expr2
->where
);
8520 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8522 if (gfc_is_coindexed (code
->expr1
))
8524 gfc_error ("Selector at %L must not be coindexed",
8525 &code
->expr1
->where
);
8530 /* Loop over TYPE IS / CLASS IS cases. */
8531 for (body
= code
->block
; body
; body
= body
->block
)
8533 c
= body
->ext
.block
.case_list
;
8537 /* Check for repeated cases. */
8538 for (tail
= code
->block
; tail
; tail
= tail
->block
)
8540 gfc_case
*d
= tail
->ext
.block
.case_list
;
8544 if (c
->ts
.type
== d
->ts
.type
8545 && ((c
->ts
.type
== BT_DERIVED
8546 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
8547 && !strcmp (c
->ts
.u
.derived
->name
,
8548 d
->ts
.u
.derived
->name
))
8549 || c
->ts
.type
== BT_UNKNOWN
8550 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8551 && c
->ts
.kind
== d
->ts
.kind
)))
8553 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8554 &c
->where
, &d
->where
);
8560 /* Check F03:C815. */
8561 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8562 && !selector_type
->attr
.unlimited_polymorphic
8563 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8565 gfc_error ("Derived type %qs at %L must be extensible",
8566 c
->ts
.u
.derived
->name
, &c
->where
);
8571 /* Check F03:C816. */
8572 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8573 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8574 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8576 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8577 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8578 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8580 gfc_error ("Unexpected intrinsic type %qs at %L",
8581 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8586 /* Check F03:C814. */
8587 if (c
->ts
.type
== BT_CHARACTER
8588 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
8590 gfc_error ("The type-spec at %L shall specify that each length "
8591 "type parameter is assumed", &c
->where
);
8596 /* Intercept the DEFAULT case. */
8597 if (c
->ts
.type
== BT_UNKNOWN
)
8599 /* Check F03:C818. */
8602 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8603 "by a second DEFAULT CASE at %L",
8604 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8609 default_case
= body
;
8616 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8617 target if present. If there are any EXIT statements referring to the
8618 SELECT TYPE construct, this is no problem because the gfc_code
8619 reference stays the same and EXIT is equally possible from the BLOCK
8620 it is changed to. */
8621 code
->op
= EXEC_BLOCK
;
8624 gfc_association_list
* assoc
;
8626 assoc
= gfc_get_association_list ();
8627 assoc
->st
= code
->expr1
->symtree
;
8628 assoc
->target
= gfc_copy_expr (code
->expr2
);
8629 assoc
->target
->where
= code
->expr2
->where
;
8630 /* assoc->variable will be set by resolve_assoc_var. */
8632 code
->ext
.block
.assoc
= assoc
;
8633 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8635 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8638 code
->ext
.block
.assoc
= NULL
;
8640 /* Ensure that the selector rank and arrayspec are available to
8641 correct expressions in which they might be missing. */
8642 if (code
->expr2
&& code
->expr2
->rank
)
8644 rank
= code
->expr2
->rank
;
8645 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
8646 if (ref
->next
== NULL
)
8648 if (ref
&& ref
->type
== REF_ARRAY
)
8649 ref
= gfc_copy_ref (ref
);
8651 /* Fixup expr1 if necessary. */
8653 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
8655 else if (code
->expr1
->rank
)
8657 rank
= code
->expr1
->rank
;
8658 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
8659 if (ref
->next
== NULL
)
8661 if (ref
&& ref
->type
== REF_ARRAY
)
8662 ref
= gfc_copy_ref (ref
);
8665 /* Add EXEC_SELECT to switch on type. */
8666 new_st
= gfc_get_code (code
->op
);
8667 new_st
->expr1
= code
->expr1
;
8668 new_st
->expr2
= code
->expr2
;
8669 new_st
->block
= code
->block
;
8670 code
->expr1
= code
->expr2
= NULL
;
8675 ns
->code
->next
= new_st
;
8677 code
->op
= EXEC_SELECT_TYPE
;
8679 /* Use the intrinsic LOC function to generate an integer expression
8680 for the vtable of the selector. Note that the rank of the selector
8681 expression has to be set to zero. */
8682 gfc_add_vptr_component (code
->expr1
);
8683 code
->expr1
->rank
= 0;
8684 code
->expr1
= build_loc_call (code
->expr1
);
8685 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
8687 /* Loop over TYPE IS / CLASS IS cases. */
8688 for (body
= code
->block
; body
; body
= body
->block
)
8692 c
= body
->ext
.block
.case_list
;
8694 /* Generate an index integer expression for address of the
8695 TYPE/CLASS vtable and store it in c->low. The hash expression
8696 is stored in c->high and is used to resolve intrinsic cases. */
8697 if (c
->ts
.type
!= BT_UNKNOWN
)
8699 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8701 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8703 c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8704 c
->ts
.u
.derived
->hash_value
);
8708 vtab
= gfc_find_vtab (&c
->ts
);
8709 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
8710 e
= CLASS_DATA (vtab
)->initializer
;
8711 c
->high
= gfc_copy_expr (e
);
8714 e
= gfc_lval_expr_from_sym (vtab
);
8715 c
->low
= build_loc_call (e
);
8720 /* Associate temporary to selector. This should only be done
8721 when this case is actually true, so build a new ASSOCIATE
8722 that does precisely this here (instead of using the
8725 if (c
->ts
.type
== BT_CLASS
)
8726 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8727 else if (c
->ts
.type
== BT_DERIVED
)
8728 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8729 else if (c
->ts
.type
== BT_CHARACTER
)
8731 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8732 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8733 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8734 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8735 charlen
, c
->ts
.kind
);
8738 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8741 st
= gfc_find_symtree (ns
->sym_root
, name
);
8742 gcc_assert (st
->n
.sym
->assoc
);
8743 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
8744 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
8745 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8747 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8748 /* Fixup the target expression if necessary. */
8750 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
8753 new_st
= gfc_get_code (EXEC_BLOCK
);
8754 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8755 new_st
->ext
.block
.ns
->code
= body
->next
;
8756 body
->next
= new_st
;
8758 /* Chain in the new list only if it is marked as dangling. Otherwise
8759 there is a CASE label overlap and this is already used. Just ignore,
8760 the error is diagnosed elsewhere. */
8761 if (st
->n
.sym
->assoc
->dangling
)
8763 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8764 st
->n
.sym
->assoc
->dangling
= 0;
8767 resolve_assoc_var (st
->n
.sym
, false);
8770 /* Take out CLASS IS cases for separate treatment. */
8772 while (body
&& body
->block
)
8774 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8776 /* Add to class_is list. */
8777 if (class_is
== NULL
)
8779 class_is
= body
->block
;
8784 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8785 tail
->block
= body
->block
;
8788 /* Remove from EXEC_SELECT list. */
8789 body
->block
= body
->block
->block
;
8802 /* Add a default case to hold the CLASS IS cases. */
8803 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8804 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8806 tail
->ext
.block
.case_list
= gfc_get_case ();
8807 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8809 default_case
= tail
;
8812 /* More than one CLASS IS block? */
8813 if (class_is
->block
)
8817 /* Sort CLASS IS blocks by extension level. */
8821 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8824 /* F03:C817 (check for doubles). */
8825 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8826 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8828 gfc_error ("Double CLASS IS block in SELECT TYPE "
8830 &c2
->ext
.block
.case_list
->where
);
8833 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8834 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8837 (*c1
)->block
= c2
->block
;
8847 /* Generate IF chain. */
8848 if_st
= gfc_get_code (EXEC_IF
);
8850 for (body
= class_is
; body
; body
= body
->block
)
8852 new_st
->block
= gfc_get_code (EXEC_IF
);
8853 new_st
= new_st
->block
;
8854 /* Set up IF condition: Call _gfortran_is_extension_of. */
8855 new_st
->expr1
= gfc_get_expr ();
8856 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8857 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8858 new_st
->expr1
->ts
.kind
= 4;
8859 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8860 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8861 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8862 /* Set up arguments. */
8863 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8864 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
8865 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8866 new_st
->expr1
->where
= code
->loc
;
8867 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8868 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8869 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8870 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8871 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8872 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
8873 new_st
->next
= body
->next
;
8875 if (default_case
->next
)
8877 new_st
->block
= gfc_get_code (EXEC_IF
);
8878 new_st
= new_st
->block
;
8879 new_st
->next
= default_case
->next
;
8882 /* Replace CLASS DEFAULT code by the IF chain. */
8883 default_case
->next
= if_st
;
8886 /* Resolve the internal code. This can not be done earlier because
8887 it requires that the sym->assoc of selectors is set already. */
8888 gfc_current_ns
= ns
;
8889 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8890 gfc_current_ns
= old_ns
;
8897 /* Resolve a transfer statement. This is making sure that:
8898 -- a derived type being transferred has only non-pointer components
8899 -- a derived type being transferred doesn't have private components, unless
8900 it's being transferred from the module where the type was defined
8901 -- we're not trying to transfer a whole assumed size array. */
8904 resolve_transfer (gfc_code
*code
)
8907 gfc_symbol
*sym
, *derived
;
8911 bool formatted
= false;
8912 gfc_dt
*dt
= code
->ext
.dt
;
8913 gfc_symbol
*dtio_sub
= NULL
;
8917 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8918 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8919 exp
= exp
->value
.op
.op1
;
8921 if (exp
&& exp
->expr_type
== EXPR_NULL
8924 gfc_error ("Invalid context for NULL () intrinsic at %L",
8929 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8930 && exp
->expr_type
!= EXPR_FUNCTION
8931 && exp
->expr_type
!= EXPR_STRUCTURE
))
8934 /* If we are reading, the variable will be changed. Note that
8935 code->ext.dt may be NULL if the TRANSFER is related to
8936 an INQUIRE statement -- but in this case, we are not reading, either. */
8937 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
8938 && !gfc_check_vardef_context (exp
, false, false, false,
8942 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8944 /* Go to actual component transferred. */
8945 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8946 if (ref
->type
== REF_COMPONENT
)
8947 ts
= &ref
->u
.c
.component
->ts
;
8949 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
8950 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
8952 if (ts
->type
== BT_DERIVED
)
8953 derived
= ts
->u
.derived
;
8955 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
8957 if (dt
->format_expr
)
8960 fmt
= gfc_widechar_to_char (dt
->format_expr
->value
.character
.string
,
8962 if (strtok (fmt
, "DT") != NULL
)
8965 else if (dt
->format_label
== &format_asterisk
)
8967 /* List directed io must call the formatted DTIO procedure. */
8971 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
8972 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
8973 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
8975 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
8978 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
8979 /* Check to see if this is a nested DTIO call, with the
8980 dummy as the io-list object. */
8981 if (sym
&& sym
== dtio_sub
&& sym
->formal
8982 && sym
->formal
->sym
== exp
->symtree
->n
.sym
8983 && exp
->ref
== NULL
)
8985 if (!sym
->attr
.recursive
)
8987 gfc_error ("DTIO %s procedure at %L must be recursive",
8988 sym
->name
, &sym
->declared_at
);
8995 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
8997 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8998 "it is processed by a defined input/output procedure",
9003 if (ts
->type
== BT_DERIVED
)
9005 /* Check that transferred derived type doesn't contain POINTER
9006 components unless it is processed by a defined input/output
9008 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9010 gfc_error ("Data transfer element at %L cannot have POINTER "
9011 "components unless it is processed by a defined "
9012 "input/output procedure", &code
->loc
);
9017 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9019 gfc_error ("Data transfer element at %L cannot have "
9020 "procedure pointer components", &code
->loc
);
9024 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9026 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9027 "components unless it is processed by a defined "
9028 "input/output procedure", &code
->loc
);
9032 /* C_PTR and C_FUNPTR have private components which means they can not
9033 be printed. However, if -std=gnu and not -pedantic, allow
9034 the component to be printed to help debugging. */
9035 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9037 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9038 "cannot have PRIVATE components", &code
->loc
))
9041 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9043 gfc_error ("Data transfer element at %L cannot have "
9044 "PRIVATE components unless it is processed by "
9045 "a defined input/output procedure", &code
->loc
);
9050 if (exp
->expr_type
== EXPR_STRUCTURE
)
9053 sym
= exp
->symtree
->n
.sym
;
9055 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9056 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9058 gfc_error ("Data transfer element at %L cannot be a full reference to "
9059 "an assumed-size array", &code
->loc
);
9065 /*********** Toplevel code resolution subroutines ***********/
9067 /* Find the set of labels that are reachable from this block. We also
9068 record the last statement in each block. */
9071 find_reachable_labels (gfc_code
*block
)
9078 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
9080 /* Collect labels in this block. We don't keep those corresponding
9081 to END {IF|SELECT}, these are checked in resolve_branch by going
9082 up through the code_stack. */
9083 for (c
= block
; c
; c
= c
->next
)
9085 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9086 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9089 /* Merge with labels from parent block. */
9092 gcc_assert (cs_base
->prev
->reachable_labels
);
9093 bitmap_ior_into (cs_base
->reachable_labels
,
9094 cs_base
->prev
->reachable_labels
);
9100 resolve_lock_unlock_event (gfc_code
*code
)
9102 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9103 && code
->expr1
->value
.function
.isym
9104 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9105 remove_caf_get_intrinsic (code
->expr1
);
9107 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9108 && (code
->expr1
->ts
.type
!= BT_DERIVED
9109 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9110 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9111 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9112 || code
->expr1
->rank
!= 0
9113 || (!gfc_is_coarray (code
->expr1
) &&
9114 !gfc_is_coindexed (code
->expr1
))))
9115 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9116 &code
->expr1
->where
);
9117 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9118 && (code
->expr1
->ts
.type
!= BT_DERIVED
9119 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9120 || code
->expr1
->ts
.u
.derived
->from_intmod
9121 != INTMOD_ISO_FORTRAN_ENV
9122 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9123 != ISOFORTRAN_EVENT_TYPE
9124 || code
->expr1
->rank
!= 0))
9125 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9126 &code
->expr1
->where
);
9127 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9128 && !gfc_is_coindexed (code
->expr1
))
9129 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9130 &code
->expr1
->where
);
9131 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9132 gfc_error ("Event variable argument at %L must be a coarray but not "
9133 "coindexed", &code
->expr1
->where
);
9137 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9138 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9139 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9140 &code
->expr2
->where
);
9143 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9144 _("STAT variable")))
9149 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9150 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9151 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9152 &code
->expr3
->where
);
9155 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9156 _("ERRMSG variable")))
9159 /* Check for LOCK the ACQUIRED_LOCK. */
9160 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9161 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9162 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9163 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9164 "variable", &code
->expr4
->where
);
9166 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9167 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9168 _("ACQUIRED_LOCK variable")))
9171 /* Check for EVENT WAIT the UNTIL_COUNT. */
9172 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
9173 && (code
->expr4
->ts
.type
!= BT_INTEGER
|| code
->expr4
->rank
!= 0))
9174 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9175 "expression", &code
->expr4
->where
);
9180 resolve_critical (gfc_code
*code
)
9182 gfc_symtree
*symtree
;
9183 gfc_symbol
*lock_type
;
9184 char name
[GFC_MAX_SYMBOL_LEN
];
9185 static int serial
= 0;
9187 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9190 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9191 GFC_PREFIX ("lock_type"));
9193 lock_type
= symtree
->n
.sym
;
9196 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9199 lock_type
= symtree
->n
.sym
;
9200 lock_type
->attr
.flavor
= FL_DERIVED
;
9201 lock_type
->attr
.zero_comp
= 1;
9202 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9203 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9206 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9207 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9210 code
->resolved_sym
= symtree
->n
.sym
;
9211 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9212 symtree
->n
.sym
->attr
.referenced
= 1;
9213 symtree
->n
.sym
->attr
.artificial
= 1;
9214 symtree
->n
.sym
->attr
.codimension
= 1;
9215 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9216 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9217 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9218 symtree
->n
.sym
->as
->corank
= 1;
9219 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9220 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9221 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9223 gfc_commit_symbols();
9228 resolve_sync (gfc_code
*code
)
9230 /* Check imageset. The * case matches expr1 == NULL. */
9233 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9234 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9235 "INTEGER expression", &code
->expr1
->where
);
9236 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9237 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9238 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9239 &code
->expr1
->where
);
9240 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9241 && gfc_simplify_expr (code
->expr1
, 0))
9243 gfc_constructor
*cons
;
9244 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9245 for (; cons
; cons
= gfc_constructor_next (cons
))
9246 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9247 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9248 gfc_error ("Imageset argument at %L must between 1 and "
9249 "num_images()", &cons
->expr
->where
);
9255 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9256 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9257 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9258 &code
->expr2
->where
);
9262 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9263 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9264 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9265 &code
->expr3
->where
);
9269 /* Given a branch to a label, see if the branch is conforming.
9270 The code node describes where the branch is located. */
9273 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9280 /* Step one: is this a valid branching target? */
9282 if (label
->defined
== ST_LABEL_UNKNOWN
)
9284 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9289 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9291 gfc_error ("Statement at %L is not a valid branch target statement "
9292 "for the branch statement at %L", &label
->where
, &code
->loc
);
9296 /* Step two: make sure this branch is not a branch to itself ;-) */
9298 if (code
->here
== label
)
9301 "Branch at %L may result in an infinite loop", &code
->loc
);
9305 /* Step three: See if the label is in the same block as the
9306 branching statement. The hard work has been done by setting up
9307 the bitmap reachable_labels. */
9309 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9311 /* Check now whether there is a CRITICAL construct; if so, check
9312 whether the label is still visible outside of the CRITICAL block,
9313 which is invalid. */
9314 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9316 if (stack
->current
->op
== EXEC_CRITICAL
9317 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9318 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9319 "label at %L", &code
->loc
, &label
->where
);
9320 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9321 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9322 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9323 "for label at %L", &code
->loc
, &label
->where
);
9329 /* Step four: If we haven't found the label in the bitmap, it may
9330 still be the label of the END of the enclosing block, in which
9331 case we find it by going up the code_stack. */
9333 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9335 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9337 if (stack
->current
->op
== EXEC_CRITICAL
)
9339 /* Note: A label at END CRITICAL does not leave the CRITICAL
9340 construct as END CRITICAL is still part of it. */
9341 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9342 " at %L", &code
->loc
, &label
->where
);
9345 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9347 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9348 "label at %L", &code
->loc
, &label
->where
);
9355 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9359 /* The label is not in an enclosing block, so illegal. This was
9360 allowed in Fortran 66, so we allow it as extension. No
9361 further checks are necessary in this case. */
9362 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9363 "as the GOTO statement at %L", &label
->where
,
9369 /* Check whether EXPR1 has the same shape as EXPR2. */
9372 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9374 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9375 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9376 bool result
= false;
9379 /* Compare the rank. */
9380 if (expr1
->rank
!= expr2
->rank
)
9383 /* Compare the size of each dimension. */
9384 for (i
=0; i
<expr1
->rank
; i
++)
9386 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9389 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9392 if (mpz_cmp (shape
[i
], shape2
[i
]))
9396 /* When either of the two expression is an assumed size array, we
9397 ignore the comparison of dimension sizes. */
9402 gfc_clear_shape (shape
, i
);
9403 gfc_clear_shape (shape2
, i
);
9408 /* Check whether a WHERE assignment target or a WHERE mask expression
9409 has the same shape as the outmost WHERE mask expression. */
9412 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9418 cblock
= code
->block
;
9420 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9421 In case of nested WHERE, only the outmost one is stored. */
9422 if (mask
== NULL
) /* outmost WHERE */
9424 else /* inner WHERE */
9431 /* Check if the mask-expr has a consistent shape with the
9432 outmost WHERE mask-expr. */
9433 if (!resolve_where_shape (cblock
->expr1
, e
))
9434 gfc_error ("WHERE mask at %L has inconsistent shape",
9435 &cblock
->expr1
->where
);
9438 /* the assignment statement of a WHERE statement, or the first
9439 statement in where-body-construct of a WHERE construct */
9440 cnext
= cblock
->next
;
9445 /* WHERE assignment statement */
9448 /* Check shape consistent for WHERE assignment target. */
9449 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9450 gfc_error ("WHERE assignment target at %L has "
9451 "inconsistent shape", &cnext
->expr1
->where
);
9455 case EXEC_ASSIGN_CALL
:
9456 resolve_call (cnext
);
9457 if (!cnext
->resolved_sym
->attr
.elemental
)
9458 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9459 &cnext
->ext
.actual
->expr
->where
);
9462 /* WHERE or WHERE construct is part of a where-body-construct */
9464 resolve_where (cnext
, e
);
9468 gfc_error ("Unsupported statement inside WHERE at %L",
9471 /* the next statement within the same where-body-construct */
9472 cnext
= cnext
->next
;
9474 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9475 cblock
= cblock
->block
;
9480 /* Resolve assignment in FORALL construct.
9481 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9482 FORALL index variables. */
9485 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9489 for (n
= 0; n
< nvar
; n
++)
9491 gfc_symbol
*forall_index
;
9493 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9495 /* Check whether the assignment target is one of the FORALL index
9497 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9498 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9499 gfc_error ("Assignment to a FORALL index variable at %L",
9500 &code
->expr1
->where
);
9503 /* If one of the FORALL index variables doesn't appear in the
9504 assignment variable, then there could be a many-to-one
9505 assignment. Emit a warning rather than an error because the
9506 mask could be resolving this problem. */
9507 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9508 gfc_warning (0, "The FORALL with index %qs is not used on the "
9509 "left side of the assignment at %L and so might "
9510 "cause multiple assignment to this object",
9511 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9517 /* Resolve WHERE statement in FORALL construct. */
9520 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9521 gfc_expr
**var_expr
)
9526 cblock
= code
->block
;
9529 /* the assignment statement of a WHERE statement, or the first
9530 statement in where-body-construct of a WHERE construct */
9531 cnext
= cblock
->next
;
9536 /* WHERE assignment statement */
9538 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9541 /* WHERE operator assignment statement */
9542 case EXEC_ASSIGN_CALL
:
9543 resolve_call (cnext
);
9544 if (!cnext
->resolved_sym
->attr
.elemental
)
9545 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9546 &cnext
->ext
.actual
->expr
->where
);
9549 /* WHERE or WHERE construct is part of a where-body-construct */
9551 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9555 gfc_error ("Unsupported statement inside WHERE at %L",
9558 /* the next statement within the same where-body-construct */
9559 cnext
= cnext
->next
;
9561 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9562 cblock
= cblock
->block
;
9567 /* Traverse the FORALL body to check whether the following errors exist:
9568 1. For assignment, check if a many-to-one assignment happens.
9569 2. For WHERE statement, check the WHERE body to see if there is any
9570 many-to-one assignment. */
9573 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9577 c
= code
->block
->next
;
9583 case EXEC_POINTER_ASSIGN
:
9584 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9587 case EXEC_ASSIGN_CALL
:
9591 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9592 there is no need to handle it here. */
9596 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9601 /* The next statement in the FORALL body. */
9607 /* Counts the number of iterators needed inside a forall construct, including
9608 nested forall constructs. This is used to allocate the needed memory
9609 in gfc_resolve_forall. */
9612 gfc_count_forall_iterators (gfc_code
*code
)
9614 int max_iters
, sub_iters
, current_iters
;
9615 gfc_forall_iterator
*fa
;
9617 gcc_assert(code
->op
== EXEC_FORALL
);
9621 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9624 code
= code
->block
->next
;
9628 if (code
->op
== EXEC_FORALL
)
9630 sub_iters
= gfc_count_forall_iterators (code
);
9631 if (sub_iters
> max_iters
)
9632 max_iters
= sub_iters
;
9637 return current_iters
+ max_iters
;
9641 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9642 gfc_resolve_forall_body to resolve the FORALL body. */
9645 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9647 static gfc_expr
**var_expr
;
9648 static int total_var
= 0;
9649 static int nvar
= 0;
9651 gfc_forall_iterator
*fa
;
9656 /* Start to resolve a FORALL construct */
9657 if (forall_save
== 0)
9659 /* Count the total number of FORALL index in the nested FORALL
9660 construct in order to allocate the VAR_EXPR with proper size. */
9661 total_var
= gfc_count_forall_iterators (code
);
9663 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9664 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9667 /* The information about FORALL iterator, including FORALL index start, end
9668 and stride. The FORALL index can not appear in start, end or stride. */
9669 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9671 /* Check if any outer FORALL index name is the same as the current
9673 for (i
= 0; i
< nvar
; i
++)
9675 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9677 gfc_error ("An outer FORALL construct already has an index "
9678 "with this name %L", &fa
->var
->where
);
9682 /* Record the current FORALL index. */
9683 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9687 /* No memory leak. */
9688 gcc_assert (nvar
<= total_var
);
9691 /* Resolve the FORALL body. */
9692 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9694 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9695 gfc_resolve_blocks (code
->block
, ns
);
9699 /* Free only the VAR_EXPRs allocated in this frame. */
9700 for (i
= nvar
; i
< tmp
; i
++)
9701 gfc_free_expr (var_expr
[i
]);
9705 /* We are in the outermost FORALL construct. */
9706 gcc_assert (forall_save
== 0);
9708 /* VAR_EXPR is not needed any more. */
9715 /* Resolve a BLOCK construct statement. */
9718 resolve_block_construct (gfc_code
* code
)
9720 /* Resolve the BLOCK's namespace. */
9721 gfc_resolve (code
->ext
.block
.ns
);
9723 /* For an ASSOCIATE block, the associations (and their targets) are already
9724 resolved during resolve_symbol. */
9728 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9732 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9736 for (; b
; b
= b
->block
)
9738 t
= gfc_resolve_expr (b
->expr1
);
9739 if (!gfc_resolve_expr (b
->expr2
))
9745 if (t
&& b
->expr1
!= NULL
9746 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9747 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9754 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9755 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9760 resolve_branch (b
->label1
, b
);
9764 resolve_block_construct (b
);
9768 case EXEC_SELECT_TYPE
:
9772 case EXEC_DO_CONCURRENT
:
9780 case EXEC_OMP_ATOMIC
:
9781 case EXEC_OACC_ATOMIC
:
9783 gfc_omp_atomic_op aop
9784 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
9786 /* Verify this before calling gfc_resolve_code, which might
9788 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
9789 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
9790 && b
->next
->next
== NULL
)
9791 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
9792 && b
->next
->next
!= NULL
9793 && b
->next
->next
->op
== EXEC_ASSIGN
9794 && b
->next
->next
->next
== NULL
));
9798 case EXEC_OACC_PARALLEL_LOOP
:
9799 case EXEC_OACC_PARALLEL
:
9800 case EXEC_OACC_KERNELS_LOOP
:
9801 case EXEC_OACC_KERNELS
:
9802 case EXEC_OACC_DATA
:
9803 case EXEC_OACC_HOST_DATA
:
9804 case EXEC_OACC_LOOP
:
9805 case EXEC_OACC_UPDATE
:
9806 case EXEC_OACC_WAIT
:
9807 case EXEC_OACC_CACHE
:
9808 case EXEC_OACC_ENTER_DATA
:
9809 case EXEC_OACC_EXIT_DATA
:
9810 case EXEC_OACC_ROUTINE
:
9811 case EXEC_OMP_CRITICAL
:
9812 case EXEC_OMP_DISTRIBUTE
:
9813 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9814 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9815 case EXEC_OMP_DISTRIBUTE_SIMD
:
9817 case EXEC_OMP_DO_SIMD
:
9818 case EXEC_OMP_MASTER
:
9819 case EXEC_OMP_ORDERED
:
9820 case EXEC_OMP_PARALLEL
:
9821 case EXEC_OMP_PARALLEL_DO
:
9822 case EXEC_OMP_PARALLEL_DO_SIMD
:
9823 case EXEC_OMP_PARALLEL_SECTIONS
:
9824 case EXEC_OMP_PARALLEL_WORKSHARE
:
9825 case EXEC_OMP_SECTIONS
:
9827 case EXEC_OMP_SINGLE
:
9828 case EXEC_OMP_TARGET
:
9829 case EXEC_OMP_TARGET_DATA
:
9830 case EXEC_OMP_TARGET_ENTER_DATA
:
9831 case EXEC_OMP_TARGET_EXIT_DATA
:
9832 case EXEC_OMP_TARGET_PARALLEL
:
9833 case EXEC_OMP_TARGET_PARALLEL_DO
:
9834 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
9835 case EXEC_OMP_TARGET_SIMD
:
9836 case EXEC_OMP_TARGET_TEAMS
:
9837 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9838 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9839 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9840 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9841 case EXEC_OMP_TARGET_UPDATE
:
9843 case EXEC_OMP_TASKGROUP
:
9844 case EXEC_OMP_TASKLOOP
:
9845 case EXEC_OMP_TASKLOOP_SIMD
:
9846 case EXEC_OMP_TASKWAIT
:
9847 case EXEC_OMP_TASKYIELD
:
9848 case EXEC_OMP_TEAMS
:
9849 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9850 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9851 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9852 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9853 case EXEC_OMP_WORKSHARE
:
9857 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9860 gfc_resolve_code (b
->next
, ns
);
9865 /* Does everything to resolve an ordinary assignment. Returns true
9866 if this is an interface assignment. */
9868 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9877 symbol_attribute attr
;
9879 if (gfc_extend_assign (code
, ns
))
9883 if (code
->op
== EXEC_ASSIGN_CALL
)
9885 lhs
= code
->ext
.actual
->expr
;
9886 rhsptr
= &code
->ext
.actual
->next
->expr
;
9890 gfc_actual_arglist
* args
;
9891 gfc_typebound_proc
* tbp
;
9893 gcc_assert (code
->op
== EXEC_COMPCALL
);
9895 args
= code
->expr1
->value
.compcall
.actual
;
9897 rhsptr
= &args
->next
->expr
;
9899 tbp
= code
->expr1
->value
.compcall
.tbp
;
9900 gcc_assert (!tbp
->is_generic
);
9903 /* Make a temporary rhs when there is a default initializer
9904 and rhs is the same symbol as the lhs. */
9905 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9906 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9907 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9908 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9909 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9918 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9919 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9923 /* Handle the case of a BOZ literal on the RHS. */
9924 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9927 if (warn_surprising
)
9928 gfc_warning (OPT_Wsurprising
,
9929 "BOZ literal at %L is bitwise transferred "
9930 "non-integer symbol %qs", &code
->loc
,
9931 lhs
->symtree
->n
.sym
->name
);
9933 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9935 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9937 if (rc
== ARITH_UNDERFLOW
)
9938 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9939 ". This check can be disabled with the option "
9940 "%<-fno-range-check%>", &rhs
->where
);
9941 else if (rc
== ARITH_OVERFLOW
)
9942 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9943 ". This check can be disabled with the option "
9944 "%<-fno-range-check%>", &rhs
->where
);
9945 else if (rc
== ARITH_NAN
)
9946 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9947 ". This check can be disabled with the option "
9948 "%<-fno-range-check%>", &rhs
->where
);
9953 if (lhs
->ts
.type
== BT_CHARACTER
9954 && warn_character_truncation
)
9956 if (lhs
->ts
.u
.cl
!= NULL
9957 && lhs
->ts
.u
.cl
->length
!= NULL
9958 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9959 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9961 if (rhs
->expr_type
== EXPR_CONSTANT
)
9962 rlen
= rhs
->value
.character
.length
;
9964 else if (rhs
->ts
.u
.cl
!= NULL
9965 && rhs
->ts
.u
.cl
->length
!= NULL
9966 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9967 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9969 if (rlen
&& llen
&& rlen
> llen
)
9970 gfc_warning_now (OPT_Wcharacter_truncation
,
9971 "CHARACTER expression will be truncated "
9972 "in assignment (%d/%d) at %L",
9973 llen
, rlen
, &code
->loc
);
9976 /* Ensure that a vector index expression for the lvalue is evaluated
9977 to a temporary if the lvalue symbol is referenced in it. */
9980 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9981 if (ref
->type
== REF_ARRAY
)
9983 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9984 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9985 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9986 ref
->u
.ar
.start
[n
]))
9988 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9992 if (gfc_pure (NULL
))
9994 if (lhs
->ts
.type
== BT_DERIVED
9995 && lhs
->expr_type
== EXPR_VARIABLE
9996 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9997 && rhs
->expr_type
== EXPR_VARIABLE
9998 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9999 || gfc_is_coindexed (rhs
)))
10001 /* F2008, C1283. */
10002 if (gfc_is_coindexed (rhs
))
10003 gfc_error ("Coindexed expression at %L is assigned to "
10004 "a derived type variable with a POINTER "
10005 "component in a PURE procedure",
10008 gfc_error ("The impure variable at %L is assigned to "
10009 "a derived type variable with a POINTER "
10010 "component in a PURE procedure (12.6)",
10015 /* Fortran 2008, C1283. */
10016 if (gfc_is_coindexed (lhs
))
10018 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10019 "procedure", &rhs
->where
);
10024 if (gfc_implicit_pure (NULL
))
10026 if (lhs
->expr_type
== EXPR_VARIABLE
10027 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10028 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10029 gfc_unset_implicit_pure (NULL
);
10031 if (lhs
->ts
.type
== BT_DERIVED
10032 && lhs
->expr_type
== EXPR_VARIABLE
10033 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10034 && rhs
->expr_type
== EXPR_VARIABLE
10035 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10036 || gfc_is_coindexed (rhs
)))
10037 gfc_unset_implicit_pure (NULL
);
10039 /* Fortran 2008, C1283. */
10040 if (gfc_is_coindexed (lhs
))
10041 gfc_unset_implicit_pure (NULL
);
10044 /* F2008, 7.2.1.2. */
10045 attr
= gfc_expr_attr (lhs
);
10046 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10048 if (attr
.codimension
)
10050 gfc_error ("Assignment to polymorphic coarray at %L is not "
10051 "permitted", &lhs
->where
);
10054 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10055 "polymorphic variable at %L", &lhs
->where
))
10057 if (!flag_realloc_lhs
)
10059 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10060 "requires %<-frealloc-lhs%>", &lhs
->where
);
10064 else if (lhs
->ts
.type
== BT_CLASS
)
10066 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10067 "assignment at %L - check that there is a matching specific "
10068 "subroutine for '=' operator", &lhs
->where
);
10072 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10074 /* F2008, Section 7.2.1.2. */
10075 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10077 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10078 "component in assignment at %L", &lhs
->where
);
10082 /* Assign the 'data' of a class object to a derived type. */
10083 if (lhs
->ts
.type
== BT_DERIVED
10084 && rhs
->ts
.type
== BT_CLASS
)
10085 gfc_add_data_component (rhs
);
10087 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10089 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10090 && code
->expr2
->value
.function
.isym
10091 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10092 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10093 && !gfc_expr_attr (rhs
).allocatable
10094 && !gfc_has_vector_subscript (rhs
)));
10096 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10098 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10099 Additionally, insert this code when the RHS is a CAF as we then use the
10100 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10101 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10102 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10104 if (caf_convert_to_send
)
10106 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10107 && code
->expr2
->value
.function
.isym
10108 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10109 remove_caf_get_intrinsic (code
->expr2
);
10110 code
->op
= EXEC_CALL
;
10111 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10112 code
->resolved_sym
= code
->symtree
->n
.sym
;
10113 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10114 code
->resolved_sym
->attr
.intrinsic
= 1;
10115 code
->resolved_sym
->attr
.subroutine
= 1;
10116 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10117 gfc_commit_symbol (code
->resolved_sym
);
10118 code
->ext
.actual
= gfc_get_actual_arglist ();
10119 code
->ext
.actual
->expr
= lhs
;
10120 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10121 code
->ext
.actual
->next
->expr
= rhs
;
10122 code
->expr1
= NULL
;
10123 code
->expr2
= NULL
;
10130 /* Add a component reference onto an expression. */
10133 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10138 ref
= &((*ref
)->next
);
10139 *ref
= gfc_get_ref ();
10140 (*ref
)->type
= REF_COMPONENT
;
10141 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10142 (*ref
)->u
.c
.component
= c
;
10145 /* Add a full array ref, as necessary. */
10148 gfc_add_full_array_ref (e
, c
->as
);
10149 e
->rank
= c
->as
->rank
;
10154 /* Build an assignment. Keep the argument 'op' for future use, so that
10155 pointer assignments can be made. */
10158 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10159 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10161 gfc_code
*this_code
;
10163 this_code
= gfc_get_code (op
);
10164 this_code
->next
= NULL
;
10165 this_code
->expr1
= gfc_copy_expr (expr1
);
10166 this_code
->expr2
= gfc_copy_expr (expr2
);
10167 this_code
->loc
= loc
;
10168 if (comp1
&& comp2
)
10170 add_comp_ref (this_code
->expr1
, comp1
);
10171 add_comp_ref (this_code
->expr2
, comp2
);
10178 /* Makes a temporary variable expression based on the characteristics of
10179 a given variable expression. */
10182 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10184 static int serial
= 0;
10185 char name
[GFC_MAX_SYMBOL_LEN
];
10187 gfc_array_spec
*as
;
10188 gfc_array_ref
*aref
;
10191 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10192 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10193 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10199 /* Obtain the arrayspec for the temporary. */
10200 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10201 && e
->expr_type
!= EXPR_FUNCTION
10202 && e
->expr_type
!= EXPR_OP
)
10204 aref
= gfc_find_array_ref (e
);
10205 if (e
->expr_type
== EXPR_VARIABLE
10206 && e
->symtree
->n
.sym
->as
== aref
->as
)
10210 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10211 if (ref
->type
== REF_COMPONENT
10212 && ref
->u
.c
.component
->as
== aref
->as
)
10220 /* Add the attributes and the arrayspec to the temporary. */
10221 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10222 tmp
->n
.sym
->attr
.function
= 0;
10223 tmp
->n
.sym
->attr
.result
= 0;
10224 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10228 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10231 if (as
->type
== AS_DEFERRED
)
10232 tmp
->n
.sym
->attr
.allocatable
= 1;
10234 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10235 || e
->expr_type
== EXPR_FUNCTION
10236 || e
->expr_type
== EXPR_OP
))
10238 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10239 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10240 tmp
->n
.sym
->as
->rank
= e
->rank
;
10241 tmp
->n
.sym
->attr
.allocatable
= 1;
10242 tmp
->n
.sym
->attr
.dimension
= 1;
10245 tmp
->n
.sym
->attr
.dimension
= 0;
10247 gfc_set_sym_referenced (tmp
->n
.sym
);
10248 gfc_commit_symbol (tmp
->n
.sym
);
10249 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10251 /* Should the lhs be a section, use its array ref for the
10252 temporary expression. */
10253 if (aref
&& aref
->type
!= AR_FULL
)
10255 gfc_free_ref_list (e
->ref
);
10256 e
->ref
= gfc_copy_ref (ref
);
10262 /* Add one line of code to the code chain, making sure that 'head' and
10263 'tail' are appropriately updated. */
10266 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10268 gcc_assert (this_code
);
10270 *head
= *tail
= *this_code
;
10272 *tail
= gfc_append_code (*tail
, *this_code
);
10277 /* Counts the potential number of part array references that would
10278 result from resolution of typebound defined assignments. */
10281 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10284 int c_depth
= 0, t_depth
;
10286 for (c
= derived
->components
; c
; c
= c
->next
)
10288 if ((!gfc_bt_struct (c
->ts
.type
)
10290 || c
->attr
.allocatable
10291 || c
->attr
.proc_pointer_comp
10292 || c
->attr
.class_pointer
10293 || c
->attr
.proc_pointer
)
10294 && !c
->attr
.defined_assign_comp
)
10297 if (c
->as
&& c_depth
== 0)
10300 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10301 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10306 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10308 return depth
+ c_depth
;
10312 /* Implement 7.2.1.3 of the F08 standard:
10313 "An intrinsic assignment where the variable is of derived type is
10314 performed as if each component of the variable were assigned from the
10315 corresponding component of expr using pointer assignment (7.2.2) for
10316 each pointer component, defined assignment for each nonpointer
10317 nonallocatable component of a type that has a type-bound defined
10318 assignment consistent with the component, intrinsic assignment for
10319 each other nonpointer nonallocatable component, ..."
10321 The pointer assignments are taken care of by the intrinsic
10322 assignment of the structure itself. This function recursively adds
10323 defined assignments where required. The recursion is accomplished
10324 by calling gfc_resolve_code.
10326 When the lhs in a defined assignment has intent INOUT, we need a
10327 temporary for the lhs. In pseudo-code:
10329 ! Only call function lhs once.
10330 if (lhs is not a constant or an variable)
10333 ! Do the intrinsic assignment
10335 ! Now do the defined assignments
10336 do over components with typebound defined assignment [%cmp]
10337 #if one component's assignment procedure is INOUT
10339 #if expr2 non-variable
10345 t1%cmp {defined=} expr2%cmp
10351 expr1%cmp {defined=} expr2%cmp
10355 /* The temporary assignments have to be put on top of the additional
10356 code to avoid the result being changed by the intrinsic assignment.
10358 static int component_assignment_level
= 0;
10359 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10362 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10364 gfc_component
*comp1
, *comp2
;
10365 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10367 int error_count
, depth
;
10369 gfc_get_errors (NULL
, &error_count
);
10371 /* Filter out continuing processing after an error. */
10373 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10374 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10377 /* TODO: Handle more than one part array reference in assignments. */
10378 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10379 (*code
)->expr1
->rank
? 1 : 0);
10382 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10383 "done because multiple part array references would "
10384 "occur in intermediate expressions.", &(*code
)->loc
);
10388 component_assignment_level
++;
10390 /* Create a temporary so that functions get called only once. */
10391 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10392 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10394 gfc_expr
*tmp_expr
;
10396 /* Assign the rhs to the temporary. */
10397 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10398 this_code
= build_assignment (EXEC_ASSIGN
,
10399 tmp_expr
, (*code
)->expr2
,
10400 NULL
, NULL
, (*code
)->loc
);
10401 /* Add the code and substitute the rhs expression. */
10402 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10403 gfc_free_expr ((*code
)->expr2
);
10404 (*code
)->expr2
= tmp_expr
;
10407 /* Do the intrinsic assignment. This is not needed if the lhs is one
10408 of the temporaries generated here, since the intrinsic assignment
10409 to the final result already does this. */
10410 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10412 this_code
= build_assignment (EXEC_ASSIGN
,
10413 (*code
)->expr1
, (*code
)->expr2
,
10414 NULL
, NULL
, (*code
)->loc
);
10415 add_code_to_chain (&this_code
, &head
, &tail
);
10418 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10419 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10422 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10424 bool inout
= false;
10426 /* The intrinsic assignment does the right thing for pointers
10427 of all kinds and allocatable components. */
10428 if (!gfc_bt_struct (comp1
->ts
.type
)
10429 || comp1
->attr
.pointer
10430 || comp1
->attr
.allocatable
10431 || comp1
->attr
.proc_pointer_comp
10432 || comp1
->attr
.class_pointer
10433 || comp1
->attr
.proc_pointer
)
10436 /* Make an assigment for this component. */
10437 this_code
= build_assignment (EXEC_ASSIGN
,
10438 (*code
)->expr1
, (*code
)->expr2
,
10439 comp1
, comp2
, (*code
)->loc
);
10441 /* Convert the assignment if there is a defined assignment for
10442 this type. Otherwise, using the call from gfc_resolve_code,
10443 recurse into its components. */
10444 gfc_resolve_code (this_code
, ns
);
10446 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10448 gfc_formal_arglist
*dummy_args
;
10450 /* Check that there is a typebound defined assignment. If not,
10451 then this must be a module defined assignment. We cannot
10452 use the defined_assign_comp attribute here because it must
10453 be this derived type that has the defined assignment and not
10455 if (!(comp1
->ts
.u
.derived
->f2k_derived
10456 && comp1
->ts
.u
.derived
->f2k_derived
10457 ->tb_op
[INTRINSIC_ASSIGN
]))
10459 gfc_free_statements (this_code
);
10464 /* If the first argument of the subroutine has intent INOUT
10465 a temporary must be generated and used instead. */
10466 rsym
= this_code
->resolved_sym
;
10467 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10469 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10471 gfc_code
*temp_code
;
10474 /* Build the temporary required for the assignment and put
10475 it at the head of the generated code. */
10478 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10479 temp_code
= build_assignment (EXEC_ASSIGN
,
10480 t1
, (*code
)->expr1
,
10481 NULL
, NULL
, (*code
)->loc
);
10483 /* For allocatable LHS, check whether it is allocated. Note
10484 that allocatable components with defined assignment are
10485 not yet support. See PR 57696. */
10486 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10490 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10491 block
= gfc_get_code (EXEC_IF
);
10492 block
->block
= gfc_get_code (EXEC_IF
);
10493 block
->block
->expr1
10494 = gfc_build_intrinsic_call (ns
,
10495 GFC_ISYM_ALLOCATED
, "allocated",
10496 (*code
)->loc
, 1, e
);
10497 block
->block
->next
= temp_code
;
10500 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10503 /* Replace the first actual arg with the component of the
10505 gfc_free_expr (this_code
->ext
.actual
->expr
);
10506 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10507 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10509 /* If the LHS variable is allocatable and wasn't allocated and
10510 the temporary is allocatable, pointer assign the address of
10511 the freshly allocated LHS to the temporary. */
10512 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10513 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10518 cond
= gfc_get_expr ();
10519 cond
->ts
.type
= BT_LOGICAL
;
10520 cond
->ts
.kind
= gfc_default_logical_kind
;
10521 cond
->expr_type
= EXPR_OP
;
10522 cond
->where
= (*code
)->loc
;
10523 cond
->value
.op
.op
= INTRINSIC_NOT
;
10524 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10525 GFC_ISYM_ALLOCATED
, "allocated",
10526 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10527 block
= gfc_get_code (EXEC_IF
);
10528 block
->block
= gfc_get_code (EXEC_IF
);
10529 block
->block
->expr1
= cond
;
10530 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10531 t1
, (*code
)->expr1
,
10532 NULL
, NULL
, (*code
)->loc
);
10533 add_code_to_chain (&block
, &head
, &tail
);
10537 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10539 /* Don't add intrinsic assignments since they are already
10540 effected by the intrinsic assignment of the structure. */
10541 gfc_free_statements (this_code
);
10546 add_code_to_chain (&this_code
, &head
, &tail
);
10550 /* Transfer the value to the final result. */
10551 this_code
= build_assignment (EXEC_ASSIGN
,
10552 (*code
)->expr1
, t1
,
10553 comp1
, comp2
, (*code
)->loc
);
10554 add_code_to_chain (&this_code
, &head
, &tail
);
10558 /* Put the temporary assignments at the top of the generated code. */
10559 if (tmp_head
&& component_assignment_level
== 1)
10561 gfc_append_code (tmp_head
, head
);
10563 tmp_head
= tmp_tail
= NULL
;
10566 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10567 // not accidentally deallocated. Hence, nullify t1.
10568 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10569 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10575 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10576 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10577 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10578 block
= gfc_get_code (EXEC_IF
);
10579 block
->block
= gfc_get_code (EXEC_IF
);
10580 block
->block
->expr1
= cond
;
10581 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10582 t1
, gfc_get_null_expr (&(*code
)->loc
),
10583 NULL
, NULL
, (*code
)->loc
);
10584 gfc_append_code (tail
, block
);
10588 /* Now attach the remaining code chain to the input code. Step on
10589 to the end of the new code since resolution is complete. */
10590 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10591 tail
->next
= (*code
)->next
;
10592 /* Overwrite 'code' because this would place the intrinsic assignment
10593 before the temporary for the lhs is created. */
10594 gfc_free_expr ((*code
)->expr1
);
10595 gfc_free_expr ((*code
)->expr2
);
10601 component_assignment_level
--;
10605 /* F2008: Pointer function assignments are of the form:
10606 ptr_fcn (args) = expr
10607 This function breaks these assignments into two statements:
10608 temporary_pointer => ptr_fcn(args)
10609 temporary_pointer = expr */
10612 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10614 gfc_expr
*tmp_ptr_expr
;
10615 gfc_code
*this_code
;
10616 gfc_component
*comp
;
10619 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10622 /* Even if standard does not support this feature, continue to build
10623 the two statements to avoid upsetting frontend_passes.c. */
10624 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10625 "%L", &(*code
)->loc
);
10627 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10630 s
= comp
->ts
.interface
;
10632 s
= (*code
)->expr1
->symtree
->n
.sym
;
10634 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10636 gfc_error ("The function result on the lhs of the assignment at "
10637 "%L must have the pointer attribute.",
10638 &(*code
)->expr1
->where
);
10639 (*code
)->op
= EXEC_NOP
;
10643 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10645 /* get_temp_from_expression is set up for ordinary assignments. To that
10646 end, where array bounds are not known, arrays are made allocatable.
10647 Change the temporary to a pointer here. */
10648 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10649 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10650 tmp_ptr_expr
->where
= (*code
)->loc
;
10652 this_code
= build_assignment (EXEC_ASSIGN
,
10653 tmp_ptr_expr
, (*code
)->expr2
,
10654 NULL
, NULL
, (*code
)->loc
);
10655 this_code
->next
= (*code
)->next
;
10656 (*code
)->next
= this_code
;
10657 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10658 (*code
)->expr2
= (*code
)->expr1
;
10659 (*code
)->expr1
= tmp_ptr_expr
;
10665 /* Deferred character length assignments from an operator expression
10666 require a temporary because the character length of the lhs can
10667 change in the course of the assignment. */
10670 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10672 gfc_expr
*tmp_expr
;
10673 gfc_code
*this_code
;
10675 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10676 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10677 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10680 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10683 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10684 tmp_expr
->where
= (*code
)->loc
;
10686 /* A new charlen is required to ensure that the variable string
10687 length is different to that of the original lhs. */
10688 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10689 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10690 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10691 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10693 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10695 this_code
= build_assignment (EXEC_ASSIGN
,
10697 gfc_copy_expr (tmp_expr
),
10698 NULL
, NULL
, (*code
)->loc
);
10700 (*code
)->expr1
= tmp_expr
;
10702 this_code
->next
= (*code
)->next
;
10703 (*code
)->next
= this_code
;
10709 /* Given a block of code, recursively resolve everything pointed to by this
10713 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10715 int omp_workshare_save
;
10716 int forall_save
, do_concurrent_save
;
10720 frame
.prev
= cs_base
;
10724 find_reachable_labels (code
);
10726 for (; code
; code
= code
->next
)
10728 frame
.current
= code
;
10729 forall_save
= forall_flag
;
10730 do_concurrent_save
= gfc_do_concurrent_flag
;
10732 if (code
->op
== EXEC_FORALL
)
10735 gfc_resolve_forall (code
, ns
, forall_save
);
10738 else if (code
->block
)
10740 omp_workshare_save
= -1;
10743 case EXEC_OACC_PARALLEL_LOOP
:
10744 case EXEC_OACC_PARALLEL
:
10745 case EXEC_OACC_KERNELS_LOOP
:
10746 case EXEC_OACC_KERNELS
:
10747 case EXEC_OACC_DATA
:
10748 case EXEC_OACC_HOST_DATA
:
10749 case EXEC_OACC_LOOP
:
10750 gfc_resolve_oacc_blocks (code
, ns
);
10752 case EXEC_OMP_PARALLEL_WORKSHARE
:
10753 omp_workshare_save
= omp_workshare_flag
;
10754 omp_workshare_flag
= 1;
10755 gfc_resolve_omp_parallel_blocks (code
, ns
);
10757 case EXEC_OMP_PARALLEL
:
10758 case EXEC_OMP_PARALLEL_DO
:
10759 case EXEC_OMP_PARALLEL_DO_SIMD
:
10760 case EXEC_OMP_PARALLEL_SECTIONS
:
10761 case EXEC_OMP_TARGET_PARALLEL
:
10762 case EXEC_OMP_TARGET_PARALLEL_DO
:
10763 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10764 case EXEC_OMP_TARGET_TEAMS
:
10765 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10766 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10767 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10768 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10769 case EXEC_OMP_TASK
:
10770 case EXEC_OMP_TEAMS
:
10771 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10772 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10773 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10774 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10775 omp_workshare_save
= omp_workshare_flag
;
10776 omp_workshare_flag
= 0;
10777 gfc_resolve_omp_parallel_blocks (code
, ns
);
10779 case EXEC_OMP_DISTRIBUTE
:
10780 case EXEC_OMP_DISTRIBUTE_SIMD
:
10782 case EXEC_OMP_DO_SIMD
:
10783 case EXEC_OMP_SIMD
:
10784 case EXEC_OMP_TARGET_SIMD
:
10785 case EXEC_OMP_TASKLOOP
:
10786 case EXEC_OMP_TASKLOOP_SIMD
:
10787 gfc_resolve_omp_do_blocks (code
, ns
);
10789 case EXEC_SELECT_TYPE
:
10790 /* Blocks are handled in resolve_select_type because we have
10791 to transform the SELECT TYPE into ASSOCIATE first. */
10793 case EXEC_DO_CONCURRENT
:
10794 gfc_do_concurrent_flag
= 1;
10795 gfc_resolve_blocks (code
->block
, ns
);
10796 gfc_do_concurrent_flag
= 2;
10798 case EXEC_OMP_WORKSHARE
:
10799 omp_workshare_save
= omp_workshare_flag
;
10800 omp_workshare_flag
= 1;
10803 gfc_resolve_blocks (code
->block
, ns
);
10807 if (omp_workshare_save
!= -1)
10808 omp_workshare_flag
= omp_workshare_save
;
10812 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10813 t
= gfc_resolve_expr (code
->expr1
);
10814 forall_flag
= forall_save
;
10815 gfc_do_concurrent_flag
= do_concurrent_save
;
10817 if (!gfc_resolve_expr (code
->expr2
))
10820 if (code
->op
== EXEC_ALLOCATE
10821 && !gfc_resolve_expr (code
->expr3
))
10827 case EXEC_END_BLOCK
:
10828 case EXEC_END_NESTED_BLOCK
:
10832 case EXEC_ERROR_STOP
:
10834 case EXEC_CONTINUE
:
10836 case EXEC_ASSIGN_CALL
:
10839 case EXEC_CRITICAL
:
10840 resolve_critical (code
);
10843 case EXEC_SYNC_ALL
:
10844 case EXEC_SYNC_IMAGES
:
10845 case EXEC_SYNC_MEMORY
:
10846 resolve_sync (code
);
10851 case EXEC_EVENT_POST
:
10852 case EXEC_EVENT_WAIT
:
10853 resolve_lock_unlock_event (code
);
10857 /* Keep track of which entry we are up to. */
10858 current_entry_id
= code
->ext
.entry
->id
;
10862 resolve_where (code
, NULL
);
10866 if (code
->expr1
!= NULL
)
10868 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10869 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10870 "INTEGER variable", &code
->expr1
->where
);
10871 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10872 gfc_error ("Variable %qs has not been assigned a target "
10873 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10874 &code
->expr1
->where
);
10877 resolve_branch (code
->label1
, code
);
10881 if (code
->expr1
!= NULL
10882 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10883 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10884 "INTEGER return specifier", &code
->expr1
->where
);
10887 case EXEC_INIT_ASSIGN
:
10888 case EXEC_END_PROCEDURE
:
10895 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10897 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10898 && code
->expr1
->value
.function
.isym
10899 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10900 remove_caf_get_intrinsic (code
->expr1
);
10902 /* If this is a pointer function in an lvalue variable context,
10903 the new code will have to be resolved afresh. This is also the
10904 case with an error, where the code is transformed into NOP to
10905 prevent ICEs downstream. */
10906 if (resolve_ptr_fcn_assign (&code
, ns
)
10907 || code
->op
== EXEC_NOP
)
10910 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10914 if (resolve_ordinary_assign (code
, ns
))
10916 if (code
->op
== EXEC_COMPCALL
)
10922 /* Check for dependencies in deferred character length array
10923 assignments and generate a temporary, if necessary. */
10924 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
10927 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10928 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10929 && code
->expr1
->ts
.u
.derived
10930 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10931 generate_component_assignments (&code
, ns
);
10935 case EXEC_LABEL_ASSIGN
:
10936 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10937 gfc_error ("Label %d referenced at %L is never defined",
10938 code
->label1
->value
, &code
->label1
->where
);
10940 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10941 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10942 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10943 != gfc_default_integer_kind
10944 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10945 gfc_error ("ASSIGN statement at %L requires a scalar "
10946 "default INTEGER variable", &code
->expr1
->where
);
10949 case EXEC_POINTER_ASSIGN
:
10956 /* This is both a variable definition and pointer assignment
10957 context, so check both of them. For rank remapping, a final
10958 array ref may be present on the LHS and fool gfc_expr_attr
10959 used in gfc_check_vardef_context. Remove it. */
10960 e
= remove_last_array_ref (code
->expr1
);
10961 t
= gfc_check_vardef_context (e
, true, false, false,
10962 _("pointer assignment"));
10964 t
= gfc_check_vardef_context (e
, false, false, false,
10965 _("pointer assignment"));
10970 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10972 /* Assigning a class object always is a regular assign. */
10973 if (code
->expr2
->ts
.type
== BT_CLASS
10974 && !CLASS_DATA (code
->expr2
)->attr
.dimension
10975 && !(UNLIMITED_POLY (code
->expr2
)
10976 && code
->expr1
->ts
.type
== BT_DERIVED
10977 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
10978 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
10979 && !(gfc_expr_attr (code
->expr1
).proc_pointer
10980 && code
->expr2
->expr_type
== EXPR_VARIABLE
10981 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
10983 code
->op
= EXEC_ASSIGN
;
10987 case EXEC_ARITHMETIC_IF
:
10989 gfc_expr
*e
= code
->expr1
;
10991 gfc_resolve_expr (e
);
10992 if (e
->expr_type
== EXPR_NULL
)
10993 gfc_error ("Invalid NULL at %L", &e
->where
);
10995 if (t
&& (e
->rank
> 0
10996 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
10997 gfc_error ("Arithmetic IF statement at %L requires a scalar "
10998 "REAL or INTEGER expression", &e
->where
);
11000 resolve_branch (code
->label1
, code
);
11001 resolve_branch (code
->label2
, code
);
11002 resolve_branch (code
->label3
, code
);
11007 if (t
&& code
->expr1
!= NULL
11008 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11009 || code
->expr1
->rank
!= 0))
11010 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11011 &code
->expr1
->where
);
11016 resolve_call (code
);
11019 case EXEC_COMPCALL
:
11021 resolve_typebound_subroutine (code
);
11024 case EXEC_CALL_PPC
:
11025 resolve_ppc_call (code
);
11029 /* Select is complicated. Also, a SELECT construct could be
11030 a transformed computed GOTO. */
11031 resolve_select (code
, false);
11034 case EXEC_SELECT_TYPE
:
11035 resolve_select_type (code
, ns
);
11039 resolve_block_construct (code
);
11043 if (code
->ext
.iterator
!= NULL
)
11045 gfc_iterator
*iter
= code
->ext
.iterator
;
11046 if (gfc_resolve_iterator (iter
, true, false))
11047 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
11051 case EXEC_DO_WHILE
:
11052 if (code
->expr1
== NULL
)
11053 gfc_internal_error ("gfc_resolve_code(): No expression on "
11056 && (code
->expr1
->rank
!= 0
11057 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11058 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11059 "a scalar LOGICAL expression", &code
->expr1
->where
);
11062 case EXEC_ALLOCATE
:
11064 resolve_allocate_deallocate (code
, "ALLOCATE");
11068 case EXEC_DEALLOCATE
:
11070 resolve_allocate_deallocate (code
, "DEALLOCATE");
11075 if (!gfc_resolve_open (code
->ext
.open
))
11078 resolve_branch (code
->ext
.open
->err
, code
);
11082 if (!gfc_resolve_close (code
->ext
.close
))
11085 resolve_branch (code
->ext
.close
->err
, code
);
11088 case EXEC_BACKSPACE
:
11092 if (!gfc_resolve_filepos (code
->ext
.filepos
))
11095 resolve_branch (code
->ext
.filepos
->err
, code
);
11099 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11102 resolve_branch (code
->ext
.inquire
->err
, code
);
11105 case EXEC_IOLENGTH
:
11106 gcc_assert (code
->ext
.inquire
!= NULL
);
11107 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11110 resolve_branch (code
->ext
.inquire
->err
, code
);
11114 if (!gfc_resolve_wait (code
->ext
.wait
))
11117 resolve_branch (code
->ext
.wait
->err
, code
);
11118 resolve_branch (code
->ext
.wait
->end
, code
);
11119 resolve_branch (code
->ext
.wait
->eor
, code
);
11124 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11127 resolve_branch (code
->ext
.dt
->err
, code
);
11128 resolve_branch (code
->ext
.dt
->end
, code
);
11129 resolve_branch (code
->ext
.dt
->eor
, code
);
11132 case EXEC_TRANSFER
:
11133 resolve_transfer (code
);
11136 case EXEC_DO_CONCURRENT
:
11138 resolve_forall_iterators (code
->ext
.forall_iterator
);
11140 if (code
->expr1
!= NULL
11141 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11142 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11143 "expression", &code
->expr1
->where
);
11146 case EXEC_OACC_PARALLEL_LOOP
:
11147 case EXEC_OACC_PARALLEL
:
11148 case EXEC_OACC_KERNELS_LOOP
:
11149 case EXEC_OACC_KERNELS
:
11150 case EXEC_OACC_DATA
:
11151 case EXEC_OACC_HOST_DATA
:
11152 case EXEC_OACC_LOOP
:
11153 case EXEC_OACC_UPDATE
:
11154 case EXEC_OACC_WAIT
:
11155 case EXEC_OACC_CACHE
:
11156 case EXEC_OACC_ENTER_DATA
:
11157 case EXEC_OACC_EXIT_DATA
:
11158 case EXEC_OACC_ATOMIC
:
11159 case EXEC_OACC_DECLARE
:
11160 gfc_resolve_oacc_directive (code
, ns
);
11163 case EXEC_OMP_ATOMIC
:
11164 case EXEC_OMP_BARRIER
:
11165 case EXEC_OMP_CANCEL
:
11166 case EXEC_OMP_CANCELLATION_POINT
:
11167 case EXEC_OMP_CRITICAL
:
11168 case EXEC_OMP_FLUSH
:
11169 case EXEC_OMP_DISTRIBUTE
:
11170 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11171 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11172 case EXEC_OMP_DISTRIBUTE_SIMD
:
11174 case EXEC_OMP_DO_SIMD
:
11175 case EXEC_OMP_MASTER
:
11176 case EXEC_OMP_ORDERED
:
11177 case EXEC_OMP_SECTIONS
:
11178 case EXEC_OMP_SIMD
:
11179 case EXEC_OMP_SINGLE
:
11180 case EXEC_OMP_TARGET
:
11181 case EXEC_OMP_TARGET_DATA
:
11182 case EXEC_OMP_TARGET_ENTER_DATA
:
11183 case EXEC_OMP_TARGET_EXIT_DATA
:
11184 case EXEC_OMP_TARGET_PARALLEL
:
11185 case EXEC_OMP_TARGET_PARALLEL_DO
:
11186 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11187 case EXEC_OMP_TARGET_SIMD
:
11188 case EXEC_OMP_TARGET_TEAMS
:
11189 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11190 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11191 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11192 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11193 case EXEC_OMP_TARGET_UPDATE
:
11194 case EXEC_OMP_TASK
:
11195 case EXEC_OMP_TASKGROUP
:
11196 case EXEC_OMP_TASKLOOP
:
11197 case EXEC_OMP_TASKLOOP_SIMD
:
11198 case EXEC_OMP_TASKWAIT
:
11199 case EXEC_OMP_TASKYIELD
:
11200 case EXEC_OMP_TEAMS
:
11201 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11202 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11203 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11204 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11205 case EXEC_OMP_WORKSHARE
:
11206 gfc_resolve_omp_directive (code
, ns
);
11209 case EXEC_OMP_PARALLEL
:
11210 case EXEC_OMP_PARALLEL_DO
:
11211 case EXEC_OMP_PARALLEL_DO_SIMD
:
11212 case EXEC_OMP_PARALLEL_SECTIONS
:
11213 case EXEC_OMP_PARALLEL_WORKSHARE
:
11214 omp_workshare_save
= omp_workshare_flag
;
11215 omp_workshare_flag
= 0;
11216 gfc_resolve_omp_directive (code
, ns
);
11217 omp_workshare_flag
= omp_workshare_save
;
11221 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11225 cs_base
= frame
.prev
;
11229 /* Resolve initial values and make sure they are compatible with
11233 resolve_values (gfc_symbol
*sym
)
11237 if (sym
->value
== NULL
)
11240 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11241 t
= resolve_structure_cons (sym
->value
, 1);
11243 t
= gfc_resolve_expr (sym
->value
);
11248 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11252 /* Verify any BIND(C) derived types in the namespace so we can report errors
11253 for them once, rather than for each variable declared of that type. */
11256 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11258 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11259 && derived_sym
->attr
.is_bind_c
== 1)
11260 verify_bind_c_derived_type (derived_sym
);
11266 /* Check the interfaces of DTIO procedures associated with derived
11267 type 'sym'. These procedures can either have typebound bindings or
11268 can appear in DTIO generic interfaces. */
11271 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11273 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11276 gfc_check_dtio_interfaces (sym
);
11281 /* Verify that any binding labels used in a given namespace do not collide
11282 with the names or binding labels of any global symbols. Multiple INTERFACE
11283 for the same procedure are permitted. */
11286 gfc_verify_binding_labels (gfc_symbol
*sym
)
11289 const char *module
;
11291 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11292 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11295 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11298 module
= sym
->module
;
11299 else if (sym
->ns
&& sym
->ns
->proc_name
11300 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11301 module
= sym
->ns
->proc_name
->name
;
11302 else if (sym
->ns
&& sym
->ns
->parent
11303 && sym
->ns
&& sym
->ns
->parent
->proc_name
11304 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11305 module
= sym
->ns
->parent
->proc_name
->name
;
11311 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11314 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11315 gsym
->where
= sym
->declared_at
;
11316 gsym
->sym_name
= sym
->name
;
11317 gsym
->binding_label
= sym
->binding_label
;
11318 gsym
->ns
= sym
->ns
;
11319 gsym
->mod_name
= module
;
11320 if (sym
->attr
.function
)
11321 gsym
->type
= GSYM_FUNCTION
;
11322 else if (sym
->attr
.subroutine
)
11323 gsym
->type
= GSYM_SUBROUTINE
;
11324 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11325 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11329 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11331 gfc_error ("Variable %s with binding label %s at %L uses the same global "
11332 "identifier as entity at %L", sym
->name
,
11333 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11334 /* Clear the binding label to prevent checking multiple times. */
11335 sym
->binding_label
= NULL
;
11338 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11339 && (strcmp (module
, gsym
->mod_name
) != 0
11340 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11342 /* This can only happen if the variable is defined in a module - if it
11343 isn't the same module, reject it. */
11344 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
11345 "the same global identifier as entity at %L from module %s",
11346 sym
->name
, module
, sym
->binding_label
,
11347 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11348 sym
->binding_label
= NULL
;
11350 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11351 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11352 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11353 && sym
!= gsym
->ns
->proc_name
11354 && (module
!= gsym
->mod_name
11355 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11356 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11358 /* Print an error if the procedure is defined multiple times; we have to
11359 exclude references to the same procedure via module association or
11360 multiple checks for the same procedure. */
11361 gfc_error ("Procedure %s with binding label %s at %L uses the same "
11362 "global identifier as entity at %L", sym
->name
,
11363 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11364 sym
->binding_label
= NULL
;
11369 /* Resolve an index expression. */
11372 resolve_index_expr (gfc_expr
*e
)
11374 if (!gfc_resolve_expr (e
))
11377 if (!gfc_simplify_expr (e
, 0))
11380 if (!gfc_specification_expr (e
))
11387 /* Resolve a charlen structure. */
11390 resolve_charlen (gfc_charlen
*cl
)
11393 bool saved_specification_expr
;
11399 saved_specification_expr
= specification_expr
;
11400 specification_expr
= true;
11402 if (cl
->length_from_typespec
)
11404 if (!gfc_resolve_expr (cl
->length
))
11406 specification_expr
= saved_specification_expr
;
11410 if (!gfc_simplify_expr (cl
->length
, 0))
11412 specification_expr
= saved_specification_expr
;
11419 if (!resolve_index_expr (cl
->length
))
11421 specification_expr
= saved_specification_expr
;
11426 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11427 a negative value, the length of character entities declared is zero. */
11428 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
11429 gfc_replace_expr (cl
->length
,
11430 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
11432 /* Check that the character length is not too large. */
11433 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11434 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11435 && cl
->length
->ts
.type
== BT_INTEGER
11436 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11438 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11439 specification_expr
= saved_specification_expr
;
11443 specification_expr
= saved_specification_expr
;
11448 /* Test for non-constant shape arrays. */
11451 is_non_constant_shape_array (gfc_symbol
*sym
)
11457 not_constant
= false;
11458 if (sym
->as
!= NULL
)
11460 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11461 has not been simplified; parameter array references. Do the
11462 simplification now. */
11463 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11465 e
= sym
->as
->lower
[i
];
11466 if (e
&& (!resolve_index_expr(e
)
11467 || !gfc_is_constant_expr (e
)))
11468 not_constant
= true;
11469 e
= sym
->as
->upper
[i
];
11470 if (e
&& (!resolve_index_expr(e
)
11471 || !gfc_is_constant_expr (e
)))
11472 not_constant
= true;
11475 return not_constant
;
11478 /* Given a symbol and an initialization expression, add code to initialize
11479 the symbol to the function entry. */
11481 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11485 gfc_namespace
*ns
= sym
->ns
;
11487 /* Search for the function namespace if this is a contained
11488 function without an explicit result. */
11489 if (sym
->attr
.function
&& sym
== sym
->result
11490 && sym
->name
!= sym
->ns
->proc_name
->name
)
11492 ns
= ns
->contained
;
11493 for (;ns
; ns
= ns
->sibling
)
11494 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11500 gfc_free_expr (init
);
11504 /* Build an l-value expression for the result. */
11505 lval
= gfc_lval_expr_from_sym (sym
);
11507 /* Add the code at scope entry. */
11508 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11509 init_st
->next
= ns
->code
;
11510 ns
->code
= init_st
;
11512 /* Assign the default initializer to the l-value. */
11513 init_st
->loc
= sym
->declared_at
;
11514 init_st
->expr1
= lval
;
11515 init_st
->expr2
= init
;
11519 /* Whether or not we can generate a default initializer for a symbol. */
11522 can_generate_init (gfc_symbol
*sym
)
11524 symbol_attribute
*a
;
11529 /* These symbols should never have a default initialization. */
11534 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11535 && (CLASS_DATA (sym
)->attr
.class_pointer
11536 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11537 || a
->in_equivalence
11544 || (!a
->referenced
&& !a
->result
)
11545 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
11546 || (a
->function
&& sym
!= sym
->result
)
11551 /* Assign the default initializer to a derived type variable or result. */
11554 apply_default_init (gfc_symbol
*sym
)
11556 gfc_expr
*init
= NULL
;
11558 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11561 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11562 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11564 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11567 build_init_assign (sym
, init
);
11568 sym
->attr
.referenced
= 1;
11572 /* Build an initializer for a local. Returns null if the symbol should not have
11573 a default initialization. */
11576 build_default_init_expr (gfc_symbol
*sym
)
11578 /* These symbols should never have a default initialization. */
11579 if (sym
->attr
.allocatable
11580 || sym
->attr
.external
11582 || sym
->attr
.pointer
11583 || sym
->attr
.in_equivalence
11584 || sym
->attr
.in_common
11587 || sym
->attr
.cray_pointee
11588 || sym
->attr
.cray_pointer
11592 /* Get the appropriate init expression. */
11593 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
11596 /* Add an initialization expression to a local variable. */
11598 apply_default_init_local (gfc_symbol
*sym
)
11600 gfc_expr
*init
= NULL
;
11602 /* The symbol should be a variable or a function return value. */
11603 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11604 || (sym
->attr
.function
&& sym
->result
!= sym
))
11607 /* Try to build the initializer expression. If we can't initialize
11608 this symbol, then init will be NULL. */
11609 init
= build_default_init_expr (sym
);
11613 /* For saved variables, we don't want to add an initializer at function
11614 entry, so we just add a static initializer. Note that automatic variables
11615 are stack allocated even with -fno-automatic; we have also to exclude
11616 result variable, which are also nonstatic. */
11617 if (!sym
->attr
.automatic
11618 && (sym
->attr
.save
|| sym
->ns
->save_all
11619 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11620 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11621 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
11623 /* Don't clobber an existing initializer! */
11624 gcc_assert (sym
->value
== NULL
);
11629 build_init_assign (sym
, init
);
11633 /* Resolution of common features of flavors variable and procedure. */
11636 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11638 gfc_array_spec
*as
;
11640 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11641 as
= CLASS_DATA (sym
)->as
;
11645 /* Constraints on deferred shape variable. */
11646 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11648 bool pointer
, allocatable
, dimension
;
11650 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11652 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11653 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11654 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11658 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11659 allocatable
= sym
->attr
.allocatable
;
11660 dimension
= sym
->attr
.dimension
;
11665 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11667 gfc_error ("Allocatable array %qs at %L must have a deferred "
11668 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11671 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11672 "%qs at %L may not be ALLOCATABLE",
11673 sym
->name
, &sym
->declared_at
))
11677 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11679 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11680 "assumed rank", sym
->name
, &sym
->declared_at
);
11686 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11687 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11689 gfc_error ("Array %qs at %L cannot have a deferred shape",
11690 sym
->name
, &sym
->declared_at
);
11695 /* Constraints on polymorphic variables. */
11696 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11699 if (sym
->attr
.class_ok
11700 && !sym
->attr
.select_type_temporary
11701 && !UNLIMITED_POLY (sym
)
11702 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11704 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11705 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11706 &sym
->declared_at
);
11711 /* Assume that use associated symbols were checked in the module ns.
11712 Class-variables that are associate-names are also something special
11713 and excepted from the test. */
11714 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11716 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11717 "or pointer", sym
->name
, &sym
->declared_at
);
11726 /* Additional checks for symbols with flavor variable and derived
11727 type. To be called from resolve_fl_variable. */
11730 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11732 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11734 /* Check to see if a derived type is blocked from being host
11735 associated by the presence of another class I symbol in the same
11736 namespace. 14.6.1.3 of the standard and the discussion on
11737 comp.lang.fortran. */
11738 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11739 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11742 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11743 if (s
&& s
->attr
.generic
)
11744 s
= gfc_find_dt_in_generic (s
);
11745 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
11747 gfc_error ("The type %qs cannot be host associated at %L "
11748 "because it is blocked by an incompatible object "
11749 "of the same name declared at %L",
11750 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11756 /* 4th constraint in section 11.3: "If an object of a type for which
11757 component-initialization is specified (R429) appears in the
11758 specification-part of a module and does not have the ALLOCATABLE
11759 or POINTER attribute, the object shall have the SAVE attribute."
11761 The check for initializers is performed with
11762 gfc_has_default_initializer because gfc_default_initializer generates
11763 a hidden default for allocatable components. */
11764 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11765 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11766 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
11767 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11768 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11769 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11770 "%qs at %L, needed due to the default "
11771 "initialization", sym
->name
, &sym
->declared_at
))
11774 /* Assign default initializer. */
11775 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11776 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11777 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11783 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
11784 except in the declaration of an entity or component that has the POINTER
11785 or ALLOCATABLE attribute. */
11788 deferred_requirements (gfc_symbol
*sym
)
11790 if (sym
->ts
.deferred
11791 && !(sym
->attr
.pointer
11792 || sym
->attr
.allocatable
11793 || sym
->attr
.omp_udr_artificial_var
))
11795 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11796 "requires either the POINTER or ALLOCATABLE attribute",
11797 sym
->name
, &sym
->declared_at
);
11804 /* Resolve symbols with flavor variable. */
11807 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11809 int no_init_flag
, automatic_flag
;
11811 const char *auto_save_msg
;
11812 bool saved_specification_expr
;
11814 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11817 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11820 /* Set this flag to check that variables are parameters of all entries.
11821 This check is effected by the call to gfc_resolve_expr through
11822 is_non_constant_shape_array. */
11823 saved_specification_expr
= specification_expr
;
11824 specification_expr
= true;
11826 if (sym
->ns
->proc_name
11827 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11828 || sym
->ns
->proc_name
->attr
.is_main_program
)
11829 && !sym
->attr
.use_assoc
11830 && !sym
->attr
.allocatable
11831 && !sym
->attr
.pointer
11832 && is_non_constant_shape_array (sym
))
11834 /* The shape of a main program or module array needs to be
11836 gfc_error ("The module or main program array %qs at %L must "
11837 "have constant shape", sym
->name
, &sym
->declared_at
);
11838 specification_expr
= saved_specification_expr
;
11842 /* Constraints on deferred type parameter. */
11843 if (!deferred_requirements (sym
))
11846 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
11848 /* Make sure that character string variables with assumed length are
11849 dummy arguments. */
11850 e
= sym
->ts
.u
.cl
->length
;
11851 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11852 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11853 && !sym
->attr
.omp_udr_artificial_var
)
11855 gfc_error ("Entity with assumed character length at %L must be a "
11856 "dummy argument or a PARAMETER", &sym
->declared_at
);
11857 specification_expr
= saved_specification_expr
;
11861 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11863 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11864 specification_expr
= saved_specification_expr
;
11868 if (!gfc_is_constant_expr (e
)
11869 && !(e
->expr_type
== EXPR_VARIABLE
11870 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11872 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11873 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11874 || sym
->ns
->proc_name
->attr
.is_main_program
))
11876 gfc_error ("%qs at %L must have constant character length "
11877 "in this context", sym
->name
, &sym
->declared_at
);
11878 specification_expr
= saved_specification_expr
;
11881 if (sym
->attr
.in_common
)
11883 gfc_error ("COMMON variable %qs at %L must have constant "
11884 "character length", sym
->name
, &sym
->declared_at
);
11885 specification_expr
= saved_specification_expr
;
11891 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11892 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11894 /* Determine if the symbol may not have an initializer. */
11895 no_init_flag
= automatic_flag
= 0;
11896 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11897 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11899 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11900 && is_non_constant_shape_array (sym
))
11902 no_init_flag
= automatic_flag
= 1;
11904 /* Also, they must not have the SAVE attribute.
11905 SAVE_IMPLICIT is checked below. */
11906 if (sym
->as
&& sym
->attr
.codimension
)
11908 int corank
= sym
->as
->corank
;
11909 sym
->as
->corank
= 0;
11910 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11911 sym
->as
->corank
= corank
;
11913 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11915 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11916 specification_expr
= saved_specification_expr
;
11921 /* Ensure that any initializer is simplified. */
11923 gfc_simplify_expr (sym
->value
, 1);
11925 /* Reject illegal initializers. */
11926 if (!sym
->mark
&& sym
->value
)
11928 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11929 && CLASS_DATA (sym
)->attr
.allocatable
))
11930 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11931 sym
->name
, &sym
->declared_at
);
11932 else if (sym
->attr
.external
)
11933 gfc_error ("External %qs at %L cannot have an initializer",
11934 sym
->name
, &sym
->declared_at
);
11935 else if (sym
->attr
.dummy
11936 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11937 gfc_error ("Dummy %qs at %L cannot have an initializer",
11938 sym
->name
, &sym
->declared_at
);
11939 else if (sym
->attr
.intrinsic
)
11940 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11941 sym
->name
, &sym
->declared_at
);
11942 else if (sym
->attr
.result
)
11943 gfc_error ("Function result %qs at %L cannot have an initializer",
11944 sym
->name
, &sym
->declared_at
);
11945 else if (automatic_flag
)
11946 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11947 sym
->name
, &sym
->declared_at
);
11949 goto no_init_error
;
11950 specification_expr
= saved_specification_expr
;
11955 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11957 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11958 specification_expr
= saved_specification_expr
;
11962 specification_expr
= saved_specification_expr
;
11967 /* Compare the dummy characteristics of a module procedure interface
11968 declaration with the corresponding declaration in a submodule. */
11969 static gfc_formal_arglist
*new_formal
;
11970 static char errmsg
[200];
11973 compare_fsyms (gfc_symbol
*sym
)
11977 if (sym
== NULL
|| new_formal
== NULL
)
11980 fsym
= new_formal
->sym
;
11985 if (strcmp (sym
->name
, fsym
->name
) == 0)
11987 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
11988 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
11993 /* Resolve a procedure. */
11996 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11998 gfc_formal_arglist
*arg
;
12000 if (sym
->attr
.function
12001 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12004 if (sym
->ts
.type
== BT_CHARACTER
)
12006 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12008 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12009 && !resolve_charlen (cl
))
12012 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12013 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12015 gfc_error ("Character-valued statement function %qs at %L must "
12016 "have constant length", sym
->name
, &sym
->declared_at
);
12021 /* Ensure that derived type for are not of a private type. Internal
12022 module procedures are excluded by 2.2.3.3 - i.e., they are not
12023 externally accessible and can access all the objects accessible in
12025 if (!(sym
->ns
->parent
12026 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12027 && gfc_check_symbol_access (sym
))
12029 gfc_interface
*iface
;
12031 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12034 && arg
->sym
->ts
.type
== BT_DERIVED
12035 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12036 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12037 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12038 "and cannot be a dummy argument"
12039 " of %qs, which is PUBLIC at %L",
12040 arg
->sym
->name
, sym
->name
,
12041 &sym
->declared_at
))
12043 /* Stop this message from recurring. */
12044 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12049 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12050 PRIVATE to the containing module. */
12051 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12053 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12056 && arg
->sym
->ts
.type
== BT_DERIVED
12057 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12058 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12059 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12060 "PUBLIC interface %qs at %L "
12061 "takes dummy arguments of %qs which "
12062 "is PRIVATE", iface
->sym
->name
,
12063 sym
->name
, &iface
->sym
->declared_at
,
12064 gfc_typename(&arg
->sym
->ts
)))
12066 /* Stop this message from recurring. */
12067 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12074 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12075 && !sym
->attr
.proc_pointer
)
12077 gfc_error ("Function %qs at %L cannot have an initializer",
12078 sym
->name
, &sym
->declared_at
);
12082 /* An external symbol may not have an initializer because it is taken to be
12083 a procedure. Exception: Procedure Pointers. */
12084 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12086 gfc_error ("External object %qs at %L may not have an initializer",
12087 sym
->name
, &sym
->declared_at
);
12091 /* An elemental function is required to return a scalar 12.7.1 */
12092 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
12094 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12095 "result", sym
->name
, &sym
->declared_at
);
12096 /* Reset so that the error only occurs once. */
12097 sym
->attr
.elemental
= 0;
12101 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12102 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12104 gfc_error ("Statement function %qs at %L may not have pointer or "
12105 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12109 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12110 char-len-param shall not be array-valued, pointer-valued, recursive
12111 or pure. ....snip... A character value of * may only be used in the
12112 following ways: (i) Dummy arg of procedure - dummy associates with
12113 actual length; (ii) To declare a named constant; or (iii) External
12114 function - but length must be declared in calling scoping unit. */
12115 if (sym
->attr
.function
12116 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12117 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12119 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12120 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12122 if (sym
->as
&& sym
->as
->rank
)
12123 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12124 "array-valued", sym
->name
, &sym
->declared_at
);
12126 if (sym
->attr
.pointer
)
12127 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12128 "pointer-valued", sym
->name
, &sym
->declared_at
);
12130 if (sym
->attr
.pure
)
12131 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12132 "pure", sym
->name
, &sym
->declared_at
);
12134 if (sym
->attr
.recursive
)
12135 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12136 "recursive", sym
->name
, &sym
->declared_at
);
12141 /* Appendix B.2 of the standard. Contained functions give an
12142 error anyway. Deferred character length is an F2003 feature.
12143 Don't warn on intrinsic conversion functions, which start
12144 with two underscores. */
12145 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12146 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12147 gfc_notify_std (GFC_STD_F95_OBS
,
12148 "CHARACTER(*) function %qs at %L",
12149 sym
->name
, &sym
->declared_at
);
12152 /* F2008, C1218. */
12153 if (sym
->attr
.elemental
)
12155 if (sym
->attr
.proc_pointer
)
12157 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12158 sym
->name
, &sym
->declared_at
);
12161 if (sym
->attr
.dummy
)
12163 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12164 sym
->name
, &sym
->declared_at
);
12169 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12171 gfc_formal_arglist
*curr_arg
;
12172 int has_non_interop_arg
= 0;
12174 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12175 sym
->common_block
))
12177 /* Clear these to prevent looking at them again if there was an
12179 sym
->attr
.is_bind_c
= 0;
12180 sym
->attr
.is_c_interop
= 0;
12181 sym
->ts
.is_c_interop
= 0;
12185 /* So far, no errors have been found. */
12186 sym
->attr
.is_c_interop
= 1;
12187 sym
->ts
.is_c_interop
= 1;
12190 curr_arg
= gfc_sym_get_dummy_args (sym
);
12191 while (curr_arg
!= NULL
)
12193 /* Skip implicitly typed dummy args here. */
12194 if (curr_arg
->sym
->attr
.implicit_type
== 0)
12195 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12196 /* If something is found to fail, record the fact so we
12197 can mark the symbol for the procedure as not being
12198 BIND(C) to try and prevent multiple errors being
12200 has_non_interop_arg
= 1;
12202 curr_arg
= curr_arg
->next
;
12205 /* See if any of the arguments were not interoperable and if so, clear
12206 the procedure symbol to prevent duplicate error messages. */
12207 if (has_non_interop_arg
!= 0)
12209 sym
->attr
.is_c_interop
= 0;
12210 sym
->ts
.is_c_interop
= 0;
12211 sym
->attr
.is_bind_c
= 0;
12215 if (!sym
->attr
.proc_pointer
)
12217 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12219 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12220 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12223 if (sym
->attr
.intent
)
12225 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12226 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12229 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12231 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12232 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12235 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12236 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12237 || sym
->attr
.contained
))
12239 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12240 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12243 if (strcmp ("ppr@", sym
->name
) == 0)
12245 gfc_error ("Procedure pointer result %qs at %L "
12246 "is missing the pointer attribute",
12247 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12252 /* Assume that a procedure whose body is not known has references
12253 to external arrays. */
12254 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12255 sym
->attr
.array_outer_dependency
= 1;
12257 /* Compare the characteristics of a module procedure with the
12258 interface declaration. Ideally this would be done with
12259 gfc_compare_interfaces but, at present, the formal interface
12260 cannot be copied to the ts.interface. */
12261 if (sym
->attr
.module_procedure
12262 && sym
->attr
.if_source
== IFSRC_DECL
)
12265 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12267 char *submodule_name
;
12268 strcpy (name
, sym
->ns
->proc_name
->name
);
12269 module_name
= strtok (name
, ".");
12270 submodule_name
= strtok (NULL
, ".");
12272 /* Stop the dummy characteristics test from using the interface
12273 symbol instead of 'sym'. */
12274 iface
= sym
->ts
.interface
;
12275 sym
->ts
.interface
= NULL
;
12277 /* Make sure that the result uses the correct charlen for deferred
12279 if (iface
&& sym
->result
12280 && iface
->ts
.type
== BT_CHARACTER
12281 && iface
->ts
.deferred
)
12282 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12287 /* Check the procedure characteristics. */
12288 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12290 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12291 "PROCEDURE at %L and its interface in %s",
12292 &sym
->declared_at
, module_name
);
12296 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12298 gfc_error ("Mismatch in PURE attribute between MODULE "
12299 "PROCEDURE at %L and its interface in %s",
12300 &sym
->declared_at
, module_name
);
12304 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12306 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12307 "PROCEDURE at %L and its interface in %s",
12308 &sym
->declared_at
, module_name
);
12312 /* Check the result characteristics. */
12313 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12315 gfc_error ("%s between the MODULE PROCEDURE declaration "
12316 "in module %s and the declaration at %L in "
12317 "SUBMODULE %s", errmsg
, module_name
,
12318 &sym
->declared_at
, submodule_name
);
12323 /* Check the charcateristics of the formal arguments. */
12324 if (sym
->formal
&& sym
->formal_ns
)
12326 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12329 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12333 sym
->ts
.interface
= iface
;
12339 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12340 been defined and we now know their defined arguments, check that they fulfill
12341 the requirements of the standard for procedures used as finalizers. */
12344 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12346 gfc_finalizer
* list
;
12347 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12348 bool result
= true;
12349 bool seen_scalar
= false;
12352 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12355 gfc_resolve_finalizers (parent
, finalizable
);
12357 /* Return early when not finalizable. Additionally, ensure that derived-type
12358 components have a their finalizables resolved. */
12359 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
12361 bool has_final
= false;
12362 for (c
= derived
->components
; c
; c
= c
->next
)
12363 if (c
->ts
.type
== BT_DERIVED
12364 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12366 bool has_final2
= false;
12367 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
12368 return false; /* Error. */
12369 has_final
= has_final
|| has_final2
;
12374 *finalizable
= false;
12379 /* Walk over the list of finalizer-procedures, check them, and if any one
12380 does not fit in with the standard's definition, print an error and remove
12381 it from the list. */
12382 prev_link
= &derived
->f2k_derived
->finalizers
;
12383 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12385 gfc_formal_arglist
*dummy_args
;
12390 /* Skip this finalizer if we already resolved it. */
12391 if (list
->proc_tree
)
12393 prev_link
= &(list
->next
);
12397 /* Check this exists and is a SUBROUTINE. */
12398 if (!list
->proc_sym
->attr
.subroutine
)
12400 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12401 list
->proc_sym
->name
, &list
->where
);
12405 /* We should have exactly one argument. */
12406 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12407 if (!dummy_args
|| dummy_args
->next
)
12409 gfc_error ("FINAL procedure at %L must have exactly one argument",
12413 arg
= dummy_args
->sym
;
12415 /* This argument must be of our type. */
12416 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12418 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12419 &arg
->declared_at
, derived
->name
);
12423 /* It must neither be a pointer nor allocatable nor optional. */
12424 if (arg
->attr
.pointer
)
12426 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12427 &arg
->declared_at
);
12430 if (arg
->attr
.allocatable
)
12432 gfc_error ("Argument of FINAL procedure at %L must not be"
12433 " ALLOCATABLE", &arg
->declared_at
);
12436 if (arg
->attr
.optional
)
12438 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12439 &arg
->declared_at
);
12443 /* It must not be INTENT(OUT). */
12444 if (arg
->attr
.intent
== INTENT_OUT
)
12446 gfc_error ("Argument of FINAL procedure at %L must not be"
12447 " INTENT(OUT)", &arg
->declared_at
);
12451 /* Warn if the procedure is non-scalar and not assumed shape. */
12452 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12453 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12454 gfc_warning (OPT_Wsurprising
,
12455 "Non-scalar FINAL procedure at %L should have assumed"
12456 " shape argument", &arg
->declared_at
);
12458 /* Check that it does not match in kind and rank with a FINAL procedure
12459 defined earlier. To really loop over the *earlier* declarations,
12460 we need to walk the tail of the list as new ones were pushed at the
12462 /* TODO: Handle kind parameters once they are implemented. */
12463 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12464 for (i
= list
->next
; i
; i
= i
->next
)
12466 gfc_formal_arglist
*dummy_args
;
12468 /* Argument list might be empty; that is an error signalled earlier,
12469 but we nevertheless continued resolving. */
12470 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12473 gfc_symbol
* i_arg
= dummy_args
->sym
;
12474 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12475 if (i_rank
== my_rank
)
12477 gfc_error ("FINAL procedure %qs declared at %L has the same"
12478 " rank (%d) as %qs",
12479 list
->proc_sym
->name
, &list
->where
, my_rank
,
12480 i
->proc_sym
->name
);
12486 /* Is this the/a scalar finalizer procedure? */
12487 if (!arg
->as
|| arg
->as
->rank
== 0)
12488 seen_scalar
= true;
12490 /* Find the symtree for this procedure. */
12491 gcc_assert (!list
->proc_tree
);
12492 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12494 prev_link
= &list
->next
;
12497 /* Remove wrong nodes immediately from the list so we don't risk any
12498 troubles in the future when they might fail later expectations. */
12501 *prev_link
= list
->next
;
12502 gfc_free_finalizer (i
);
12506 if (result
== false)
12509 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12510 were nodes in the list, must have been for arrays. It is surely a good
12511 idea to have a scalar version there if there's something to finalize. */
12512 if (warn_surprising
&& result
&& !seen_scalar
)
12513 gfc_warning (OPT_Wsurprising
,
12514 "Only array FINAL procedures declared for derived type %qs"
12515 " defined at %L, suggest also scalar one",
12516 derived
->name
, &derived
->declared_at
);
12518 vtab
= gfc_find_derived_vtab (derived
);
12519 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12520 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12523 *finalizable
= true;
12529 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12532 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12533 const char* generic_name
, locus where
)
12535 gfc_symbol
*sym1
, *sym2
;
12536 const char *pass1
, *pass2
;
12537 gfc_formal_arglist
*dummy_args
;
12539 gcc_assert (t1
->specific
&& t2
->specific
);
12540 gcc_assert (!t1
->specific
->is_generic
);
12541 gcc_assert (!t2
->specific
->is_generic
);
12542 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12544 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12545 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12550 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12551 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12552 || sym1
->attr
.function
!= sym2
->attr
.function
)
12554 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12555 " GENERIC %qs at %L",
12556 sym1
->name
, sym2
->name
, generic_name
, &where
);
12560 /* Determine PASS arguments. */
12561 if (t1
->specific
->nopass
)
12563 else if (t1
->specific
->pass_arg
)
12564 pass1
= t1
->specific
->pass_arg
;
12567 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12569 pass1
= dummy_args
->sym
->name
;
12573 if (t2
->specific
->nopass
)
12575 else if (t2
->specific
->pass_arg
)
12576 pass2
= t2
->specific
->pass_arg
;
12579 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12581 pass2
= dummy_args
->sym
->name
;
12586 /* Compare the interfaces. */
12587 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12588 NULL
, 0, pass1
, pass2
))
12590 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12591 sym1
->name
, sym2
->name
, generic_name
, &where
);
12599 /* Worker function for resolving a generic procedure binding; this is used to
12600 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12602 The difference between those cases is finding possible inherited bindings
12603 that are overridden, as one has to look for them in tb_sym_root,
12604 tb_uop_root or tb_op, respectively. Thus the caller must already find
12605 the super-type and set p->overridden correctly. */
12608 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12609 gfc_typebound_proc
* p
, const char* name
)
12611 gfc_tbp_generic
* target
;
12612 gfc_symtree
* first_target
;
12613 gfc_symtree
* inherited
;
12615 gcc_assert (p
&& p
->is_generic
);
12617 /* Try to find the specific bindings for the symtrees in our target-list. */
12618 gcc_assert (p
->u
.generic
);
12619 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12620 if (!target
->specific
)
12622 gfc_typebound_proc
* overridden_tbp
;
12623 gfc_tbp_generic
* g
;
12624 const char* target_name
;
12626 target_name
= target
->specific_st
->name
;
12628 /* Defined for this type directly. */
12629 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12631 target
->specific
= target
->specific_st
->n
.tb
;
12632 goto specific_found
;
12635 /* Look for an inherited specific binding. */
12638 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12643 gcc_assert (inherited
->n
.tb
);
12644 target
->specific
= inherited
->n
.tb
;
12645 goto specific_found
;
12649 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12650 " at %L", target_name
, name
, &p
->where
);
12653 /* Once we've found the specific binding, check it is not ambiguous with
12654 other specifics already found or inherited for the same GENERIC. */
12656 gcc_assert (target
->specific
);
12658 /* This must really be a specific binding! */
12659 if (target
->specific
->is_generic
)
12661 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12662 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12666 /* Check those already resolved on this type directly. */
12667 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12668 if (g
!= target
&& g
->specific
12669 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12672 /* Check for ambiguity with inherited specific targets. */
12673 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12674 overridden_tbp
= overridden_tbp
->overridden
)
12675 if (overridden_tbp
->is_generic
)
12677 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12679 gcc_assert (g
->specific
);
12680 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12686 /* If we attempt to "overwrite" a specific binding, this is an error. */
12687 if (p
->overridden
&& !p
->overridden
->is_generic
)
12689 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12690 " the same name", name
, &p
->where
);
12694 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12695 all must have the same attributes here. */
12696 first_target
= p
->u
.generic
->specific
->u
.specific
;
12697 gcc_assert (first_target
);
12698 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12699 p
->function
= first_target
->n
.sym
->attr
.function
;
12705 /* Resolve a GENERIC procedure binding for a derived type. */
12708 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12710 gfc_symbol
* super_type
;
12712 /* Find the overridden binding if any. */
12713 st
->n
.tb
->overridden
= NULL
;
12714 super_type
= gfc_get_derived_super_type (derived
);
12717 gfc_symtree
* overridden
;
12718 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12721 if (overridden
&& overridden
->n
.tb
)
12722 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12725 /* Resolve using worker function. */
12726 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12730 /* Retrieve the target-procedure of an operator binding and do some checks in
12731 common for intrinsic and user-defined type-bound operators. */
12734 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12736 gfc_symbol
* target_proc
;
12738 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12739 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12740 gcc_assert (target_proc
);
12742 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12743 if (target
->specific
->nopass
)
12745 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12749 return target_proc
;
12753 /* Resolve a type-bound intrinsic operator. */
12756 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12757 gfc_typebound_proc
* p
)
12759 gfc_symbol
* super_type
;
12760 gfc_tbp_generic
* target
;
12762 /* If there's already an error here, do nothing (but don't fail again). */
12766 /* Operators should always be GENERIC bindings. */
12767 gcc_assert (p
->is_generic
);
12769 /* Look for an overridden binding. */
12770 super_type
= gfc_get_derived_super_type (derived
);
12771 if (super_type
&& super_type
->f2k_derived
)
12772 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12775 p
->overridden
= NULL
;
12777 /* Resolve general GENERIC properties using worker function. */
12778 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
12781 /* Check the targets to be procedures of correct interface. */
12782 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12784 gfc_symbol
* target_proc
;
12786 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12790 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12793 /* Add target to non-typebound operator list. */
12794 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12795 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12797 gfc_interface
*head
, *intr
;
12799 /* Preempt 'gfc_check_new_interface' for submodules, where the
12800 mechanism for handling module procedures winds up resolving
12801 operator interfaces twice and would otherwise cause an error. */
12802 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
12803 if (intr
->sym
== target_proc
12804 && target_proc
->attr
.used_in_submodule
)
12807 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
12808 target_proc
, p
->where
))
12810 head
= derived
->ns
->op
[op
];
12811 intr
= gfc_get_interface ();
12812 intr
->sym
= target_proc
;
12813 intr
->where
= p
->where
;
12815 derived
->ns
->op
[op
] = intr
;
12827 /* Resolve a type-bound user operator (tree-walker callback). */
12829 static gfc_symbol
* resolve_bindings_derived
;
12830 static bool resolve_bindings_result
;
12832 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12835 resolve_typebound_user_op (gfc_symtree
* stree
)
12837 gfc_symbol
* super_type
;
12838 gfc_tbp_generic
* target
;
12840 gcc_assert (stree
&& stree
->n
.tb
);
12842 if (stree
->n
.tb
->error
)
12845 /* Operators should always be GENERIC bindings. */
12846 gcc_assert (stree
->n
.tb
->is_generic
);
12848 /* Find overridden procedure, if any. */
12849 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12850 if (super_type
&& super_type
->f2k_derived
)
12852 gfc_symtree
* overridden
;
12853 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12854 stree
->name
, true, NULL
);
12856 if (overridden
&& overridden
->n
.tb
)
12857 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12860 stree
->n
.tb
->overridden
= NULL
;
12862 /* Resolve basically using worker function. */
12863 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12866 /* Check the targets to be functions of correct interface. */
12867 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12869 gfc_symbol
* target_proc
;
12871 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12875 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12882 resolve_bindings_result
= false;
12883 stree
->n
.tb
->error
= 1;
12887 /* Resolve the type-bound procedures for a derived type. */
12890 resolve_typebound_procedure (gfc_symtree
* stree
)
12894 gfc_symbol
* me_arg
;
12895 gfc_symbol
* super_type
;
12896 gfc_component
* comp
;
12898 gcc_assert (stree
);
12900 /* Undefined specific symbol from GENERIC target definition. */
12904 if (stree
->n
.tb
->error
)
12907 /* If this is a GENERIC binding, use that routine. */
12908 if (stree
->n
.tb
->is_generic
)
12910 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12915 /* Get the target-procedure to check it. */
12916 gcc_assert (!stree
->n
.tb
->is_generic
);
12917 gcc_assert (stree
->n
.tb
->u
.specific
);
12918 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12919 where
= stree
->n
.tb
->where
;
12921 /* Default access should already be resolved from the parser. */
12922 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12924 if (stree
->n
.tb
->deferred
)
12926 if (!check_proc_interface (proc
, &where
))
12931 /* Check for F08:C465. */
12932 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12933 || (proc
->attr
.proc
!= PROC_MODULE
12934 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12935 || proc
->attr
.abstract
)
12937 gfc_error ("%qs must be a module procedure or an external procedure with"
12938 " an explicit interface at %L", proc
->name
, &where
);
12943 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12944 stree
->n
.tb
->function
= proc
->attr
.function
;
12946 /* Find the super-type of the current derived type. We could do this once and
12947 store in a global if speed is needed, but as long as not I believe this is
12948 more readable and clearer. */
12949 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12951 /* If PASS, resolve and check arguments if not already resolved / loaded
12952 from a .mod file. */
12953 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12955 gfc_formal_arglist
*dummy_args
;
12957 dummy_args
= gfc_sym_get_dummy_args (proc
);
12958 if (stree
->n
.tb
->pass_arg
)
12960 gfc_formal_arglist
*i
;
12962 /* If an explicit passing argument name is given, walk the arg-list
12963 and look for it. */
12966 stree
->n
.tb
->pass_arg_num
= 1;
12967 for (i
= dummy_args
; i
; i
= i
->next
)
12969 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12974 ++stree
->n
.tb
->pass_arg_num
;
12979 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12981 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12982 stree
->n
.tb
->pass_arg
);
12988 /* Otherwise, take the first one; there should in fact be at least
12990 stree
->n
.tb
->pass_arg_num
= 1;
12993 gfc_error ("Procedure %qs with PASS at %L must have at"
12994 " least one argument", proc
->name
, &where
);
12997 me_arg
= dummy_args
->sym
;
13000 /* Now check that the argument-type matches and the passed-object
13001 dummy argument is generally fine. */
13003 gcc_assert (me_arg
);
13005 if (me_arg
->ts
.type
!= BT_CLASS
)
13007 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13008 " at %L", proc
->name
, &where
);
13012 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13013 != resolve_bindings_derived
)
13015 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13016 " the derived-type %qs", me_arg
->name
, proc
->name
,
13017 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13021 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13022 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13024 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13025 " scalar", proc
->name
, &where
);
13028 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13030 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13031 " be ALLOCATABLE", proc
->name
, &where
);
13034 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13036 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13037 " be POINTER", proc
->name
, &where
);
13042 /* If we are extending some type, check that we don't override a procedure
13043 flagged NON_OVERRIDABLE. */
13044 stree
->n
.tb
->overridden
= NULL
;
13047 gfc_symtree
* overridden
;
13048 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13049 stree
->name
, true, NULL
);
13053 if (overridden
->n
.tb
)
13054 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13056 if (!gfc_check_typebound_override (stree
, overridden
))
13061 /* See if there's a name collision with a component directly in this type. */
13062 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13063 if (!strcmp (comp
->name
, stree
->name
))
13065 gfc_error ("Procedure %qs at %L has the same name as a component of"
13067 stree
->name
, &where
, resolve_bindings_derived
->name
);
13071 /* Try to find a name collision with an inherited component. */
13072 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13075 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13076 " component of %qs",
13077 stree
->name
, &where
, resolve_bindings_derived
->name
);
13081 stree
->n
.tb
->error
= 0;
13085 resolve_bindings_result
= false;
13086 stree
->n
.tb
->error
= 1;
13091 resolve_typebound_procedures (gfc_symbol
* derived
)
13094 gfc_symbol
* super_type
;
13096 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13099 super_type
= gfc_get_derived_super_type (derived
);
13101 resolve_symbol (super_type
);
13103 resolve_bindings_derived
= derived
;
13104 resolve_bindings_result
= true;
13106 if (derived
->f2k_derived
->tb_sym_root
)
13107 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13108 &resolve_typebound_procedure
);
13110 if (derived
->f2k_derived
->tb_uop_root
)
13111 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13112 &resolve_typebound_user_op
);
13114 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13116 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13117 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13118 (gfc_intrinsic_op
)op
, p
))
13119 resolve_bindings_result
= false;
13122 return resolve_bindings_result
;
13126 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13127 to give all identical derived types the same backend_decl. */
13129 add_dt_to_dt_list (gfc_symbol
*derived
)
13131 gfc_dt_list
*dt_list
;
13133 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
13134 if (derived
== dt_list
->derived
)
13137 dt_list
= gfc_get_dt_list ();
13138 dt_list
->next
= gfc_derived_types
;
13139 dt_list
->derived
= derived
;
13140 gfc_derived_types
= dt_list
;
13144 /* Ensure that a derived-type is really not abstract, meaning that every
13145 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13148 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13153 if (!ensure_not_abstract_walker (sub
, st
->left
))
13155 if (!ensure_not_abstract_walker (sub
, st
->right
))
13158 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13160 gfc_symtree
* overriding
;
13161 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13164 gcc_assert (overriding
->n
.tb
);
13165 if (overriding
->n
.tb
->deferred
)
13167 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13168 " %qs is DEFERRED and not overridden",
13169 sub
->name
, &sub
->declared_at
, st
->name
);
13178 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13180 /* The algorithm used here is to recursively travel up the ancestry of sub
13181 and for each ancestor-type, check all bindings. If any of them is
13182 DEFERRED, look it up starting from sub and see if the found (overriding)
13183 binding is not DEFERRED.
13184 This is not the most efficient way to do this, but it should be ok and is
13185 clearer than something sophisticated. */
13187 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13189 if (!ancestor
->attr
.abstract
)
13192 /* Walk bindings of this ancestor. */
13193 if (ancestor
->f2k_derived
)
13196 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13201 /* Find next ancestor type and recurse on it. */
13202 ancestor
= gfc_get_derived_super_type (ancestor
);
13204 return ensure_not_abstract (sub
, ancestor
);
13210 /* This check for typebound defined assignments is done recursively
13211 since the order in which derived types are resolved is not always in
13212 order of the declarations. */
13215 check_defined_assignments (gfc_symbol
*derived
)
13219 for (c
= derived
->components
; c
; c
= c
->next
)
13221 if (!gfc_bt_struct (c
->ts
.type
)
13223 || c
->attr
.allocatable
13224 || c
->attr
.proc_pointer_comp
13225 || c
->attr
.class_pointer
13226 || c
->attr
.proc_pointer
)
13229 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13230 || (c
->ts
.u
.derived
->f2k_derived
13231 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13233 derived
->attr
.defined_assign_comp
= 1;
13237 check_defined_assignments (c
->ts
.u
.derived
);
13238 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13240 derived
->attr
.defined_assign_comp
= 1;
13247 /* Resolve a single component of a derived type or structure. */
13250 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13252 gfc_symbol
*super_type
;
13254 if (c
->attr
.artificial
)
13258 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13259 && c
->attr
.codimension
13260 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13262 gfc_error ("Coarray component %qs at %L must be allocatable with "
13263 "deferred shape", c
->name
, &c
->loc
);
13268 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13269 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13271 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13272 "shall not be a coarray", c
->name
, &c
->loc
);
13277 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13278 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13279 || c
->attr
.allocatable
))
13281 gfc_error ("Component %qs at %L with coarray component "
13282 "shall be a nonpointer, nonallocatable scalar",
13288 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13290 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13291 "is not an array pointer", c
->name
, &c
->loc
);
13295 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13297 gfc_symbol
*ifc
= c
->ts
.interface
;
13299 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13305 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13307 /* Resolve interface and copy attributes. */
13308 if (ifc
->formal
&& !ifc
->formal_ns
)
13309 resolve_symbol (ifc
);
13310 if (ifc
->attr
.intrinsic
)
13311 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13315 c
->ts
= ifc
->result
->ts
;
13316 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13317 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13318 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13319 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13320 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13325 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13326 c
->attr
.pointer
= ifc
->attr
.pointer
;
13327 c
->attr
.dimension
= ifc
->attr
.dimension
;
13328 c
->as
= gfc_copy_array_spec (ifc
->as
);
13329 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13331 c
->ts
.interface
= ifc
;
13332 c
->attr
.function
= ifc
->attr
.function
;
13333 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13335 c
->attr
.pure
= ifc
->attr
.pure
;
13336 c
->attr
.elemental
= ifc
->attr
.elemental
;
13337 c
->attr
.recursive
= ifc
->attr
.recursive
;
13338 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13339 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13340 /* Copy char length. */
13341 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13343 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13344 if (cl
->length
&& !cl
->resolved
13345 && !gfc_resolve_expr (cl
->length
))
13354 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13356 /* Since PPCs are not implicitly typed, a PPC without an explicit
13357 interface must be a subroutine. */
13358 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13361 /* Procedure pointer components: Check PASS arg. */
13362 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13363 && !sym
->attr
.vtype
)
13365 gfc_symbol
* me_arg
;
13367 if (c
->tb
->pass_arg
)
13369 gfc_formal_arglist
* i
;
13371 /* If an explicit passing argument name is given, walk the arg-list
13372 and look for it. */
13375 c
->tb
->pass_arg_num
= 1;
13376 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13378 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13383 c
->tb
->pass_arg_num
++;
13388 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13389 "at %L has no argument %qs", c
->name
,
13390 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13397 /* Otherwise, take the first one; there should in fact be at least
13399 c
->tb
->pass_arg_num
= 1;
13400 if (!c
->ts
.interface
->formal
)
13402 gfc_error ("Procedure pointer component %qs with PASS at %L "
13403 "must have at least one argument",
13408 me_arg
= c
->ts
.interface
->formal
->sym
;
13411 /* Now check that the argument-type matches. */
13412 gcc_assert (me_arg
);
13413 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13414 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13415 || (me_arg
->ts
.type
== BT_CLASS
13416 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13418 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13419 " the derived type %qs", me_arg
->name
, c
->name
,
13420 me_arg
->name
, &c
->loc
, sym
->name
);
13425 /* Check for C453. */
13426 if (me_arg
->attr
.dimension
)
13428 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13429 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13435 if (me_arg
->attr
.pointer
)
13437 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13438 "may not have the POINTER attribute", me_arg
->name
,
13439 c
->name
, me_arg
->name
, &c
->loc
);
13444 if (me_arg
->attr
.allocatable
)
13446 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13447 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13448 me_arg
->name
, &c
->loc
);
13453 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13455 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13456 " at %L", c
->name
, &c
->loc
);
13462 /* Check type-spec if this is not the parent-type component. */
13463 if (((sym
->attr
.is_class
13464 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13465 || c
!= sym
->components
->ts
.u
.derived
->components
))
13466 || (!sym
->attr
.is_class
13467 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13468 && !sym
->attr
.vtype
13469 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13472 super_type
= gfc_get_derived_super_type (sym
);
13474 /* If this type is an extension, set the accessibility of the parent
13477 && ((sym
->attr
.is_class
13478 && c
== sym
->components
->ts
.u
.derived
->components
)
13479 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13480 && strcmp (super_type
->name
, c
->name
) == 0)
13481 c
->attr
.access
= super_type
->attr
.access
;
13483 /* If this type is an extension, see if this component has the same name
13484 as an inherited type-bound procedure. */
13485 if (super_type
&& !sym
->attr
.is_class
13486 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13488 gfc_error ("Component %qs of %qs at %L has the same name as an"
13489 " inherited type-bound procedure",
13490 c
->name
, sym
->name
, &c
->loc
);
13494 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13495 && !c
->ts
.deferred
)
13497 if (c
->ts
.u
.cl
->length
== NULL
13498 || (!resolve_charlen(c
->ts
.u
.cl
))
13499 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13501 gfc_error ("Character length of component %qs needs to "
13502 "be a constant specification expression at %L",
13504 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13509 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13510 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13512 gfc_error ("Character component %qs of %qs at %L with deferred "
13513 "length must be a POINTER or ALLOCATABLE",
13514 c
->name
, sym
->name
, &c
->loc
);
13518 /* Add the hidden deferred length field. */
13519 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
13520 && !sym
->attr
.is_class
)
13522 char name
[GFC_MAX_SYMBOL_LEN
+9];
13523 gfc_component
*strlen
;
13524 sprintf (name
, "_%s_length", c
->name
);
13525 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
13526 if (strlen
== NULL
)
13528 if (!gfc_add_component (sym
, name
, &strlen
))
13530 strlen
->ts
.type
= BT_INTEGER
;
13531 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13532 strlen
->attr
.access
= ACCESS_PRIVATE
;
13533 strlen
->attr
.artificial
= 1;
13537 if (c
->ts
.type
== BT_DERIVED
13538 && sym
->component_access
!= ACCESS_PRIVATE
13539 && gfc_check_symbol_access (sym
)
13540 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13541 && !c
->ts
.u
.derived
->attr
.use_assoc
13542 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13543 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13544 "PRIVATE type and cannot be a component of "
13545 "%qs, which is PUBLIC at %L", c
->name
,
13546 sym
->name
, &sym
->declared_at
))
13549 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13551 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13552 "type %s", c
->name
, &c
->loc
, sym
->name
);
13556 if (sym
->attr
.sequence
)
13558 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13560 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13561 "not have the SEQUENCE attribute",
13562 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13567 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13568 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13569 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13570 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13571 CLASS_DATA (c
)->ts
.u
.derived
13572 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13574 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13575 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13576 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13578 gfc_error ("The pointer component %qs of %qs at %L is a type "
13579 "that has not been declared", c
->name
, sym
->name
,
13584 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13585 && CLASS_DATA (c
)->attr
.class_pointer
13586 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13587 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13588 && !UNLIMITED_POLY (c
))
13590 gfc_error ("The pointer component %qs of %qs at %L is a type "
13591 "that has not been declared", c
->name
, sym
->name
,
13596 /* If an allocatable component derived type is of the same type as
13597 the enclosing derived type, we need a vtable generating so that
13598 the __deallocate procedure is created. */
13599 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
13600 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
13601 gfc_find_vtab (&c
->ts
);
13603 /* Ensure that all the derived type components are put on the
13604 derived type list; even in formal namespaces, where derived type
13605 pointer components might not have been declared. */
13606 if (c
->ts
.type
== BT_DERIVED
13608 && c
->ts
.u
.derived
->components
13610 && sym
!= c
->ts
.u
.derived
)
13611 add_dt_to_dt_list (c
->ts
.u
.derived
);
13613 if (!gfc_resolve_array_spec (c
->as
,
13614 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13615 || c
->attr
.allocatable
)))
13618 if (c
->initializer
&& !sym
->attr
.vtype
13619 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13626 /* Be nice about the locus for a structure expression - show the locus of the
13627 first non-null sub-expression if we can. */
13630 cons_where (gfc_expr
*struct_expr
)
13632 gfc_constructor
*cons
;
13634 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
13636 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
13637 for (; cons
; cons
= gfc_constructor_next (cons
))
13639 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
13640 return &cons
->expr
->where
;
13643 return &struct_expr
->where
;
13646 /* Resolve the components of a structure type. Much less work than derived
13650 resolve_fl_struct (gfc_symbol
*sym
)
13653 gfc_expr
*init
= NULL
;
13656 /* Make sure UNIONs do not have overlapping initializers. */
13657 if (sym
->attr
.flavor
== FL_UNION
)
13659 for (c
= sym
->components
; c
; c
= c
->next
)
13661 if (init
&& c
->initializer
)
13663 gfc_error ("Conflicting initializers in union at %L and %L",
13664 cons_where (init
), cons_where (c
->initializer
));
13665 gfc_free_expr (c
->initializer
);
13666 c
->initializer
= NULL
;
13669 init
= c
->initializer
;
13674 for (c
= sym
->components
; c
; c
= c
->next
)
13675 if (!resolve_component (c
, sym
))
13681 if (sym
->components
)
13682 add_dt_to_dt_list (sym
);
13688 /* Resolve the components of a derived type. This does not have to wait until
13689 resolution stage, but can be done as soon as the dt declaration has been
13693 resolve_fl_derived0 (gfc_symbol
*sym
)
13695 gfc_symbol
* super_type
;
13699 if (sym
->attr
.unlimited_polymorphic
)
13702 super_type
= gfc_get_derived_super_type (sym
);
13705 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
13707 gfc_error ("As extending type %qs at %L has a coarray component, "
13708 "parent type %qs shall also have one", sym
->name
,
13709 &sym
->declared_at
, super_type
->name
);
13713 /* Ensure the extended type gets resolved before we do. */
13714 if (super_type
&& !resolve_fl_derived0 (super_type
))
13717 /* An ABSTRACT type must be extensible. */
13718 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
13720 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
13721 sym
->name
, &sym
->declared_at
);
13725 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
13729 for ( ; c
!= NULL
; c
= c
->next
)
13730 if (!resolve_component (c
, sym
))
13736 check_defined_assignments (sym
);
13738 if (!sym
->attr
.defined_assign_comp
&& super_type
)
13739 sym
->attr
.defined_assign_comp
13740 = super_type
->attr
.defined_assign_comp
;
13742 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13743 all DEFERRED bindings are overridden. */
13744 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
13745 && !sym
->attr
.is_class
13746 && !ensure_not_abstract (sym
, super_type
))
13749 /* Add derived type to the derived type list. */
13750 add_dt_to_dt_list (sym
);
13756 /* The following procedure does the full resolution of a derived type,
13757 including resolution of all type-bound procedures (if present). In contrast
13758 to 'resolve_fl_derived0' this can only be done after the module has been
13759 parsed completely. */
13762 resolve_fl_derived (gfc_symbol
*sym
)
13764 gfc_symbol
*gen_dt
= NULL
;
13766 if (sym
->attr
.unlimited_polymorphic
)
13769 if (!sym
->attr
.is_class
)
13770 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
13771 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
13772 && (!gen_dt
->generic
->sym
->attr
.use_assoc
13773 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
13774 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
13775 "%qs at %L being the same name as derived "
13776 "type at %L", sym
->name
,
13777 gen_dt
->generic
->sym
== sym
13778 ? gen_dt
->generic
->next
->sym
->name
13779 : gen_dt
->generic
->sym
->name
,
13780 gen_dt
->generic
->sym
== sym
13781 ? &gen_dt
->generic
->next
->sym
->declared_at
13782 : &gen_dt
->generic
->sym
->declared_at
,
13783 &sym
->declared_at
))
13786 /* Resolve the finalizer procedures. */
13787 if (!gfc_resolve_finalizers (sym
, NULL
))
13790 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
13792 /* Fix up incomplete CLASS symbols. */
13793 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
13794 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
13796 /* Nothing more to do for unlimited polymorphic entities. */
13797 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
13799 else if (vptr
->ts
.u
.derived
== NULL
)
13801 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
13803 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
13807 if (!resolve_fl_derived0 (sym
))
13810 /* Resolve the type-bound procedures. */
13811 if (!resolve_typebound_procedures (sym
))
13818 /* Check for formatted read and write DTIO procedures. */
13821 dtio_procs_present (gfc_symbol
*sym
)
13823 gfc_symbol
*derived
;
13825 if (sym
->ts
.type
== BT_CLASS
)
13826 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
13827 else if (sym
->ts
.type
== BT_DERIVED
)
13828 derived
= sym
->ts
.u
.derived
;
13832 return gfc_find_specific_dtio_proc (derived
, true, true) != NULL
13833 && gfc_find_specific_dtio_proc (derived
, false, true) != NULL
;
13838 resolve_fl_namelist (gfc_symbol
*sym
)
13844 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13846 /* Check again, the check in match only works if NAMELIST comes
13848 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
13850 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13851 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13855 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
13856 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13857 "with assumed shape in namelist %qs at %L",
13858 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13861 if (is_non_constant_shape_array (nl
->sym
)
13862 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13863 "with nonconstant shape in namelist %qs at %L",
13864 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13867 if (nl
->sym
->ts
.type
== BT_CHARACTER
13868 && (nl
->sym
->ts
.u
.cl
->length
== NULL
13869 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13870 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13871 "nonconstant character length in "
13872 "namelist %qs at %L", nl
->sym
->name
,
13873 sym
->name
, &sym
->declared_at
))
13876 dtio
= dtio_procs_present (nl
->sym
);
13878 if (nl
->sym
->ts
.type
== BT_CLASS
&& !dtio
)
13880 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13881 "polymorphic and requires a defined input/output "
13882 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13886 if (nl
->sym
->ts
.type
== BT_DERIVED
13887 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13888 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13890 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13891 "namelist %qs at %L with ALLOCATABLE "
13892 "or POINTER components", nl
->sym
->name
,
13893 sym
->name
, &sym
->declared_at
))
13898 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13899 "ALLOCATABLE or POINTER components and thus requires "
13900 "a defined input/output procedure", nl
->sym
->name
,
13901 sym
->name
, &sym
->declared_at
);
13907 /* Reject PRIVATE objects in a PUBLIC namelist. */
13908 if (gfc_check_symbol_access (sym
))
13910 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13912 if (!nl
->sym
->attr
.use_assoc
13913 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13914 && !gfc_check_symbol_access (nl
->sym
))
13916 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13917 "cannot be member of PUBLIC namelist %qs at %L",
13918 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13922 /* If the derived type has specific DTIO procedures for both read and
13923 write then namelist objects with private components are OK. */
13924 if (dtio_procs_present (nl
->sym
))
13927 /* Types with private components that came here by USE-association. */
13928 if (nl
->sym
->ts
.type
== BT_DERIVED
13929 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13931 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13932 "components and cannot be member of namelist %qs at %L",
13933 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13937 /* Types with private components that are defined in the same module. */
13938 if (nl
->sym
->ts
.type
== BT_DERIVED
13939 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13940 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13942 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13943 "cannot be a member of PUBLIC namelist %qs at %L",
13944 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13951 /* 14.1.2 A module or internal procedure represent local entities
13952 of the same type as a namelist member and so are not allowed. */
13953 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13955 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13958 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13959 if ((nl
->sym
== sym
->ns
->proc_name
)
13961 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13966 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13967 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13969 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13970 "attribute in %qs at %L", nlsym
->name
,
13971 &sym
->declared_at
);
13981 resolve_fl_parameter (gfc_symbol
*sym
)
13983 /* A parameter array's shape needs to be constant. */
13984 if (sym
->as
!= NULL
13985 && (sym
->as
->type
== AS_DEFERRED
13986 || is_non_constant_shape_array (sym
)))
13988 gfc_error ("Parameter array %qs at %L cannot be automatic "
13989 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13993 /* Constraints on deferred type parameter. */
13994 if (!deferred_requirements (sym
))
13997 /* Make sure a parameter that has been implicitly typed still
13998 matches the implicit type, since PARAMETER statements can precede
13999 IMPLICIT statements. */
14000 if (sym
->attr
.implicit_type
14001 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14004 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14005 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14009 /* Make sure the types of derived parameters are consistent. This
14010 type checking is deferred until resolution because the type may
14011 refer to a derived type from the host. */
14012 if (sym
->ts
.type
== BT_DERIVED
14013 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14015 gfc_error ("Incompatible derived type in PARAMETER at %L",
14016 &sym
->value
->where
);
14020 /* F03:C509,C514. */
14021 if (sym
->ts
.type
== BT_CLASS
)
14023 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14024 sym
->name
, &sym
->declared_at
);
14032 /* Do anything necessary to resolve a symbol. Right now, we just
14033 assume that an otherwise unknown symbol is a variable. This sort
14034 of thing commonly happens for symbols in module. */
14037 resolve_symbol (gfc_symbol
*sym
)
14039 int check_constant
, mp_flag
;
14040 gfc_symtree
*symtree
;
14041 gfc_symtree
*this_symtree
;
14044 symbol_attribute class_attr
;
14045 gfc_array_spec
*as
;
14046 bool saved_specification_expr
;
14052 /* No symbol will ever have union type; only components can be unions.
14053 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14054 (just like derived type declaration symbols have flavor FL_DERIVED). */
14055 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14057 /* Coarrayed polymorphic objects with allocatable or pointer components are
14058 yet unsupported for -fcoarray=lib. */
14059 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14060 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14061 && CLASS_DATA (sym
)->attr
.codimension
14062 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14063 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14065 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14066 "type coarrays at %L are unsupported", &sym
->declared_at
);
14070 if (sym
->attr
.artificial
)
14073 if (sym
->attr
.unlimited_polymorphic
)
14076 if (sym
->attr
.flavor
== FL_UNKNOWN
14077 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14078 && !sym
->attr
.generic
&& !sym
->attr
.external
14079 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14080 && sym
->ts
.type
== BT_UNKNOWN
))
14083 /* If we find that a flavorless symbol is an interface in one of the
14084 parent namespaces, find its symtree in this namespace, free the
14085 symbol and set the symtree to point to the interface symbol. */
14086 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14088 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14089 if (symtree
&& (symtree
->n
.sym
->generic
||
14090 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14091 && sym
->ns
->construct_entities
)))
14093 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14095 if (this_symtree
->n
.sym
== sym
)
14097 symtree
->n
.sym
->refs
++;
14098 gfc_release_symbol (sym
);
14099 this_symtree
->n
.sym
= symtree
->n
.sym
;
14105 /* Otherwise give it a flavor according to such attributes as
14107 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14108 && sym
->attr
.intrinsic
== 0)
14109 sym
->attr
.flavor
= FL_VARIABLE
;
14110 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14112 sym
->attr
.flavor
= FL_PROCEDURE
;
14113 if (sym
->attr
.dimension
)
14114 sym
->attr
.function
= 1;
14118 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14119 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14121 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14122 && !resolve_procedure_interface (sym
))
14125 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14126 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14128 if (sym
->attr
.external
)
14129 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14130 "at %L", &sym
->declared_at
);
14132 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14133 "at %L", &sym
->declared_at
);
14138 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14141 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14142 && !resolve_fl_struct (sym
))
14145 /* Symbols that are module procedures with results (functions) have
14146 the types and array specification copied for type checking in
14147 procedures that call them, as well as for saving to a module
14148 file. These symbols can't stand the scrutiny that their results
14150 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14152 /* Make sure that the intrinsic is consistent with its internal
14153 representation. This needs to be done before assigning a default
14154 type to avoid spurious warnings. */
14155 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14156 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14159 /* Resolve associate names. */
14161 resolve_assoc_var (sym
, true);
14163 /* Assign default type to symbols that need one and don't have one. */
14164 if (sym
->ts
.type
== BT_UNKNOWN
)
14166 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14168 gfc_set_default_type (sym
, 1, NULL
);
14171 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14172 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14173 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14174 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14176 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14178 /* The specific case of an external procedure should emit an error
14179 in the case that there is no implicit type. */
14182 if (!sym
->attr
.mixed_entry_master
)
14183 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14187 /* Result may be in another namespace. */
14188 resolve_symbol (sym
->result
);
14190 if (!sym
->result
->attr
.proc_pointer
)
14192 sym
->ts
= sym
->result
->ts
;
14193 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14194 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14195 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14196 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14197 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14202 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14204 bool saved_specification_expr
= specification_expr
;
14205 specification_expr
= true;
14206 gfc_resolve_array_spec (sym
->result
->as
, false);
14207 specification_expr
= saved_specification_expr
;
14210 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14212 as
= CLASS_DATA (sym
)->as
;
14213 class_attr
= CLASS_DATA (sym
)->attr
;
14214 class_attr
.pointer
= class_attr
.class_pointer
;
14218 class_attr
= sym
->attr
;
14223 if (sym
->attr
.contiguous
14224 && (!class_attr
.dimension
14225 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14226 && !class_attr
.pointer
)))
14228 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14229 "array pointer or an assumed-shape or assumed-rank array",
14230 sym
->name
, &sym
->declared_at
);
14234 /* Assumed size arrays and assumed shape arrays must be dummy
14235 arguments. Array-spec's of implied-shape should have been resolved to
14236 AS_EXPLICIT already. */
14240 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
14241 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14242 || as
->type
== AS_ASSUMED_SHAPE
)
14243 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14245 if (as
->type
== AS_ASSUMED_SIZE
)
14246 gfc_error ("Assumed size array at %L must be a dummy argument",
14247 &sym
->declared_at
);
14249 gfc_error ("Assumed shape array at %L must be a dummy argument",
14250 &sym
->declared_at
);
14253 /* TS 29113, C535a. */
14254 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14255 && !sym
->attr
.select_type_temporary
)
14257 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14258 &sym
->declared_at
);
14261 if (as
->type
== AS_ASSUMED_RANK
14262 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14264 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14265 "CODIMENSION attribute", &sym
->declared_at
);
14270 /* Make sure symbols with known intent or optional are really dummy
14271 variable. Because of ENTRY statement, this has to be deferred
14272 until resolution time. */
14274 if (!sym
->attr
.dummy
14275 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14277 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14281 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14283 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14284 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14288 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14290 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14291 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14293 gfc_error ("Character dummy variable %qs at %L with VALUE "
14294 "attribute must have constant length",
14295 sym
->name
, &sym
->declared_at
);
14299 if (sym
->ts
.is_c_interop
14300 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14302 gfc_error ("C interoperable character dummy variable %qs at %L "
14303 "with VALUE attribute must have length one",
14304 sym
->name
, &sym
->declared_at
);
14309 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14310 && sym
->ts
.u
.derived
->attr
.generic
)
14312 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14313 if (!sym
->ts
.u
.derived
)
14315 gfc_error ("The derived type %qs at %L is of type %qs, "
14316 "which has not been defined", sym
->name
,
14317 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14318 sym
->ts
.type
= BT_UNKNOWN
;
14323 /* Use the same constraints as TYPE(*), except for the type check
14324 and that only scalars and assumed-size arrays are permitted. */
14325 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14327 if (!sym
->attr
.dummy
)
14329 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14330 "a dummy argument", sym
->name
, &sym
->declared_at
);
14334 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14335 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14336 && sym
->ts
.type
!= BT_COMPLEX
)
14338 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14339 "of type TYPE(*) or of an numeric intrinsic type",
14340 sym
->name
, &sym
->declared_at
);
14344 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14345 || sym
->attr
.pointer
|| sym
->attr
.value
)
14347 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14348 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14349 "attribute", sym
->name
, &sym
->declared_at
);
14353 if (sym
->attr
.intent
== INTENT_OUT
)
14355 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14356 "have the INTENT(OUT) attribute",
14357 sym
->name
, &sym
->declared_at
);
14360 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14362 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14363 "either be a scalar or an assumed-size array",
14364 sym
->name
, &sym
->declared_at
);
14368 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14369 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14371 sym
->ts
.type
= BT_ASSUMED
;
14372 sym
->as
= gfc_get_array_spec ();
14373 sym
->as
->type
= AS_ASSUMED_SIZE
;
14375 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14377 else if (sym
->ts
.type
== BT_ASSUMED
)
14379 /* TS 29113, C407a. */
14380 if (!sym
->attr
.dummy
)
14382 gfc_error ("Assumed type of variable %s at %L is only permitted "
14383 "for dummy variables", sym
->name
, &sym
->declared_at
);
14386 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14387 || sym
->attr
.pointer
|| sym
->attr
.value
)
14389 gfc_error ("Assumed-type variable %s at %L may not have the "
14390 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14391 sym
->name
, &sym
->declared_at
);
14394 if (sym
->attr
.intent
== INTENT_OUT
)
14396 gfc_error ("Assumed-type variable %s at %L may not have the "
14397 "INTENT(OUT) attribute",
14398 sym
->name
, &sym
->declared_at
);
14401 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14403 gfc_error ("Assumed-type variable %s at %L shall not be an "
14404 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14409 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
14410 do this for something that was implicitly typed because that is handled
14411 in gfc_set_default_type. Handle dummy arguments and procedure
14412 definitions separately. Also, anything that is use associated is not
14413 handled here but instead is handled in the module it is declared in.
14414 Finally, derived type definitions are allowed to be BIND(C) since that
14415 only implies that they're interoperable, and they are checked fully for
14416 interoperability when a variable is declared of that type. */
14417 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
14418 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
14419 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
14423 /* First, make sure the variable is declared at the
14424 module-level scope (J3/04-007, Section 15.3). */
14425 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
14426 sym
->attr
.in_common
== 0)
14428 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14429 "is neither a COMMON block nor declared at the "
14430 "module level scope", sym
->name
, &(sym
->declared_at
));
14433 else if (sym
->common_head
!= NULL
)
14435 t
= verify_com_block_vars_c_interop (sym
->common_head
);
14439 /* If type() declaration, we need to verify that the components
14440 of the given type are all C interoperable, etc. */
14441 if (sym
->ts
.type
== BT_DERIVED
&&
14442 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
14444 /* Make sure the user marked the derived type as BIND(C). If
14445 not, call the verify routine. This could print an error
14446 for the derived type more than once if multiple variables
14447 of that type are declared. */
14448 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
14449 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
14453 /* Verify the variable itself as C interoperable if it
14454 is BIND(C). It is not possible for this to succeed if
14455 the verify_bind_c_derived_type failed, so don't have to handle
14456 any error returned by verify_bind_c_derived_type. */
14457 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
14458 sym
->common_block
);
14463 /* clear the is_bind_c flag to prevent reporting errors more than
14464 once if something failed. */
14465 sym
->attr
.is_bind_c
= 0;
14470 /* If a derived type symbol has reached this point, without its
14471 type being declared, we have an error. Notice that most
14472 conditions that produce undefined derived types have already
14473 been dealt with. However, the likes of:
14474 implicit type(t) (t) ..... call foo (t) will get us here if
14475 the type is not declared in the scope of the implicit
14476 statement. Change the type to BT_UNKNOWN, both because it is so
14477 and to prevent an ICE. */
14478 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14479 && sym
->ts
.u
.derived
->components
== NULL
14480 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14482 gfc_error ("The derived type %qs at %L is of type %qs, "
14483 "which has not been defined", sym
->name
,
14484 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14485 sym
->ts
.type
= BT_UNKNOWN
;
14489 /* Make sure that the derived type has been resolved and that the
14490 derived type is visible in the symbol's namespace, if it is a
14491 module function and is not PRIVATE. */
14492 if (sym
->ts
.type
== BT_DERIVED
14493 && sym
->ts
.u
.derived
->attr
.use_assoc
14494 && sym
->ns
->proc_name
14495 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14496 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14499 /* Unless the derived-type declaration is use associated, Fortran 95
14500 does not allow public entries of private derived types.
14501 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14502 161 in 95-006r3. */
14503 if (sym
->ts
.type
== BT_DERIVED
14504 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14505 && !sym
->ts
.u
.derived
->attr
.use_assoc
14506 && gfc_check_symbol_access (sym
)
14507 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14508 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14509 "derived type %qs",
14510 (sym
->attr
.flavor
== FL_PARAMETER
)
14511 ? "parameter" : "variable",
14512 sym
->name
, &sym
->declared_at
,
14513 sym
->ts
.u
.derived
->name
))
14516 /* F2008, C1302. */
14517 if (sym
->ts
.type
== BT_DERIVED
14518 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14519 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14520 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14521 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14523 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14524 "type LOCK_TYPE must be a coarray", sym
->name
,
14525 &sym
->declared_at
);
14529 /* TS18508, C702/C703. */
14530 if (sym
->ts
.type
== BT_DERIVED
14531 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14532 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14533 || sym
->ts
.u
.derived
->attr
.event_comp
)
14534 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14536 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14537 "type LOCK_TYPE must be a coarray", sym
->name
,
14538 &sym
->declared_at
);
14542 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14543 default initialization is defined (5.1.2.4.4). */
14544 if (sym
->ts
.type
== BT_DERIVED
14546 && sym
->attr
.intent
== INTENT_OUT
14548 && sym
->as
->type
== AS_ASSUMED_SIZE
)
14550 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
14552 if (c
->initializer
)
14554 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14555 "ASSUMED SIZE and so cannot have a default initializer",
14556 sym
->name
, &sym
->declared_at
);
14563 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14564 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
14566 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14567 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14572 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14573 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
14575 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14576 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14581 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14582 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14583 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14584 || class_attr
.codimension
)
14585 && (sym
->attr
.result
|| sym
->result
== sym
))
14587 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14588 "a coarray component", sym
->name
, &sym
->declared_at
);
14593 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
14594 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
14596 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14597 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
14602 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14603 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14604 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14605 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
14606 || class_attr
.allocatable
))
14608 gfc_error ("Variable %qs at %L with coarray component shall be a "
14609 "nonpointer, nonallocatable scalar, which is not a coarray",
14610 sym
->name
, &sym
->declared_at
);
14614 /* F2008, C526. The function-result case was handled above. */
14615 if (class_attr
.codimension
14616 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
14617 || sym
->attr
.select_type_temporary
14618 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14619 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14620 || sym
->ns
->proc_name
->attr
.is_main_program
14621 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
14623 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14624 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
14628 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
14629 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
14631 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
14632 "deferred shape", sym
->name
, &sym
->declared_at
);
14635 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
14636 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
14638 gfc_error ("Allocatable coarray variable %qs at %L must have "
14639 "deferred shape", sym
->name
, &sym
->declared_at
);
14644 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14645 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14646 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14647 || (class_attr
.codimension
&& class_attr
.allocatable
))
14648 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
14650 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
14651 "allocatable coarray or have coarray components",
14652 sym
->name
, &sym
->declared_at
);
14656 if (class_attr
.codimension
&& sym
->attr
.dummy
14657 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
14659 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
14660 "procedure %qs", sym
->name
, &sym
->declared_at
,
14661 sym
->ns
->proc_name
->name
);
14665 if (sym
->ts
.type
== BT_LOGICAL
14666 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
14667 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
14668 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
14671 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
14672 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
14674 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
14675 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
14676 "%L with non-C_Bool kind in BIND(C) procedure "
14677 "%qs", sym
->name
, &sym
->declared_at
,
14678 sym
->ns
->proc_name
->name
))
14680 else if (!gfc_logical_kinds
[i
].c_bool
14681 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
14682 "%qs at %L with non-C_Bool kind in "
14683 "BIND(C) procedure %qs", sym
->name
,
14685 sym
->attr
.function
? sym
->name
14686 : sym
->ns
->proc_name
->name
))
14690 switch (sym
->attr
.flavor
)
14693 if (!resolve_fl_variable (sym
, mp_flag
))
14698 if (sym
->formal
&& !sym
->formal_ns
)
14700 /* Check that none of the arguments are a namelist. */
14701 gfc_formal_arglist
*formal
= sym
->formal
;
14703 for (; formal
; formal
= formal
->next
)
14704 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
14706 gfc_error ("Namelist '%s' can not be an argument to "
14707 "subroutine or function at %L",
14708 formal
->sym
->name
, &sym
->declared_at
);
14713 if (!resolve_fl_procedure (sym
, mp_flag
))
14718 if (!resolve_fl_namelist (sym
))
14723 if (!resolve_fl_parameter (sym
))
14731 /* Resolve array specifier. Check as well some constraints
14732 on COMMON blocks. */
14734 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
14736 /* Set the formal_arg_flag so that check_conflict will not throw
14737 an error for host associated variables in the specification
14738 expression for an array_valued function. */
14739 if (sym
->attr
.function
&& sym
->as
)
14740 formal_arg_flag
= 1;
14742 saved_specification_expr
= specification_expr
;
14743 specification_expr
= true;
14744 gfc_resolve_array_spec (sym
->as
, check_constant
);
14745 specification_expr
= saved_specification_expr
;
14747 formal_arg_flag
= 0;
14749 /* Resolve formal namespaces. */
14750 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
14751 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
14752 gfc_resolve (sym
->formal_ns
);
14754 /* Make sure the formal namespace is present. */
14755 if (sym
->formal
&& !sym
->formal_ns
)
14757 gfc_formal_arglist
*formal
= sym
->formal
;
14758 while (formal
&& !formal
->sym
)
14759 formal
= formal
->next
;
14763 sym
->formal_ns
= formal
->sym
->ns
;
14764 if (sym
->ns
!= formal
->sym
->ns
)
14765 sym
->formal_ns
->refs
++;
14769 /* Check threadprivate restrictions. */
14770 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
14771 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14772 && (!sym
->attr
.in_common
14773 && sym
->module
== NULL
14774 && (sym
->ns
->proc_name
== NULL
14775 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14776 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
14778 /* Check omp declare target restrictions. */
14779 if (sym
->attr
.omp_declare_target
14780 && sym
->attr
.flavor
== FL_VARIABLE
14782 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14783 && (!sym
->attr
.in_common
14784 && sym
->module
== NULL
14785 && (sym
->ns
->proc_name
== NULL
14786 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14787 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14788 sym
->name
, &sym
->declared_at
);
14790 /* If we have come this far we can apply default-initializers, as
14791 described in 14.7.5, to those variables that have not already
14792 been assigned one. */
14793 if (sym
->ts
.type
== BT_DERIVED
14795 && !sym
->attr
.allocatable
14796 && !sym
->attr
.alloc_comp
)
14798 symbol_attribute
*a
= &sym
->attr
;
14800 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
14801 && !a
->in_common
&& !a
->use_assoc
14802 && !a
->result
&& !a
->function
)
14803 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
14804 apply_default_init (sym
);
14805 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
14806 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14807 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14808 /* Mark the result symbol to be referenced, when it has allocatable
14810 sym
->result
->attr
.referenced
= 1;
14813 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
14814 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
14815 && !CLASS_DATA (sym
)->attr
.class_pointer
14816 && !CLASS_DATA (sym
)->attr
.allocatable
)
14817 apply_default_init (sym
);
14819 /* If this symbol has a type-spec, check it. */
14820 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
14821 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
14822 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
14827 /************* Resolve DATA statements *************/
14831 gfc_data_value
*vnode
;
14837 /* Advance the values structure to point to the next value in the data list. */
14840 next_data_value (void)
14842 while (mpz_cmp_ui (values
.left
, 0) == 0)
14845 if (values
.vnode
->next
== NULL
)
14848 values
.vnode
= values
.vnode
->next
;
14849 mpz_set (values
.left
, values
.vnode
->repeat
);
14857 check_data_variable (gfc_data_variable
*var
, locus
*where
)
14863 ar_type mark
= AR_UNKNOWN
;
14865 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
14871 if (!gfc_resolve_expr (var
->expr
))
14875 mpz_init_set_si (offset
, 0);
14878 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
14879 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
14880 e
= e
->value
.function
.actual
->expr
;
14882 if (e
->expr_type
!= EXPR_VARIABLE
)
14883 gfc_internal_error ("check_data_variable(): Bad expression");
14885 sym
= e
->symtree
->n
.sym
;
14887 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
14889 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
14890 sym
->name
, &sym
->declared_at
);
14893 if (e
->ref
== NULL
&& sym
->as
)
14895 gfc_error ("DATA array %qs at %L must be specified in a previous"
14896 " declaration", sym
->name
, where
);
14900 has_pointer
= sym
->attr
.pointer
;
14902 if (gfc_is_coindexed (e
))
14904 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
14909 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14911 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
14915 && ref
->type
== REF_ARRAY
14916 && ref
->u
.ar
.type
!= AR_FULL
)
14918 gfc_error ("DATA element %qs at %L is a pointer and so must "
14919 "be a full array", sym
->name
, where
);
14924 if (e
->rank
== 0 || has_pointer
)
14926 mpz_init_set_ui (size
, 1);
14933 /* Find the array section reference. */
14934 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14936 if (ref
->type
!= REF_ARRAY
)
14938 if (ref
->u
.ar
.type
== AR_ELEMENT
)
14944 /* Set marks according to the reference pattern. */
14945 switch (ref
->u
.ar
.type
)
14953 /* Get the start position of array section. */
14954 gfc_get_section_index (ar
, section_index
, &offset
);
14959 gcc_unreachable ();
14962 if (!gfc_array_size (e
, &size
))
14964 gfc_error ("Nonconstant array section at %L in DATA statement",
14966 mpz_clear (offset
);
14973 while (mpz_cmp_ui (size
, 0) > 0)
14975 if (!next_data_value ())
14977 gfc_error ("DATA statement at %L has more variables than values",
14983 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14987 /* If we have more than one element left in the repeat count,
14988 and we have more than one element left in the target variable,
14989 then create a range assignment. */
14990 /* FIXME: Only done for full arrays for now, since array sections
14992 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14993 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14997 if (mpz_cmp (size
, values
.left
) >= 0)
14999 mpz_init_set (range
, values
.left
);
15000 mpz_sub (size
, size
, values
.left
);
15001 mpz_set_ui (values
.left
, 0);
15005 mpz_init_set (range
, size
);
15006 mpz_sub (values
.left
, values
.left
, size
);
15007 mpz_set_ui (size
, 0);
15010 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15013 mpz_add (offset
, offset
, range
);
15020 /* Assign initial value to symbol. */
15023 mpz_sub_ui (values
.left
, values
.left
, 1);
15024 mpz_sub_ui (size
, size
, 1);
15026 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15031 if (mark
== AR_FULL
)
15032 mpz_add_ui (offset
, offset
, 1);
15034 /* Modify the array section indexes and recalculate the offset
15035 for next element. */
15036 else if (mark
== AR_SECTION
)
15037 gfc_advance_section (section_index
, ar
, &offset
);
15041 if (mark
== AR_SECTION
)
15043 for (i
= 0; i
< ar
->dimen
; i
++)
15044 mpz_clear (section_index
[i
]);
15048 mpz_clear (offset
);
15054 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15056 /* Iterate over a list of elements in a DATA statement. */
15059 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15062 iterator_stack frame
;
15063 gfc_expr
*e
, *start
, *end
, *step
;
15064 bool retval
= true;
15066 mpz_init (frame
.value
);
15069 start
= gfc_copy_expr (var
->iter
.start
);
15070 end
= gfc_copy_expr (var
->iter
.end
);
15071 step
= gfc_copy_expr (var
->iter
.step
);
15073 if (!gfc_simplify_expr (start
, 1)
15074 || start
->expr_type
!= EXPR_CONSTANT
)
15076 gfc_error ("start of implied-do loop at %L could not be "
15077 "simplified to a constant value", &start
->where
);
15081 if (!gfc_simplify_expr (end
, 1)
15082 || end
->expr_type
!= EXPR_CONSTANT
)
15084 gfc_error ("end of implied-do loop at %L could not be "
15085 "simplified to a constant value", &start
->where
);
15089 if (!gfc_simplify_expr (step
, 1)
15090 || step
->expr_type
!= EXPR_CONSTANT
)
15092 gfc_error ("step of implied-do loop at %L could not be "
15093 "simplified to a constant value", &start
->where
);
15098 mpz_set (trip
, end
->value
.integer
);
15099 mpz_sub (trip
, trip
, start
->value
.integer
);
15100 mpz_add (trip
, trip
, step
->value
.integer
);
15102 mpz_div (trip
, trip
, step
->value
.integer
);
15104 mpz_set (frame
.value
, start
->value
.integer
);
15106 frame
.prev
= iter_stack
;
15107 frame
.variable
= var
->iter
.var
->symtree
;
15108 iter_stack
= &frame
;
15110 while (mpz_cmp_ui (trip
, 0) > 0)
15112 if (!traverse_data_var (var
->list
, where
))
15118 e
= gfc_copy_expr (var
->expr
);
15119 if (!gfc_simplify_expr (e
, 1))
15126 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15128 mpz_sub_ui (trip
, trip
, 1);
15132 mpz_clear (frame
.value
);
15135 gfc_free_expr (start
);
15136 gfc_free_expr (end
);
15137 gfc_free_expr (step
);
15139 iter_stack
= frame
.prev
;
15144 /* Type resolve variables in the variable list of a DATA statement. */
15147 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15151 for (; var
; var
= var
->next
)
15153 if (var
->expr
== NULL
)
15154 t
= traverse_data_list (var
, where
);
15156 t
= check_data_variable (var
, where
);
15166 /* Resolve the expressions and iterators associated with a data statement.
15167 This is separate from the assignment checking because data lists should
15168 only be resolved once. */
15171 resolve_data_variables (gfc_data_variable
*d
)
15173 for (; d
; d
= d
->next
)
15175 if (d
->list
== NULL
)
15177 if (!gfc_resolve_expr (d
->expr
))
15182 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15185 if (!resolve_data_variables (d
->list
))
15194 /* Resolve a single DATA statement. We implement this by storing a pointer to
15195 the value list into static variables, and then recursively traversing the
15196 variables list, expanding iterators and such. */
15199 resolve_data (gfc_data
*d
)
15202 if (!resolve_data_variables (d
->var
))
15205 values
.vnode
= d
->value
;
15206 if (d
->value
== NULL
)
15207 mpz_set_ui (values
.left
, 0);
15209 mpz_set (values
.left
, d
->value
->repeat
);
15211 if (!traverse_data_var (d
->var
, &d
->where
))
15214 /* At this point, we better not have any values left. */
15216 if (next_data_value ())
15217 gfc_error ("DATA statement at %L has more values than variables",
15222 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15223 accessed by host or use association, is a dummy argument to a pure function,
15224 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15225 is storage associated with any such variable, shall not be used in the
15226 following contexts: (clients of this function). */
15228 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15229 procedure. Returns zero if assignment is OK, nonzero if there is a
15232 gfc_impure_variable (gfc_symbol
*sym
)
15237 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15240 /* Check if the symbol's ns is inside the pure procedure. */
15241 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15245 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15249 proc
= sym
->ns
->proc_name
;
15250 if (sym
->attr
.dummy
15251 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15252 || proc
->attr
.function
))
15255 /* TODO: Sort out what can be storage associated, if anything, and include
15256 it here. In principle equivalences should be scanned but it does not
15257 seem to be possible to storage associate an impure variable this way. */
15262 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15263 current namespace is inside a pure procedure. */
15266 gfc_pure (gfc_symbol
*sym
)
15268 symbol_attribute attr
;
15273 /* Check if the current namespace or one of its parents
15274 belongs to a pure procedure. */
15275 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15277 sym
= ns
->proc_name
;
15281 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15289 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15293 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15294 checks if the current namespace is implicitly pure. Note that this
15295 function returns false for a PURE procedure. */
15298 gfc_implicit_pure (gfc_symbol
*sym
)
15304 /* Check if the current procedure is implicit_pure. Walk up
15305 the procedure list until we find a procedure. */
15306 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15308 sym
= ns
->proc_name
;
15312 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15317 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15318 && !sym
->attr
.pure
;
15323 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15329 /* Check if the current procedure is implicit_pure. Walk up
15330 the procedure list until we find a procedure. */
15331 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15333 sym
= ns
->proc_name
;
15337 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15342 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15343 sym
->attr
.implicit_pure
= 0;
15345 sym
->attr
.pure
= 0;
15349 /* Test whether the current procedure is elemental or not. */
15352 gfc_elemental (gfc_symbol
*sym
)
15354 symbol_attribute attr
;
15357 sym
= gfc_current_ns
->proc_name
;
15362 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15366 /* Warn about unused labels. */
15369 warn_unused_fortran_label (gfc_st_label
*label
)
15374 warn_unused_fortran_label (label
->left
);
15376 if (label
->defined
== ST_LABEL_UNKNOWN
)
15379 switch (label
->referenced
)
15381 case ST_LABEL_UNKNOWN
:
15382 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
15383 label
->value
, &label
->where
);
15386 case ST_LABEL_BAD_TARGET
:
15387 gfc_warning (OPT_Wunused_label
,
15388 "Label %d at %L defined but cannot be used",
15389 label
->value
, &label
->where
);
15396 warn_unused_fortran_label (label
->right
);
15400 /* Returns the sequence type of a symbol or sequence. */
15403 sequence_type (gfc_typespec ts
)
15412 if (ts
.u
.derived
->components
== NULL
)
15413 return SEQ_NONDEFAULT
;
15415 result
= sequence_type (ts
.u
.derived
->components
->ts
);
15416 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
15417 if (sequence_type (c
->ts
) != result
)
15423 if (ts
.kind
!= gfc_default_character_kind
)
15424 return SEQ_NONDEFAULT
;
15426 return SEQ_CHARACTER
;
15429 if (ts
.kind
!= gfc_default_integer_kind
)
15430 return SEQ_NONDEFAULT
;
15432 return SEQ_NUMERIC
;
15435 if (!(ts
.kind
== gfc_default_real_kind
15436 || ts
.kind
== gfc_default_double_kind
))
15437 return SEQ_NONDEFAULT
;
15439 return SEQ_NUMERIC
;
15442 if (ts
.kind
!= gfc_default_complex_kind
)
15443 return SEQ_NONDEFAULT
;
15445 return SEQ_NUMERIC
;
15448 if (ts
.kind
!= gfc_default_logical_kind
)
15449 return SEQ_NONDEFAULT
;
15451 return SEQ_NUMERIC
;
15454 return SEQ_NONDEFAULT
;
15459 /* Resolve derived type EQUIVALENCE object. */
15462 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
15464 gfc_component
*c
= derived
->components
;
15469 /* Shall not be an object of nonsequence derived type. */
15470 if (!derived
->attr
.sequence
)
15472 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15473 "attribute to be an EQUIVALENCE object", sym
->name
,
15478 /* Shall not have allocatable components. */
15479 if (derived
->attr
.alloc_comp
)
15481 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15482 "components to be an EQUIVALENCE object",sym
->name
,
15487 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
15489 gfc_error ("Derived type variable %qs at %L with default "
15490 "initialization cannot be in EQUIVALENCE with a variable "
15491 "in COMMON", sym
->name
, &e
->where
);
15495 for (; c
; c
= c
->next
)
15497 if (gfc_bt_struct (c
->ts
.type
)
15498 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15501 /* Shall not be an object of sequence derived type containing a pointer
15502 in the structure. */
15503 if (c
->attr
.pointer
)
15505 gfc_error ("Derived type variable %qs at %L with pointer "
15506 "component(s) cannot be an EQUIVALENCE object",
15507 sym
->name
, &e
->where
);
15515 /* Resolve equivalence object.
15516 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15517 an allocatable array, an object of nonsequence derived type, an object of
15518 sequence derived type containing a pointer at any level of component
15519 selection, an automatic object, a function name, an entry name, a result
15520 name, a named constant, a structure component, or a subobject of any of
15521 the preceding objects. A substring shall not have length zero. A
15522 derived type shall not have components with default initialization nor
15523 shall two objects of an equivalence group be initialized.
15524 Either all or none of the objects shall have an protected attribute.
15525 The simple constraints are done in symbol.c(check_conflict) and the rest
15526 are implemented here. */
15529 resolve_equivalence (gfc_equiv
*eq
)
15532 gfc_symbol
*first_sym
;
15535 locus
*last_where
= NULL
;
15536 seq_type eq_type
, last_eq_type
;
15537 gfc_typespec
*last_ts
;
15538 int object
, cnt_protected
;
15541 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
15543 first_sym
= eq
->expr
->symtree
->n
.sym
;
15547 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
15551 e
->ts
= e
->symtree
->n
.sym
->ts
;
15552 /* match_varspec might not know yet if it is seeing
15553 array reference or substring reference, as it doesn't
15555 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
15557 gfc_ref
*ref
= e
->ref
;
15558 sym
= e
->symtree
->n
.sym
;
15560 if (sym
->attr
.dimension
)
15562 ref
->u
.ar
.as
= sym
->as
;
15566 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15567 if (e
->ts
.type
== BT_CHARACTER
15569 && ref
->type
== REF_ARRAY
15570 && ref
->u
.ar
.dimen
== 1
15571 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
15572 && ref
->u
.ar
.stride
[0] == NULL
)
15574 gfc_expr
*start
= ref
->u
.ar
.start
[0];
15575 gfc_expr
*end
= ref
->u
.ar
.end
[0];
15578 /* Optimize away the (:) reference. */
15579 if (start
== NULL
&& end
== NULL
)
15582 e
->ref
= ref
->next
;
15584 e
->ref
->next
= ref
->next
;
15589 ref
->type
= REF_SUBSTRING
;
15591 start
= gfc_get_int_expr (gfc_default_integer_kind
,
15593 ref
->u
.ss
.start
= start
;
15594 if (end
== NULL
&& e
->ts
.u
.cl
)
15595 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
15596 ref
->u
.ss
.end
= end
;
15597 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
15604 /* Any further ref is an error. */
15607 gcc_assert (ref
->type
== REF_ARRAY
);
15608 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15614 if (!gfc_resolve_expr (e
))
15617 sym
= e
->symtree
->n
.sym
;
15619 if (sym
->attr
.is_protected
)
15621 if (cnt_protected
> 0 && cnt_protected
!= object
)
15623 gfc_error ("Either all or none of the objects in the "
15624 "EQUIVALENCE set at %L shall have the "
15625 "PROTECTED attribute",
15630 /* Shall not equivalence common block variables in a PURE procedure. */
15631 if (sym
->ns
->proc_name
15632 && sym
->ns
->proc_name
->attr
.pure
15633 && sym
->attr
.in_common
)
15635 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
15636 "object in the pure procedure %qs",
15637 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
15641 /* Shall not be a named constant. */
15642 if (e
->expr_type
== EXPR_CONSTANT
)
15644 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
15645 "object", sym
->name
, &e
->where
);
15649 if (e
->ts
.type
== BT_DERIVED
15650 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
15653 /* Check that the types correspond correctly:
15655 A numeric sequence structure may be equivalenced to another sequence
15656 structure, an object of default integer type, default real type, double
15657 precision real type, default logical type such that components of the
15658 structure ultimately only become associated to objects of the same
15659 kind. A character sequence structure may be equivalenced to an object
15660 of default character kind or another character sequence structure.
15661 Other objects may be equivalenced only to objects of the same type and
15662 kind parameters. */
15664 /* Identical types are unconditionally OK. */
15665 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
15666 goto identical_types
;
15668 last_eq_type
= sequence_type (*last_ts
);
15669 eq_type
= sequence_type (sym
->ts
);
15671 /* Since the pair of objects is not of the same type, mixed or
15672 non-default sequences can be rejected. */
15674 msg
= "Sequence %s with mixed components in EQUIVALENCE "
15675 "statement at %L with different type objects";
15677 && last_eq_type
== SEQ_MIXED
15678 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15679 || (eq_type
== SEQ_MIXED
15680 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15683 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
15684 "statement at %L with objects of different type";
15686 && last_eq_type
== SEQ_NONDEFAULT
15687 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15688 || (eq_type
== SEQ_NONDEFAULT
15689 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15692 msg
="Non-CHARACTER object %qs in default CHARACTER "
15693 "EQUIVALENCE statement at %L";
15694 if (last_eq_type
== SEQ_CHARACTER
15695 && eq_type
!= SEQ_CHARACTER
15696 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15699 msg
="Non-NUMERIC object %qs in default NUMERIC "
15700 "EQUIVALENCE statement at %L";
15701 if (last_eq_type
== SEQ_NUMERIC
15702 && eq_type
!= SEQ_NUMERIC
15703 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15708 last_where
= &e
->where
;
15713 /* Shall not be an automatic array. */
15714 if (e
->ref
->type
== REF_ARRAY
15715 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
15717 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15718 "an EQUIVALENCE object", sym
->name
, &e
->where
);
15725 /* Shall not be a structure component. */
15726 if (r
->type
== REF_COMPONENT
)
15728 gfc_error ("Structure component %qs at %L cannot be an "
15729 "EQUIVALENCE object",
15730 r
->u
.c
.component
->name
, &e
->where
);
15734 /* A substring shall not have length zero. */
15735 if (r
->type
== REF_SUBSTRING
)
15737 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
15739 gfc_error ("Substring at %L has length zero",
15740 &r
->u
.ss
.start
->where
);
15750 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15753 resolve_fntype (gfc_namespace
*ns
)
15755 gfc_entry_list
*el
;
15758 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
15761 /* If there are any entries, ns->proc_name is the entry master
15762 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15764 sym
= ns
->entries
->sym
;
15766 sym
= ns
->proc_name
;
15767 if (sym
->result
== sym
15768 && sym
->ts
.type
== BT_UNKNOWN
15769 && !gfc_set_default_type (sym
, 0, NULL
)
15770 && !sym
->attr
.untyped
)
15772 gfc_error ("Function %qs at %L has no IMPLICIT type",
15773 sym
->name
, &sym
->declared_at
);
15774 sym
->attr
.untyped
= 1;
15777 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
15778 && !sym
->attr
.contained
15779 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15780 && gfc_check_symbol_access (sym
))
15782 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
15783 "%L of PRIVATE type %qs", sym
->name
,
15784 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15788 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
15790 if (el
->sym
->result
== el
->sym
15791 && el
->sym
->ts
.type
== BT_UNKNOWN
15792 && !gfc_set_default_type (el
->sym
, 0, NULL
)
15793 && !el
->sym
->attr
.untyped
)
15795 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
15796 el
->sym
->name
, &el
->sym
->declared_at
);
15797 el
->sym
->attr
.untyped
= 1;
15803 /* 12.3.2.1.1 Defined operators. */
15806 check_uop_procedure (gfc_symbol
*sym
, locus where
)
15808 gfc_formal_arglist
*formal
;
15810 if (!sym
->attr
.function
)
15812 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
15813 sym
->name
, &where
);
15817 if (sym
->ts
.type
== BT_CHARACTER
15818 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
15819 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
15820 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
15822 gfc_error ("User operator procedure %qs at %L cannot be assumed "
15823 "character length", sym
->name
, &where
);
15827 formal
= gfc_sym_get_dummy_args (sym
);
15828 if (!formal
|| !formal
->sym
)
15830 gfc_error ("User operator procedure %qs at %L must have at least "
15831 "one argument", sym
->name
, &where
);
15835 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15837 gfc_error ("First argument of operator interface at %L must be "
15838 "INTENT(IN)", &where
);
15842 if (formal
->sym
->attr
.optional
)
15844 gfc_error ("First argument of operator interface at %L cannot be "
15845 "optional", &where
);
15849 formal
= formal
->next
;
15850 if (!formal
|| !formal
->sym
)
15853 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15855 gfc_error ("Second argument of operator interface at %L must be "
15856 "INTENT(IN)", &where
);
15860 if (formal
->sym
->attr
.optional
)
15862 gfc_error ("Second argument of operator interface at %L cannot be "
15863 "optional", &where
);
15869 gfc_error ("Operator interface at %L must have, at most, two "
15870 "arguments", &where
);
15878 gfc_resolve_uops (gfc_symtree
*symtree
)
15880 gfc_interface
*itr
;
15882 if (symtree
== NULL
)
15885 gfc_resolve_uops (symtree
->left
);
15886 gfc_resolve_uops (symtree
->right
);
15888 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
15889 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
15893 /* Examine all of the expressions associated with a program unit,
15894 assign types to all intermediate expressions, make sure that all
15895 assignments are to compatible types and figure out which names
15896 refer to which functions or subroutines. It doesn't check code
15897 block, which is handled by gfc_resolve_code. */
15900 resolve_types (gfc_namespace
*ns
)
15906 gfc_namespace
* old_ns
= gfc_current_ns
;
15908 if (ns
->types_resolved
)
15911 /* Check that all IMPLICIT types are ok. */
15912 if (!ns
->seen_implicit_none
)
15915 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
15916 if (ns
->set_flag
[letter
]
15917 && !resolve_typespec_used (&ns
->default_type
[letter
],
15918 &ns
->implicit_loc
[letter
], NULL
))
15922 gfc_current_ns
= ns
;
15924 resolve_entries (ns
);
15926 resolve_common_vars (&ns
->blank_common
, false);
15927 resolve_common_blocks (ns
->common_root
);
15929 resolve_contained_functions (ns
);
15931 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
15932 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15933 resolve_formal_arglist (ns
->proc_name
);
15935 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
15937 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
15938 resolve_charlen (cl
);
15940 gfc_traverse_ns (ns
, resolve_symbol
);
15942 resolve_fntype (ns
);
15944 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15946 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
15947 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
15948 "also be PURE", n
->proc_name
->name
,
15949 &n
->proc_name
->declared_at
);
15955 gfc_do_concurrent_flag
= 0;
15956 gfc_check_interfaces (ns
);
15958 gfc_traverse_ns (ns
, resolve_values
);
15964 for (d
= ns
->data
; d
; d
= d
->next
)
15968 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
15970 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
15972 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
15973 resolve_equivalence (eq
);
15975 /* Warn about unused labels. */
15976 if (warn_unused_label
)
15977 warn_unused_fortran_label (ns
->st_labels
);
15979 gfc_resolve_uops (ns
->uop_root
);
15981 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
15983 gfc_resolve_omp_declare_simd (ns
);
15985 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
15987 ns
->types_resolved
= 1;
15989 gfc_current_ns
= old_ns
;
15993 /* Call gfc_resolve_code recursively. */
15996 resolve_codes (gfc_namespace
*ns
)
15999 bitmap_obstack old_obstack
;
16001 if (ns
->resolved
== 1)
16004 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16007 gfc_current_ns
= ns
;
16009 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16010 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16013 /* Set to an out of range value. */
16014 current_entry_id
= -1;
16016 old_obstack
= labels_obstack
;
16017 bitmap_obstack_initialize (&labels_obstack
);
16019 gfc_resolve_oacc_declare (ns
);
16020 gfc_resolve_code (ns
->code
, ns
);
16022 bitmap_obstack_release (&labels_obstack
);
16023 labels_obstack
= old_obstack
;
16027 /* This function is called after a complete program unit has been compiled.
16028 Its purpose is to examine all of the expressions associated with a program
16029 unit, assign types to all intermediate expressions, make sure that all
16030 assignments are to compatible types and figure out which names refer to
16031 which functions or subroutines. */
16034 gfc_resolve (gfc_namespace
*ns
)
16036 gfc_namespace
*old_ns
;
16037 code_stack
*old_cs_base
;
16038 struct gfc_omp_saved_state old_omp_state
;
16044 old_ns
= gfc_current_ns
;
16045 old_cs_base
= cs_base
;
16047 /* As gfc_resolve can be called during resolution of an OpenMP construct
16048 body, we should clear any state associated to it, so that say NS's
16049 DO loops are not interpreted as OpenMP loops. */
16050 if (!ns
->construct_entities
)
16051 gfc_omp_save_and_clear_state (&old_omp_state
);
16053 resolve_types (ns
);
16054 component_assignment_level
= 0;
16055 resolve_codes (ns
);
16057 gfc_current_ns
= old_ns
;
16058 cs_base
= old_cs_base
;
16061 gfc_run_passes (ns
);
16063 if (!ns
->construct_entities
)
16064 gfc_omp_restore_state (&old_omp_state
);