1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2017 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 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag
= false;
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;
288 formal_arg_flag
= true;
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
);
533 formal_arg_flag
= false;
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 (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
571 && sym
->ns
->parent
->proc_name
572 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
573 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
574 gfc_error ("Contained procedure %qs at %L has the same name as its "
575 "encompassing procedure", sym
->name
, &sym
->declared_at
);
577 /* If this namespace is not a function or an entry master function,
579 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
580 || sym
->attr
.entry_master
)
583 /* Try to find out of what the return type is. */
584 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
586 t
= gfc_set_default_type (sym
->result
, 0, ns
);
588 if (!t
&& !sym
->result
->attr
.untyped
)
590 if (sym
->result
== sym
)
591 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
592 sym
->name
, &sym
->declared_at
);
593 else if (!sym
->result
->attr
.proc_pointer
)
594 gfc_error ("Result %qs of contained function %qs at %L has "
595 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
596 &sym
->result
->declared_at
);
597 sym
->result
->attr
.untyped
= 1;
601 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
602 type, lists the only ways a character length value of * can be used:
603 dummy arguments of procedures, named constants, and function results
604 in external functions. Internal function results and results of module
605 procedures are not on this list, ergo, not permitted. */
607 if (sym
->result
->ts
.type
== BT_CHARACTER
)
609 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
610 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
612 /* See if this is a module-procedure and adapt error message
615 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
616 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
618 gfc_error (module_proc
619 ? G_("Character-valued module procedure %qs at %L"
620 " must not be assumed length")
621 : G_("Character-valued internal function %qs at %L"
622 " must not be assumed length"),
623 sym
->name
, &sym
->declared_at
);
629 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
630 introduce duplicates. */
633 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
635 gfc_formal_arglist
*f
, *new_arglist
;
638 for (; new_args
!= NULL
; new_args
= new_args
->next
)
640 new_sym
= new_args
->sym
;
641 /* See if this arg is already in the formal argument list. */
642 for (f
= proc
->formal
; f
; f
= f
->next
)
644 if (new_sym
== f
->sym
)
651 /* Add a new argument. Argument order is not important. */
652 new_arglist
= gfc_get_formal_arglist ();
653 new_arglist
->sym
= new_sym
;
654 new_arglist
->next
= proc
->formal
;
655 proc
->formal
= new_arglist
;
660 /* Flag the arguments that are not present in all entries. */
663 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
665 gfc_formal_arglist
*f
, *head
;
668 for (f
= proc
->formal
; f
; f
= f
->next
)
673 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
675 if (new_args
->sym
== f
->sym
)
682 f
->sym
->attr
.not_always_present
= 1;
687 /* Resolve alternate entry points. If a symbol has multiple entry points we
688 create a new master symbol for the main routine, and turn the existing
689 symbol into an entry point. */
692 resolve_entries (gfc_namespace
*ns
)
694 gfc_namespace
*old_ns
;
698 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
699 static int master_count
= 0;
701 if (ns
->proc_name
== NULL
)
704 /* No need to do anything if this procedure doesn't have alternate entry
709 /* We may already have resolved alternate entry points. */
710 if (ns
->proc_name
->attr
.entry_master
)
713 /* If this isn't a procedure something has gone horribly wrong. */
714 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
716 /* Remember the current namespace. */
717 old_ns
= gfc_current_ns
;
721 /* Add the main entry point to the list of entry points. */
722 el
= gfc_get_entry_list ();
723 el
->sym
= ns
->proc_name
;
725 el
->next
= ns
->entries
;
727 ns
->proc_name
->attr
.entry
= 1;
729 /* If it is a module function, it needs to be in the right namespace
730 so that gfc_get_fake_result_decl can gather up the results. The
731 need for this arose in get_proc_name, where these beasts were
732 left in their own namespace, to keep prior references linked to
733 the entry declaration.*/
734 if (ns
->proc_name
->attr
.function
735 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
738 /* Do the same for entries where the master is not a module
739 procedure. These are retained in the module namespace because
740 of the module procedure declaration. */
741 for (el
= el
->next
; el
; el
= el
->next
)
742 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
743 && el
->sym
->attr
.mod_proc
)
747 /* Add an entry statement for it. */
748 c
= gfc_get_code (EXEC_ENTRY
);
753 /* Create a new symbol for the master function. */
754 /* Give the internal function a unique name (within this file).
755 Also include the function name so the user has some hope of figuring
756 out what is going on. */
757 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
758 master_count
++, ns
->proc_name
->name
);
759 gfc_get_ha_symbol (name
, &proc
);
760 gcc_assert (proc
!= NULL
);
762 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
763 if (ns
->proc_name
->attr
.subroutine
)
764 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
768 gfc_typespec
*ts
, *fts
;
769 gfc_array_spec
*as
, *fas
;
770 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
772 fas
= ns
->entries
->sym
->as
;
773 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
774 fts
= &ns
->entries
->sym
->result
->ts
;
775 if (fts
->type
== BT_UNKNOWN
)
776 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
777 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
779 ts
= &el
->sym
->result
->ts
;
781 as
= as
? as
: el
->sym
->result
->as
;
782 if (ts
->type
== BT_UNKNOWN
)
783 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
785 if (! gfc_compare_types (ts
, fts
)
786 || (el
->sym
->result
->attr
.dimension
787 != ns
->entries
->sym
->result
->attr
.dimension
)
788 || (el
->sym
->result
->attr
.pointer
789 != ns
->entries
->sym
->result
->attr
.pointer
))
791 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
792 && gfc_compare_array_spec (as
, fas
) == 0)
793 gfc_error ("Function %s at %L has entries with mismatched "
794 "array specifications", ns
->entries
->sym
->name
,
795 &ns
->entries
->sym
->declared_at
);
796 /* The characteristics need to match and thus both need to have
797 the same string length, i.e. both len=*, or both len=4.
798 Having both len=<variable> is also possible, but difficult to
799 check at compile time. */
800 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
801 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
802 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
804 && ts
->u
.cl
->length
->expr_type
805 != fts
->u
.cl
->length
->expr_type
)
807 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
808 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
809 fts
->u
.cl
->length
->value
.integer
) != 0)))
810 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
811 "entries returning variables of different "
812 "string lengths", ns
->entries
->sym
->name
,
813 &ns
->entries
->sym
->declared_at
);
818 sym
= ns
->entries
->sym
->result
;
819 /* All result types the same. */
821 if (sym
->attr
.dimension
)
822 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
823 if (sym
->attr
.pointer
)
824 gfc_add_pointer (&proc
->attr
, NULL
);
828 /* Otherwise the result will be passed through a union by
830 proc
->attr
.mixed_entry_master
= 1;
831 for (el
= ns
->entries
; el
; el
= el
->next
)
833 sym
= el
->sym
->result
;
834 if (sym
->attr
.dimension
)
836 if (el
== ns
->entries
)
837 gfc_error ("FUNCTION result %s can't be an array in "
838 "FUNCTION %s at %L", sym
->name
,
839 ns
->entries
->sym
->name
, &sym
->declared_at
);
841 gfc_error ("ENTRY result %s can't be an array in "
842 "FUNCTION %s at %L", sym
->name
,
843 ns
->entries
->sym
->name
, &sym
->declared_at
);
845 else if (sym
->attr
.pointer
)
847 if (el
== ns
->entries
)
848 gfc_error ("FUNCTION result %s can't be a POINTER in "
849 "FUNCTION %s at %L", sym
->name
,
850 ns
->entries
->sym
->name
, &sym
->declared_at
);
852 gfc_error ("ENTRY result %s can't be a POINTER in "
853 "FUNCTION %s at %L", sym
->name
,
854 ns
->entries
->sym
->name
, &sym
->declared_at
);
859 if (ts
->type
== BT_UNKNOWN
)
860 ts
= gfc_get_default_type (sym
->name
, NULL
);
864 if (ts
->kind
== gfc_default_integer_kind
)
868 if (ts
->kind
== gfc_default_real_kind
869 || ts
->kind
== gfc_default_double_kind
)
873 if (ts
->kind
== gfc_default_complex_kind
)
877 if (ts
->kind
== gfc_default_logical_kind
)
881 /* We will issue error elsewhere. */
889 if (el
== ns
->entries
)
890 gfc_error ("FUNCTION result %s can't be of type %s "
891 "in FUNCTION %s at %L", sym
->name
,
892 gfc_typename (ts
), ns
->entries
->sym
->name
,
895 gfc_error ("ENTRY result %s can't be of type %s "
896 "in FUNCTION %s at %L", sym
->name
,
897 gfc_typename (ts
), ns
->entries
->sym
->name
,
904 proc
->attr
.access
= ACCESS_PRIVATE
;
905 proc
->attr
.entry_master
= 1;
907 /* Merge all the entry point arguments. */
908 for (el
= ns
->entries
; el
; el
= el
->next
)
909 merge_argument_lists (proc
, el
->sym
->formal
);
911 /* Check the master formal arguments for any that are not
912 present in all entry points. */
913 for (el
= ns
->entries
; el
; el
= el
->next
)
914 check_argument_lists (proc
, el
->sym
->formal
);
916 /* Use the master function for the function body. */
917 ns
->proc_name
= proc
;
919 /* Finalize the new symbols. */
920 gfc_commit_symbols ();
922 /* Restore the original namespace. */
923 gfc_current_ns
= old_ns
;
927 /* Resolve common variables. */
929 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
931 gfc_symbol
*csym
= common_block
->head
;
933 for (; csym
; csym
= csym
->common_next
)
935 /* gfc_add_in_common may have been called before, but the reported errors
936 have been ignored to continue parsing.
937 We do the checks again here. */
938 if (!csym
->attr
.use_assoc
)
939 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
941 if (csym
->value
|| csym
->attr
.data
)
943 if (!csym
->ns
->is_block_data
)
944 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
945 "but only in BLOCK DATA initialization is "
946 "allowed", csym
->name
, &csym
->declared_at
);
947 else if (!named_common
)
948 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
949 "in a blank COMMON but initialization is only "
950 "allowed in named common blocks", csym
->name
,
954 if (UNLIMITED_POLY (csym
))
955 gfc_error_now ("%qs in cannot appear in COMMON at %L "
956 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
958 if (csym
->ts
.type
!= BT_DERIVED
)
961 if (!(csym
->ts
.u
.derived
->attr
.sequence
962 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
963 gfc_error_now ("Derived type variable %qs in COMMON at %L "
964 "has neither the SEQUENCE nor the BIND(C) "
965 "attribute", csym
->name
, &csym
->declared_at
);
966 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
967 gfc_error_now ("Derived type variable %qs in COMMON at %L "
968 "has an ultimate component that is "
969 "allocatable", csym
->name
, &csym
->declared_at
);
970 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
971 gfc_error_now ("Derived type variable %qs in COMMON at %L "
972 "may not have default initializer", csym
->name
,
975 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
976 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
980 /* Resolve common blocks. */
982 resolve_common_blocks (gfc_symtree
*common_root
)
987 if (common_root
== NULL
)
990 if (common_root
->left
)
991 resolve_common_blocks (common_root
->left
);
992 if (common_root
->right
)
993 resolve_common_blocks (common_root
->right
);
995 resolve_common_vars (common_root
->n
.common
, true);
997 /* The common name is a global name - in Fortran 2003 also if it has a
998 C binding name, since Fortran 2008 only the C binding name is a global
1000 if (!common_root
->n
.common
->binding_label
1001 || gfc_notification_std (GFC_STD_F2008
))
1003 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1004 common_root
->n
.common
->name
);
1006 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1007 && gsym
->type
== GSYM_COMMON
1008 && ((common_root
->n
.common
->binding_label
1009 && (!gsym
->binding_label
1010 || strcmp (common_root
->n
.common
->binding_label
,
1011 gsym
->binding_label
) != 0))
1012 || (!common_root
->n
.common
->binding_label
1013 && gsym
->binding_label
)))
1015 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1016 "identifier and must thus have the same binding name "
1017 "as the same-named COMMON block at %L: %s vs %s",
1018 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1020 common_root
->n
.common
->binding_label
1021 ? common_root
->n
.common
->binding_label
: "(blank)",
1022 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1026 if (gsym
&& gsym
->type
!= GSYM_COMMON
1027 && !common_root
->n
.common
->binding_label
)
1029 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1031 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1035 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1037 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1038 "%L sharing the identifier with global non-COMMON-block "
1039 "entity at %L", common_root
->n
.common
->name
,
1040 &common_root
->n
.common
->where
, &gsym
->where
);
1045 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1046 gsym
->type
= GSYM_COMMON
;
1047 gsym
->where
= common_root
->n
.common
->where
;
1053 if (common_root
->n
.common
->binding_label
)
1055 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1056 common_root
->n
.common
->binding_label
);
1057 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1059 gfc_error ("COMMON block at %L with binding label %s uses the same "
1060 "global identifier as entity at %L",
1061 &common_root
->n
.common
->where
,
1062 common_root
->n
.common
->binding_label
, &gsym
->where
);
1067 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1068 gsym
->type
= GSYM_COMMON
;
1069 gsym
->where
= common_root
->n
.common
->where
;
1075 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1079 if (sym
->attr
.flavor
== FL_PARAMETER
)
1080 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1081 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1083 if (sym
->attr
.external
)
1084 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1085 sym
->name
, &common_root
->n
.common
->where
);
1087 if (sym
->attr
.intrinsic
)
1088 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1089 sym
->name
, &common_root
->n
.common
->where
);
1090 else if (sym
->attr
.result
1091 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1092 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1093 "that is also a function result", sym
->name
,
1094 &common_root
->n
.common
->where
);
1095 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1096 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1097 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1098 "that is also a global procedure", sym
->name
,
1099 &common_root
->n
.common
->where
);
1103 /* Resolve contained function types. Because contained functions can call one
1104 another, they have to be worked out before any of the contained procedures
1107 The good news is that if a function doesn't already have a type, the only
1108 way it can get one is through an IMPLICIT type or a RESULT variable, because
1109 by definition contained functions are contained namespace they're contained
1110 in, not in a sibling or parent namespace. */
1113 resolve_contained_functions (gfc_namespace
*ns
)
1115 gfc_namespace
*child
;
1118 resolve_formal_arglists (ns
);
1120 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1122 /* Resolve alternate entry points first. */
1123 resolve_entries (child
);
1125 /* Then check function return types. */
1126 resolve_contained_fntype (child
->proc_name
, child
);
1127 for (el
= child
->entries
; el
; el
= el
->next
)
1128 resolve_contained_fntype (el
->sym
, child
);
1133 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1134 static bool resolve_fl_struct (gfc_symbol
*sym
);
1137 /* Resolve all of the elements of a structure constructor and make sure that
1138 the types are correct. The 'init' flag indicates that the given
1139 constructor is an initializer. */
1142 resolve_structure_cons (gfc_expr
*expr
, int init
)
1144 gfc_constructor
*cons
;
1145 gfc_component
*comp
;
1151 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1153 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1154 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1156 resolve_fl_struct (expr
->ts
.u
.derived
);
1159 cons
= gfc_constructor_first (expr
->value
.constructor
);
1161 /* A constructor may have references if it is the result of substituting a
1162 parameter variable. In this case we just pull out the component we
1165 comp
= expr
->ref
->u
.c
.sym
->components
;
1167 comp
= expr
->ts
.u
.derived
->components
;
1169 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1176 /* Unions use an EXPR_NULL contrived expression to tell the translation
1177 phase to generate an initializer of the appropriate length.
1179 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1182 if (!gfc_resolve_expr (cons
->expr
))
1188 rank
= comp
->as
? comp
->as
->rank
: 0;
1189 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1190 rank
= CLASS_DATA (comp
)->as
->rank
;
1192 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1193 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1195 gfc_error ("The rank of the element in the structure "
1196 "constructor at %L does not match that of the "
1197 "component (%d/%d)", &cons
->expr
->where
,
1198 cons
->expr
->rank
, rank
);
1202 /* If we don't have the right type, try to convert it. */
1204 if (!comp
->attr
.proc_pointer
&&
1205 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1207 if (strcmp (comp
->name
, "_extends") == 0)
1209 /* Can afford to be brutal with the _extends initializer.
1210 The derived type can get lost because it is PRIVATE
1211 but it is not usage constrained by the standard. */
1212 cons
->expr
->ts
= comp
->ts
;
1214 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1216 gfc_error ("The element in the structure constructor at %L, "
1217 "for pointer component %qs, is %s but should be %s",
1218 &cons
->expr
->where
, comp
->name
,
1219 gfc_basic_typename (cons
->expr
->ts
.type
),
1220 gfc_basic_typename (comp
->ts
.type
));
1225 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1231 /* For strings, the length of the constructor should be the same as
1232 the one of the structure, ensure this if the lengths are known at
1233 compile time and when we are dealing with PARAMETER or structure
1235 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1236 && comp
->ts
.u
.cl
->length
1237 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1238 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1239 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1240 && cons
->expr
->rank
!= 0
1241 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1242 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1244 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1245 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1247 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1248 to make use of the gfc_resolve_character_array_constructor
1249 machinery. The expression is later simplified away to
1250 an array of string literals. */
1251 gfc_expr
*para
= cons
->expr
;
1252 cons
->expr
= gfc_get_expr ();
1253 cons
->expr
->ts
= para
->ts
;
1254 cons
->expr
->where
= para
->where
;
1255 cons
->expr
->expr_type
= EXPR_ARRAY
;
1256 cons
->expr
->rank
= para
->rank
;
1257 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1258 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1259 para
, &cons
->expr
->where
);
1262 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1264 /* Rely on the cleanup of the namespace to deal correctly with
1265 the old charlen. (There was a block here that attempted to
1266 remove the charlen but broke the chain in so doing.) */
1267 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1268 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1269 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1270 gfc_resolve_character_array_constructor (cons
->expr
);
1274 if (cons
->expr
->expr_type
== EXPR_NULL
1275 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1276 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1277 || (comp
->ts
.type
== BT_CLASS
1278 && (CLASS_DATA (comp
)->attr
.class_pointer
1279 || CLASS_DATA (comp
)->attr
.allocatable
))))
1282 gfc_error ("The NULL in the structure constructor at %L is "
1283 "being applied to component %qs, which is neither "
1284 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1288 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1290 /* Check procedure pointer interface. */
1291 gfc_symbol
*s2
= NULL
;
1296 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1299 s2
= c2
->ts
.interface
;
1302 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1304 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1305 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1307 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1309 s2
= cons
->expr
->symtree
->n
.sym
;
1310 name
= cons
->expr
->symtree
->n
.sym
->name
;
1313 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1314 err
, sizeof (err
), NULL
, NULL
))
1316 gfc_error_opt (OPT_Wargument_mismatch
,
1317 "Interface mismatch for procedure-pointer "
1318 "component %qs in structure constructor at %L:"
1319 " %s", comp
->name
, &cons
->expr
->where
, err
);
1324 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1325 || cons
->expr
->expr_type
== EXPR_NULL
)
1328 a
= gfc_expr_attr (cons
->expr
);
1330 if (!a
.pointer
&& !a
.target
)
1333 gfc_error ("The element in the structure constructor at %L, "
1334 "for pointer component %qs should be a POINTER or "
1335 "a TARGET", &cons
->expr
->where
, comp
->name
);
1340 /* F08:C461. Additional checks for pointer initialization. */
1344 gfc_error ("Pointer initialization target at %L "
1345 "must not be ALLOCATABLE", &cons
->expr
->where
);
1350 gfc_error ("Pointer initialization target at %L "
1351 "must have the SAVE attribute", &cons
->expr
->where
);
1355 /* F2003, C1272 (3). */
1356 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1357 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1358 || gfc_is_coindexed (cons
->expr
));
1359 if (impure
&& gfc_pure (NULL
))
1362 gfc_error ("Invalid expression in the structure constructor for "
1363 "pointer component %qs at %L in PURE procedure",
1364 comp
->name
, &cons
->expr
->where
);
1368 gfc_unset_implicit_pure (NULL
);
1375 /****************** Expression name resolution ******************/
1377 /* Returns 0 if a symbol was not declared with a type or
1378 attribute declaration statement, nonzero otherwise. */
1381 was_declared (gfc_symbol
*sym
)
1387 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1390 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1391 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1392 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1393 || a
.asynchronous
|| a
.codimension
)
1400 /* Determine if a symbol is generic or not. */
1403 generic_sym (gfc_symbol
*sym
)
1407 if (sym
->attr
.generic
||
1408 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1411 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1414 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1421 return generic_sym (s
);
1428 /* Determine if a symbol is specific or not. */
1431 specific_sym (gfc_symbol
*sym
)
1435 if (sym
->attr
.if_source
== IFSRC_IFBODY
1436 || sym
->attr
.proc
== PROC_MODULE
1437 || sym
->attr
.proc
== PROC_INTERNAL
1438 || sym
->attr
.proc
== PROC_ST_FUNCTION
1439 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1440 || sym
->attr
.external
)
1443 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1446 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1448 return (s
== NULL
) ? 0 : specific_sym (s
);
1452 /* Figure out if the procedure is specific, generic or unknown. */
1455 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1458 procedure_kind (gfc_symbol
*sym
)
1460 if (generic_sym (sym
))
1461 return PTYPE_GENERIC
;
1463 if (specific_sym (sym
))
1464 return PTYPE_SPECIFIC
;
1466 return PTYPE_UNKNOWN
;
1469 /* Check references to assumed size arrays. The flag need_full_assumed_size
1470 is nonzero when matching actual arguments. */
1472 static int need_full_assumed_size
= 0;
1475 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1477 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1480 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1481 What should it be? */
1482 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1483 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1484 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1486 gfc_error ("The upper bound in the last dimension must "
1487 "appear in the reference to the assumed size "
1488 "array %qs at %L", sym
->name
, &e
->where
);
1495 /* Look for bad assumed size array references in argument expressions
1496 of elemental and array valued intrinsic procedures. Since this is
1497 called from procedure resolution functions, it only recurses at
1501 resolve_assumed_size_actual (gfc_expr
*e
)
1506 switch (e
->expr_type
)
1509 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1514 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1515 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1526 /* Check a generic procedure, passed as an actual argument, to see if
1527 there is a matching specific name. If none, it is an error, and if
1528 more than one, the reference is ambiguous. */
1530 count_specific_procs (gfc_expr
*e
)
1537 sym
= e
->symtree
->n
.sym
;
1539 for (p
= sym
->generic
; p
; p
= p
->next
)
1540 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1542 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1548 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1552 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1553 "argument at %L", sym
->name
, &e
->where
);
1559 /* See if a call to sym could possibly be a not allowed RECURSION because of
1560 a missing RECURSIVE declaration. This means that either sym is the current
1561 context itself, or sym is the parent of a contained procedure calling its
1562 non-RECURSIVE containing procedure.
1563 This also works if sym is an ENTRY. */
1566 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1568 gfc_symbol
* proc_sym
;
1569 gfc_symbol
* context_proc
;
1570 gfc_namespace
* real_context
;
1572 if (sym
->attr
.flavor
== FL_PROGRAM
1573 || gfc_fl_struct (sym
->attr
.flavor
))
1576 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1578 /* If we've got an ENTRY, find real procedure. */
1579 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1580 proc_sym
= sym
->ns
->entries
->sym
;
1584 /* If sym is RECURSIVE, all is well of course. */
1585 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1588 /* Find the context procedure's "real" symbol if it has entries.
1589 We look for a procedure symbol, so recurse on the parents if we don't
1590 find one (like in case of a BLOCK construct). */
1591 for (real_context
= context
; ; real_context
= real_context
->parent
)
1593 /* We should find something, eventually! */
1594 gcc_assert (real_context
);
1596 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1597 : real_context
->proc_name
);
1599 /* In some special cases, there may not be a proc_name, like for this
1601 real(bad_kind()) function foo () ...
1602 when checking the call to bad_kind ().
1603 In these cases, we simply return here and assume that the
1608 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1612 /* A call from sym's body to itself is recursion, of course. */
1613 if (context_proc
== proc_sym
)
1616 /* The same is true if context is a contained procedure and sym the
1618 if (context_proc
->attr
.contained
)
1620 gfc_symbol
* parent_proc
;
1622 gcc_assert (context
->parent
);
1623 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1624 : context
->parent
->proc_name
);
1626 if (parent_proc
== proc_sym
)
1634 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1635 its typespec and formal argument list. */
1638 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1640 gfc_intrinsic_sym
* isym
= NULL
;
1646 /* Already resolved. */
1647 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1650 /* We already know this one is an intrinsic, so we don't call
1651 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1652 gfc_find_subroutine directly to check whether it is a function or
1655 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1657 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1658 isym
= gfc_intrinsic_subroutine_by_id (id
);
1660 else if (sym
->intmod_sym_id
)
1662 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1663 isym
= gfc_intrinsic_function_by_id (id
);
1665 else if (!sym
->attr
.subroutine
)
1666 isym
= gfc_find_function (sym
->name
);
1668 if (isym
&& !sym
->attr
.subroutine
)
1670 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1671 && !sym
->attr
.implicit_type
)
1672 gfc_warning (OPT_Wsurprising
,
1673 "Type specified for intrinsic function %qs at %L is"
1674 " ignored", sym
->name
, &sym
->declared_at
);
1676 if (!sym
->attr
.function
&&
1677 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1682 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1684 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1686 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1687 " specifier", sym
->name
, &sym
->declared_at
);
1691 if (!sym
->attr
.subroutine
&&
1692 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1697 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1702 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1704 sym
->attr
.pure
= isym
->pure
;
1705 sym
->attr
.elemental
= isym
->elemental
;
1707 /* Check it is actually available in the standard settings. */
1708 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1710 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1711 "available in the current standard settings but %s. Use "
1712 "an appropriate %<-std=*%> option or enable "
1713 "%<-fall-intrinsics%> in order to use it.",
1714 sym
->name
, &sym
->declared_at
, symstd
);
1722 /* Resolve a procedure expression, like passing it to a called procedure or as
1723 RHS for a procedure pointer assignment. */
1726 resolve_procedure_expression (gfc_expr
* expr
)
1730 if (expr
->expr_type
!= EXPR_VARIABLE
)
1732 gcc_assert (expr
->symtree
);
1734 sym
= expr
->symtree
->n
.sym
;
1736 if (sym
->attr
.intrinsic
)
1737 gfc_resolve_intrinsic (sym
, &expr
->where
);
1739 if (sym
->attr
.flavor
!= FL_PROCEDURE
1740 || (sym
->attr
.function
&& sym
->result
== sym
))
1743 /* A non-RECURSIVE procedure that is used as procedure expression within its
1744 own body is in danger of being called recursively. */
1745 if (is_illegal_recursion (sym
, gfc_current_ns
))
1746 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1747 " itself recursively. Declare it RECURSIVE or use"
1748 " %<-frecursive%>", sym
->name
, &expr
->where
);
1754 /* Resolve an actual argument list. Most of the time, this is just
1755 resolving the expressions in the list.
1756 The exception is that we sometimes have to decide whether arguments
1757 that look like procedure arguments are really simple variable
1761 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1762 bool no_formal_args
)
1765 gfc_symtree
*parent_st
;
1767 gfc_component
*comp
;
1768 int save_need_full_assumed_size
;
1769 bool return_value
= false;
1770 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1773 first_actual_arg
= true;
1775 for (; arg
; arg
= arg
->next
)
1780 /* Check the label is a valid branching target. */
1783 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1785 gfc_error ("Label %d referenced at %L is never defined",
1786 arg
->label
->value
, &arg
->label
->where
);
1790 first_actual_arg
= false;
1794 if (e
->expr_type
== EXPR_VARIABLE
1795 && e
->symtree
->n
.sym
->attr
.generic
1797 && count_specific_procs (e
) != 1)
1800 if (e
->ts
.type
!= BT_PROCEDURE
)
1802 save_need_full_assumed_size
= need_full_assumed_size
;
1803 if (e
->expr_type
!= EXPR_VARIABLE
)
1804 need_full_assumed_size
= 0;
1805 if (!gfc_resolve_expr (e
))
1807 need_full_assumed_size
= save_need_full_assumed_size
;
1811 /* See if the expression node should really be a variable reference. */
1813 sym
= e
->symtree
->n
.sym
;
1815 if (sym
->attr
.flavor
== FL_PROCEDURE
1816 || sym
->attr
.intrinsic
1817 || sym
->attr
.external
)
1821 /* If a procedure is not already determined to be something else
1822 check if it is intrinsic. */
1823 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1824 sym
->attr
.intrinsic
= 1;
1826 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1828 gfc_error ("Statement function %qs at %L is not allowed as an "
1829 "actual argument", sym
->name
, &e
->where
);
1832 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1833 sym
->attr
.subroutine
);
1834 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1836 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1837 "actual argument", sym
->name
, &e
->where
);
1840 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1841 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1843 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1844 " used as actual argument at %L",
1845 sym
->name
, &e
->where
))
1849 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1851 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1852 "allowed as an actual argument at %L", sym
->name
,
1856 /* Check if a generic interface has a specific procedure
1857 with the same name before emitting an error. */
1858 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1861 /* Just in case a specific was found for the expression. */
1862 sym
= e
->symtree
->n
.sym
;
1864 /* If the symbol is the function that names the current (or
1865 parent) scope, then we really have a variable reference. */
1867 if (gfc_is_function_return_value (sym
, sym
->ns
))
1870 /* If all else fails, see if we have a specific intrinsic. */
1871 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1873 gfc_intrinsic_sym
*isym
;
1875 isym
= gfc_find_function (sym
->name
);
1876 if (isym
== NULL
|| !isym
->specific
)
1878 gfc_error ("Unable to find a specific INTRINSIC procedure "
1879 "for the reference %qs at %L", sym
->name
,
1884 sym
->attr
.intrinsic
= 1;
1885 sym
->attr
.function
= 1;
1888 if (!gfc_resolve_expr (e
))
1893 /* See if the name is a module procedure in a parent unit. */
1895 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1898 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1900 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1904 if (parent_st
== NULL
)
1907 sym
= parent_st
->n
.sym
;
1908 e
->symtree
= parent_st
; /* Point to the right thing. */
1910 if (sym
->attr
.flavor
== FL_PROCEDURE
1911 || sym
->attr
.intrinsic
1912 || sym
->attr
.external
)
1914 if (!gfc_resolve_expr (e
))
1920 e
->expr_type
= EXPR_VARIABLE
;
1922 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1923 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1924 && CLASS_DATA (sym
)->as
))
1926 e
->rank
= sym
->ts
.type
== BT_CLASS
1927 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1928 e
->ref
= gfc_get_ref ();
1929 e
->ref
->type
= REF_ARRAY
;
1930 e
->ref
->u
.ar
.type
= AR_FULL
;
1931 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1932 ? CLASS_DATA (sym
)->as
: sym
->as
;
1935 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1936 primary.c (match_actual_arg). If above code determines that it
1937 is a variable instead, it needs to be resolved as it was not
1938 done at the beginning of this function. */
1939 save_need_full_assumed_size
= need_full_assumed_size
;
1940 if (e
->expr_type
!= EXPR_VARIABLE
)
1941 need_full_assumed_size
= 0;
1942 if (!gfc_resolve_expr (e
))
1944 need_full_assumed_size
= save_need_full_assumed_size
;
1947 /* Check argument list functions %VAL, %LOC and %REF. There is
1948 nothing to do for %REF. */
1949 if (arg
->name
&& arg
->name
[0] == '%')
1951 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1953 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1955 gfc_error ("By-value argument at %L is not of numeric "
1962 gfc_error ("By-value argument at %L cannot be an array or "
1963 "an array section", &e
->where
);
1967 /* Intrinsics are still PROC_UNKNOWN here. However,
1968 since same file external procedures are not resolvable
1969 in gfortran, it is a good deal easier to leave them to
1971 if (ptype
!= PROC_UNKNOWN
1972 && ptype
!= PROC_DUMMY
1973 && ptype
!= PROC_EXTERNAL
1974 && ptype
!= PROC_MODULE
)
1976 gfc_error ("By-value argument at %L is not allowed "
1977 "in this context", &e
->where
);
1982 /* Statement functions have already been excluded above. */
1983 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1984 && e
->ts
.type
== BT_PROCEDURE
)
1986 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1988 gfc_error ("Passing internal procedure at %L by location "
1989 "not allowed", &e
->where
);
1995 comp
= gfc_get_proc_ptr_comp(e
);
1996 if (e
->expr_type
== EXPR_VARIABLE
1997 && comp
&& comp
->attr
.elemental
)
1999 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2000 "allowed as an actual argument at %L", comp
->name
,
2004 /* Fortran 2008, C1237. */
2005 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2006 && gfc_has_ultimate_pointer (e
))
2008 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2009 "component", &e
->where
);
2013 first_actual_arg
= false;
2016 return_value
= true;
2019 actual_arg
= actual_arg_sav
;
2020 first_actual_arg
= first_actual_arg_sav
;
2022 return return_value
;
2026 /* Do the checks of the actual argument list that are specific to elemental
2027 procedures. If called with c == NULL, we have a function, otherwise if
2028 expr == NULL, we have a subroutine. */
2031 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2033 gfc_actual_arglist
*arg0
;
2034 gfc_actual_arglist
*arg
;
2035 gfc_symbol
*esym
= NULL
;
2036 gfc_intrinsic_sym
*isym
= NULL
;
2038 gfc_intrinsic_arg
*iformal
= NULL
;
2039 gfc_formal_arglist
*eformal
= NULL
;
2040 bool formal_optional
= false;
2041 bool set_by_optional
= false;
2045 /* Is this an elemental procedure? */
2046 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2048 if (expr
->value
.function
.esym
!= NULL
2049 && expr
->value
.function
.esym
->attr
.elemental
)
2051 arg0
= expr
->value
.function
.actual
;
2052 esym
= expr
->value
.function
.esym
;
2054 else if (expr
->value
.function
.isym
!= NULL
2055 && expr
->value
.function
.isym
->elemental
)
2057 arg0
= expr
->value
.function
.actual
;
2058 isym
= expr
->value
.function
.isym
;
2063 else if (c
&& c
->ext
.actual
!= NULL
)
2065 arg0
= c
->ext
.actual
;
2067 if (c
->resolved_sym
)
2068 esym
= c
->resolved_sym
;
2070 esym
= c
->symtree
->n
.sym
;
2073 if (!esym
->attr
.elemental
)
2079 /* The rank of an elemental is the rank of its array argument(s). */
2080 for (arg
= arg0
; arg
; arg
= arg
->next
)
2082 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2084 rank
= arg
->expr
->rank
;
2085 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2086 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2087 set_by_optional
= true;
2089 /* Function specific; set the result rank and shape. */
2093 if (!expr
->shape
&& arg
->expr
->shape
)
2095 expr
->shape
= gfc_get_shape (rank
);
2096 for (i
= 0; i
< rank
; i
++)
2097 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2104 /* If it is an array, it shall not be supplied as an actual argument
2105 to an elemental procedure unless an array of the same rank is supplied
2106 as an actual argument corresponding to a nonoptional dummy argument of
2107 that elemental procedure(12.4.1.5). */
2108 formal_optional
= false;
2110 iformal
= isym
->formal
;
2112 eformal
= esym
->formal
;
2114 for (arg
= arg0
; arg
; arg
= arg
->next
)
2118 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2119 formal_optional
= true;
2120 eformal
= eformal
->next
;
2122 else if (isym
&& iformal
)
2124 if (iformal
->optional
)
2125 formal_optional
= true;
2126 iformal
= iformal
->next
;
2129 formal_optional
= true;
2131 if (pedantic
&& arg
->expr
!= NULL
2132 && arg
->expr
->expr_type
== EXPR_VARIABLE
2133 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2136 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2137 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2139 gfc_warning (OPT_Wpedantic
,
2140 "%qs at %L is an array and OPTIONAL; IF IT IS "
2141 "MISSING, it cannot be the actual argument of an "
2142 "ELEMENTAL procedure unless there is a non-optional "
2143 "argument with the same rank (12.4.1.5)",
2144 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2148 for (arg
= arg0
; arg
; arg
= arg
->next
)
2150 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2153 /* Being elemental, the last upper bound of an assumed size array
2154 argument must be present. */
2155 if (resolve_assumed_size_actual (arg
->expr
))
2158 /* Elemental procedure's array actual arguments must conform. */
2161 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2168 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2169 is an array, the intent inout/out variable needs to be also an array. */
2170 if (rank
> 0 && esym
&& expr
== NULL
)
2171 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2172 arg
= arg
->next
, eformal
= eformal
->next
)
2173 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2174 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2175 && arg
->expr
&& arg
->expr
->rank
== 0)
2177 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2178 "ELEMENTAL subroutine %qs is a scalar, but another "
2179 "actual argument is an array", &arg
->expr
->where
,
2180 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2181 : "INOUT", eformal
->sym
->name
, esym
->name
);
2188 /* This function does the checking of references to global procedures
2189 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2190 77 and 95 standards. It checks for a gsymbol for the name, making
2191 one if it does not already exist. If it already exists, then the
2192 reference being resolved must correspond to the type of gsymbol.
2193 Otherwise, the new symbol is equipped with the attributes of the
2194 reference. The corresponding code that is called in creating
2195 global entities is parse.c.
2197 In addition, for all but -std=legacy, the gsymbols are used to
2198 check the interfaces of external procedures from the same file.
2199 The namespace of the gsymbol is resolved and then, once this is
2200 done the interface is checked. */
2204 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2206 if (!gsym_ns
->proc_name
->attr
.recursive
)
2209 if (sym
->ns
== gsym_ns
)
2212 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2219 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2221 if (gsym_ns
->entries
)
2223 gfc_entry_list
*entry
= gsym_ns
->entries
;
2225 for (; entry
; entry
= entry
->next
)
2227 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2229 if (strcmp (gsym_ns
->proc_name
->name
,
2230 sym
->ns
->proc_name
->name
) == 0)
2234 && strcmp (gsym_ns
->proc_name
->name
,
2235 sym
->ns
->parent
->proc_name
->name
) == 0)
2244 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2247 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2249 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2251 for ( ; arg
; arg
= arg
->next
)
2256 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2258 strncpy (errmsg
, _("allocatable argument"), err_len
);
2261 else if (arg
->sym
->attr
.asynchronous
)
2263 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2266 else if (arg
->sym
->attr
.optional
)
2268 strncpy (errmsg
, _("optional argument"), err_len
);
2271 else if (arg
->sym
->attr
.pointer
)
2273 strncpy (errmsg
, _("pointer argument"), err_len
);
2276 else if (arg
->sym
->attr
.target
)
2278 strncpy (errmsg
, _("target argument"), err_len
);
2281 else if (arg
->sym
->attr
.value
)
2283 strncpy (errmsg
, _("value argument"), err_len
);
2286 else if (arg
->sym
->attr
.volatile_
)
2288 strncpy (errmsg
, _("volatile argument"), err_len
);
2291 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2293 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2296 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2298 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2301 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2303 strncpy (errmsg
, _("coarray argument"), err_len
);
2306 else if (false) /* (2d) TODO: parametrized derived type */
2308 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2311 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2313 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2316 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2318 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2321 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2323 /* As assumed-type is unlimited polymorphic (cf. above).
2324 See also TS 29113, Note 6.1. */
2325 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2330 if (sym
->attr
.function
)
2332 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2334 if (res
->attr
.dimension
) /* (3a) */
2336 strncpy (errmsg
, _("array result"), err_len
);
2339 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2341 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2344 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2345 && res
->ts
.u
.cl
->length
2346 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2348 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2353 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2355 strncpy (errmsg
, _("elemental procedure"), err_len
);
2358 else if (sym
->attr
.is_bind_c
) /* (5) */
2360 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2369 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2370 gfc_actual_arglist
**actual
, int sub
)
2374 enum gfc_symbol_type type
;
2377 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2379 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2381 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2382 gfc_global_used (gsym
, where
);
2384 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2385 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2386 && gsym
->type
!= GSYM_UNKNOWN
2387 && !gsym
->binding_label
2389 && gsym
->ns
->resolved
!= -1
2390 && gsym
->ns
->proc_name
2391 && not_in_recursive (sym
, gsym
->ns
)
2392 && not_entry_self_reference (sym
, gsym
->ns
))
2394 gfc_symbol
*def_sym
;
2396 /* Resolve the gsymbol namespace if needed. */
2397 if (!gsym
->ns
->resolved
)
2399 gfc_dt_list
*old_dt_list
;
2401 /* Stash away derived types so that the backend_decls do not
2403 old_dt_list
= gfc_derived_types
;
2404 gfc_derived_types
= NULL
;
2406 gfc_resolve (gsym
->ns
);
2408 /* Store the new derived types with the global namespace. */
2409 if (gfc_derived_types
)
2410 gsym
->ns
->derived_types
= gfc_derived_types
;
2412 /* Restore the derived types of this namespace. */
2413 gfc_derived_types
= old_dt_list
;
2416 /* Make sure that translation for the gsymbol occurs before
2417 the procedure currently being resolved. */
2418 ns
= gfc_global_ns_list
;
2419 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2421 if (ns
->sibling
== gsym
->ns
)
2423 ns
->sibling
= gsym
->ns
->sibling
;
2424 gsym
->ns
->sibling
= gfc_global_ns_list
;
2425 gfc_global_ns_list
= gsym
->ns
;
2430 def_sym
= gsym
->ns
->proc_name
;
2432 /* This can happen if a binding name has been specified. */
2433 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2434 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2436 if (def_sym
->attr
.entry_master
)
2438 gfc_entry_list
*entry
;
2439 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2440 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2442 def_sym
= entry
->sym
;
2447 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2449 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2450 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2451 gfc_typename (&def_sym
->ts
));
2455 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2456 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2458 gfc_error ("Explicit interface required for %qs at %L: %s",
2459 sym
->name
, &sym
->declared_at
, reason
);
2463 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2464 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2465 gfc_errors_to_warnings (true);
2467 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2468 reason
, sizeof(reason
), NULL
, NULL
))
2470 gfc_error_opt (OPT_Wargument_mismatch
,
2471 "Interface mismatch in global procedure %qs at %L:"
2472 " %s", sym
->name
, &sym
->declared_at
, reason
);
2477 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2478 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2479 gfc_errors_to_warnings (true);
2481 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2482 gfc_procedure_use (def_sym
, actual
, where
);
2486 gfc_errors_to_warnings (false);
2488 if (gsym
->type
== GSYM_UNKNOWN
)
2491 gsym
->where
= *where
;
2498 /************* Function resolution *************/
2500 /* Resolve a function call known to be generic.
2501 Section 14.1.2.4.1. */
2504 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2508 if (sym
->attr
.generic
)
2510 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2513 expr
->value
.function
.name
= s
->name
;
2514 expr
->value
.function
.esym
= s
;
2516 if (s
->ts
.type
!= BT_UNKNOWN
)
2518 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2519 expr
->ts
= s
->result
->ts
;
2522 expr
->rank
= s
->as
->rank
;
2523 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2524 expr
->rank
= s
->result
->as
->rank
;
2526 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2531 /* TODO: Need to search for elemental references in generic
2535 if (sym
->attr
.intrinsic
)
2536 return gfc_intrinsic_func_interface (expr
, 0);
2543 resolve_generic_f (gfc_expr
*expr
)
2547 gfc_interface
*intr
= NULL
;
2549 sym
= expr
->symtree
->n
.sym
;
2553 m
= resolve_generic_f0 (expr
, sym
);
2556 else if (m
== MATCH_ERROR
)
2561 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2562 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2565 if (sym
->ns
->parent
== NULL
)
2567 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2571 if (!generic_sym (sym
))
2575 /* Last ditch attempt. See if the reference is to an intrinsic
2576 that possesses a matching interface. 14.1.2.4 */
2577 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2579 if (gfc_init_expr_flag
)
2580 gfc_error ("Function %qs in initialization expression at %L "
2581 "must be an intrinsic function",
2582 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2584 gfc_error ("There is no specific function for the generic %qs "
2585 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2591 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2594 return resolve_structure_cons (expr
, 0);
2597 m
= gfc_intrinsic_func_interface (expr
, 0);
2602 gfc_error ("Generic function %qs at %L is not consistent with a "
2603 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2610 /* Resolve a function call known to be specific. */
2613 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2617 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2619 if (sym
->attr
.dummy
)
2621 sym
->attr
.proc
= PROC_DUMMY
;
2625 sym
->attr
.proc
= PROC_EXTERNAL
;
2629 if (sym
->attr
.proc
== PROC_MODULE
2630 || sym
->attr
.proc
== PROC_ST_FUNCTION
2631 || sym
->attr
.proc
== PROC_INTERNAL
)
2634 if (sym
->attr
.intrinsic
)
2636 m
= gfc_intrinsic_func_interface (expr
, 1);
2640 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2641 "with an intrinsic", sym
->name
, &expr
->where
);
2649 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2652 expr
->ts
= sym
->result
->ts
;
2655 expr
->value
.function
.name
= sym
->name
;
2656 expr
->value
.function
.esym
= sym
;
2657 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2659 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2661 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2662 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2663 else if (sym
->as
!= NULL
)
2664 expr
->rank
= sym
->as
->rank
;
2671 resolve_specific_f (gfc_expr
*expr
)
2676 sym
= expr
->symtree
->n
.sym
;
2680 m
= resolve_specific_f0 (sym
, expr
);
2683 if (m
== MATCH_ERROR
)
2686 if (sym
->ns
->parent
== NULL
)
2689 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2695 gfc_error ("Unable to resolve the specific function %qs at %L",
2696 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2702 /* Resolve a procedure call not known to be generic nor specific. */
2705 resolve_unknown_f (gfc_expr
*expr
)
2710 sym
= expr
->symtree
->n
.sym
;
2712 if (sym
->attr
.dummy
)
2714 sym
->attr
.proc
= PROC_DUMMY
;
2715 expr
->value
.function
.name
= sym
->name
;
2719 /* See if we have an intrinsic function reference. */
2721 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2723 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2728 /* The reference is to an external name. */
2730 sym
->attr
.proc
= PROC_EXTERNAL
;
2731 expr
->value
.function
.name
= sym
->name
;
2732 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2734 if (sym
->as
!= NULL
)
2735 expr
->rank
= sym
->as
->rank
;
2737 /* Type of the expression is either the type of the symbol or the
2738 default type of the symbol. */
2741 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2743 if (sym
->ts
.type
!= BT_UNKNOWN
)
2747 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2749 if (ts
->type
== BT_UNKNOWN
)
2751 gfc_error ("Function %qs at %L has no IMPLICIT type",
2752 sym
->name
, &expr
->where
);
2763 /* Return true, if the symbol is an external procedure. */
2765 is_external_proc (gfc_symbol
*sym
)
2767 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2768 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2769 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2770 && !sym
->attr
.proc_pointer
2771 && !sym
->attr
.use_assoc
2779 /* Figure out if a function reference is pure or not. Also set the name
2780 of the function for a potential error message. Return nonzero if the
2781 function is PURE, zero if not. */
2783 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2786 pure_function (gfc_expr
*e
, const char **name
)
2789 gfc_component
*comp
;
2793 if (e
->symtree
!= NULL
2794 && e
->symtree
->n
.sym
!= NULL
2795 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2796 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2798 comp
= gfc_get_proc_ptr_comp (e
);
2801 pure
= gfc_pure (comp
->ts
.interface
);
2804 else if (e
->value
.function
.esym
)
2806 pure
= gfc_pure (e
->value
.function
.esym
);
2807 *name
= e
->value
.function
.esym
->name
;
2809 else if (e
->value
.function
.isym
)
2811 pure
= e
->value
.function
.isym
->pure
2812 || e
->value
.function
.isym
->elemental
;
2813 *name
= e
->value
.function
.isym
->name
;
2817 /* Implicit functions are not pure. */
2819 *name
= e
->value
.function
.name
;
2827 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2828 int *f ATTRIBUTE_UNUSED
)
2832 /* Don't bother recursing into other statement functions
2833 since they will be checked individually for purity. */
2834 if (e
->expr_type
!= EXPR_FUNCTION
2836 || e
->symtree
->n
.sym
== sym
2837 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2840 return pure_function (e
, &name
) ? false : true;
2845 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2847 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2851 /* Check if an impure function is allowed in the current context. */
2853 static bool check_pure_function (gfc_expr
*e
)
2855 const char *name
= NULL
;
2856 if (!pure_function (e
, &name
) && name
)
2860 gfc_error ("Reference to impure function %qs at %L inside a "
2861 "FORALL %s", name
, &e
->where
,
2862 forall_flag
== 2 ? "mask" : "block");
2865 else if (gfc_do_concurrent_flag
)
2867 gfc_error ("Reference to impure function %qs at %L inside a "
2868 "DO CONCURRENT %s", name
, &e
->where
,
2869 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2872 else if (gfc_pure (NULL
))
2874 gfc_error ("Reference to impure function %qs at %L "
2875 "within a PURE procedure", name
, &e
->where
);
2878 gfc_unset_implicit_pure (NULL
);
2884 /* Update current procedure's array_outer_dependency flag, considering
2885 a call to procedure SYM. */
2888 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2890 /* Check to see if this is a sibling function that has not yet
2892 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2893 for (; sibling
; sibling
= sibling
->sibling
)
2895 if (sibling
->proc_name
== sym
)
2897 gfc_resolve (sibling
);
2902 /* If SYM has references to outer arrays, so has the procedure calling
2903 SYM. If SYM is a procedure pointer, we can assume the worst. */
2904 if (sym
->attr
.array_outer_dependency
2905 || sym
->attr
.proc_pointer
)
2906 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2910 /* Resolve a function call, which means resolving the arguments, then figuring
2911 out which entity the name refers to. */
2914 resolve_function (gfc_expr
*expr
)
2916 gfc_actual_arglist
*arg
;
2920 procedure_type p
= PROC_INTRINSIC
;
2921 bool no_formal_args
;
2925 sym
= expr
->symtree
->n
.sym
;
2927 /* If this is a procedure pointer component, it has already been resolved. */
2928 if (gfc_is_proc_ptr_comp (expr
))
2931 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
2933 if (sym
&& sym
->attr
.intrinsic
2934 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
2935 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
2938 if (sym
&& sym
->attr
.intrinsic
2939 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2942 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2944 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2948 /* If this ia a deferred TBP with an abstract interface (which may
2949 of course be referenced), expr->value.function.esym will be set. */
2950 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2952 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2953 sym
->name
, &expr
->where
);
2957 /* Switch off assumed size checking and do this again for certain kinds
2958 of procedure, once the procedure itself is resolved. */
2959 need_full_assumed_size
++;
2961 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2962 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2964 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2965 inquiry_argument
= true;
2966 no_formal_args
= sym
&& is_external_proc (sym
)
2967 && gfc_sym_get_dummy_args (sym
) == NULL
;
2969 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2972 inquiry_argument
= false;
2976 inquiry_argument
= false;
2978 /* Resume assumed_size checking. */
2979 need_full_assumed_size
--;
2981 /* If the procedure is external, check for usage. */
2982 if (sym
&& is_external_proc (sym
))
2983 resolve_global_procedure (sym
, &expr
->where
,
2984 &expr
->value
.function
.actual
, 0);
2986 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2988 && sym
->ts
.u
.cl
->length
== NULL
2990 && !sym
->ts
.deferred
2991 && expr
->value
.function
.esym
== NULL
2992 && !sym
->attr
.contained
)
2994 /* Internal procedures are taken care of in resolve_contained_fntype. */
2995 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2996 "be used at %L since it is not a dummy argument",
2997 sym
->name
, &expr
->where
);
3001 /* See if function is already resolved. */
3003 if (expr
->value
.function
.name
!= NULL
3004 || expr
->value
.function
.isym
!= NULL
)
3006 if (expr
->ts
.type
== BT_UNKNOWN
)
3012 /* Apply the rules of section 14.1.2. */
3014 switch (procedure_kind (sym
))
3017 t
= resolve_generic_f (expr
);
3020 case PTYPE_SPECIFIC
:
3021 t
= resolve_specific_f (expr
);
3025 t
= resolve_unknown_f (expr
);
3029 gfc_internal_error ("resolve_function(): bad function type");
3033 /* If the expression is still a function (it might have simplified),
3034 then we check to see if we are calling an elemental function. */
3036 if (expr
->expr_type
!= EXPR_FUNCTION
)
3039 temp
= need_full_assumed_size
;
3040 need_full_assumed_size
= 0;
3042 if (!resolve_elemental_actual (expr
, NULL
))
3045 if (omp_workshare_flag
3046 && expr
->value
.function
.esym
3047 && ! gfc_elemental (expr
->value
.function
.esym
))
3049 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3050 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3055 #define GENERIC_ID expr->value.function.isym->id
3056 else if (expr
->value
.function
.actual
!= NULL
3057 && expr
->value
.function
.isym
!= NULL
3058 && GENERIC_ID
!= GFC_ISYM_LBOUND
3059 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3060 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3061 && GENERIC_ID
!= GFC_ISYM_LEN
3062 && GENERIC_ID
!= GFC_ISYM_LOC
3063 && GENERIC_ID
!= GFC_ISYM_C_LOC
3064 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3066 /* Array intrinsics must also have the last upper bound of an
3067 assumed size array argument. UBOUND and SIZE have to be
3068 excluded from the check if the second argument is anything
3071 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3073 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3074 && arg
== expr
->value
.function
.actual
3075 && arg
->next
!= NULL
&& arg
->next
->expr
)
3077 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3080 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3083 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3088 if (arg
->expr
!= NULL
3089 && arg
->expr
->rank
> 0
3090 && resolve_assumed_size_actual (arg
->expr
))
3096 need_full_assumed_size
= temp
;
3098 if (!check_pure_function(expr
))
3101 /* Functions without the RECURSIVE attribution are not allowed to
3102 * call themselves. */
3103 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3106 esym
= expr
->value
.function
.esym
;
3108 if (is_illegal_recursion (esym
, gfc_current_ns
))
3110 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3111 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3112 " function %qs is not RECURSIVE",
3113 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3115 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3116 " is not RECURSIVE", esym
->name
, &expr
->where
);
3122 /* Character lengths of use associated functions may contains references to
3123 symbols not referenced from the current program unit otherwise. Make sure
3124 those symbols are marked as referenced. */
3126 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3127 && expr
->value
.function
.esym
->attr
.use_assoc
)
3129 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3132 /* Make sure that the expression has a typespec that works. */
3133 if (expr
->ts
.type
== BT_UNKNOWN
)
3135 if (expr
->symtree
->n
.sym
->result
3136 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3137 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3138 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3141 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3143 if (expr
->value
.function
.esym
)
3144 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3146 update_current_proc_array_outer_dependency (sym
);
3149 /* typebound procedure: Assume the worst. */
3150 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3156 /************* Subroutine resolution *************/
3159 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3166 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3170 else if (gfc_do_concurrent_flag
)
3172 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3176 else if (gfc_pure (NULL
))
3178 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3182 gfc_unset_implicit_pure (NULL
);
3188 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3192 if (sym
->attr
.generic
)
3194 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3197 c
->resolved_sym
= s
;
3198 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3203 /* TODO: Need to search for elemental references in generic interface. */
3206 if (sym
->attr
.intrinsic
)
3207 return gfc_intrinsic_sub_interface (c
, 0);
3214 resolve_generic_s (gfc_code
*c
)
3219 sym
= c
->symtree
->n
.sym
;
3223 m
= resolve_generic_s0 (c
, sym
);
3226 else if (m
== MATCH_ERROR
)
3230 if (sym
->ns
->parent
== NULL
)
3232 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3236 if (!generic_sym (sym
))
3240 /* Last ditch attempt. See if the reference is to an intrinsic
3241 that possesses a matching interface. 14.1.2.4 */
3242 sym
= c
->symtree
->n
.sym
;
3244 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3246 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3247 sym
->name
, &c
->loc
);
3251 m
= gfc_intrinsic_sub_interface (c
, 0);
3255 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3256 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3262 /* Resolve a subroutine call known to be specific. */
3265 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3269 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3271 if (sym
->attr
.dummy
)
3273 sym
->attr
.proc
= PROC_DUMMY
;
3277 sym
->attr
.proc
= PROC_EXTERNAL
;
3281 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3284 if (sym
->attr
.intrinsic
)
3286 m
= gfc_intrinsic_sub_interface (c
, 1);
3290 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3291 "with an intrinsic", sym
->name
, &c
->loc
);
3299 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3301 c
->resolved_sym
= sym
;
3302 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3310 resolve_specific_s (gfc_code
*c
)
3315 sym
= c
->symtree
->n
.sym
;
3319 m
= resolve_specific_s0 (c
, sym
);
3322 if (m
== MATCH_ERROR
)
3325 if (sym
->ns
->parent
== NULL
)
3328 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3334 sym
= c
->symtree
->n
.sym
;
3335 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3336 sym
->name
, &c
->loc
);
3342 /* Resolve a subroutine call not known to be generic nor specific. */
3345 resolve_unknown_s (gfc_code
*c
)
3349 sym
= c
->symtree
->n
.sym
;
3351 if (sym
->attr
.dummy
)
3353 sym
->attr
.proc
= PROC_DUMMY
;
3357 /* See if we have an intrinsic function reference. */
3359 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3361 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3366 /* The reference is to an external name. */
3369 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3371 c
->resolved_sym
= sym
;
3373 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3377 /* Resolve a subroutine call. Although it was tempting to use the same code
3378 for functions, subroutines and functions are stored differently and this
3379 makes things awkward. */
3382 resolve_call (gfc_code
*c
)
3385 procedure_type ptype
= PROC_INTRINSIC
;
3386 gfc_symbol
*csym
, *sym
;
3387 bool no_formal_args
;
3389 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3391 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3393 gfc_error ("%qs at %L has a type, which is not consistent with "
3394 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3398 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3401 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3402 sym
= st
? st
->n
.sym
: NULL
;
3403 if (sym
&& csym
!= sym
3404 && sym
->ns
== gfc_current_ns
3405 && sym
->attr
.flavor
== FL_PROCEDURE
3406 && sym
->attr
.contained
)
3409 if (csym
->attr
.generic
)
3410 c
->symtree
->n
.sym
= sym
;
3413 csym
= c
->symtree
->n
.sym
;
3417 /* If this ia a deferred TBP, c->expr1 will be set. */
3418 if (!c
->expr1
&& csym
)
3420 if (csym
->attr
.abstract
)
3422 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3423 csym
->name
, &c
->loc
);
3427 /* Subroutines without the RECURSIVE attribution are not allowed to
3429 if (is_illegal_recursion (csym
, gfc_current_ns
))
3431 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3432 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3433 "as subroutine %qs is not RECURSIVE",
3434 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3436 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3437 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3443 /* Switch off assumed size checking and do this again for certain kinds
3444 of procedure, once the procedure itself is resolved. */
3445 need_full_assumed_size
++;
3448 ptype
= csym
->attr
.proc
;
3450 no_formal_args
= csym
&& is_external_proc (csym
)
3451 && gfc_sym_get_dummy_args (csym
) == NULL
;
3452 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3455 /* Resume assumed_size checking. */
3456 need_full_assumed_size
--;
3458 /* If external, check for usage. */
3459 if (csym
&& is_external_proc (csym
))
3460 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3463 if (c
->resolved_sym
== NULL
)
3465 c
->resolved_isym
= NULL
;
3466 switch (procedure_kind (csym
))
3469 t
= resolve_generic_s (c
);
3472 case PTYPE_SPECIFIC
:
3473 t
= resolve_specific_s (c
);
3477 t
= resolve_unknown_s (c
);
3481 gfc_internal_error ("resolve_subroutine(): bad function type");
3485 /* Some checks of elemental subroutine actual arguments. */
3486 if (!resolve_elemental_actual (NULL
, c
))
3490 update_current_proc_array_outer_dependency (csym
);
3492 /* Typebound procedure: Assume the worst. */
3493 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3499 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3500 op1->shape and op2->shape are non-NULL return true if their shapes
3501 match. If both op1->shape and op2->shape are non-NULL return false
3502 if their shapes do not match. If either op1->shape or op2->shape is
3503 NULL, return true. */
3506 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3513 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3515 for (i
= 0; i
< op1
->rank
; i
++)
3517 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3519 gfc_error ("Shapes for operands at %L and %L are not conformable",
3520 &op1
->where
, &op2
->where
);
3530 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3531 For example A .AND. B becomes IAND(A, B). */
3533 logical_to_bitwise (gfc_expr
*e
)
3535 gfc_expr
*tmp
, *op1
, *op2
;
3537 gfc_actual_arglist
*args
= NULL
;
3539 gcc_assert (e
->expr_type
== EXPR_OP
);
3541 isym
= GFC_ISYM_NONE
;
3542 op1
= e
->value
.op
.op1
;
3543 op2
= e
->value
.op
.op2
;
3545 switch (e
->value
.op
.op
)
3548 isym
= GFC_ISYM_NOT
;
3551 isym
= GFC_ISYM_IAND
;
3554 isym
= GFC_ISYM_IOR
;
3556 case INTRINSIC_NEQV
:
3557 isym
= GFC_ISYM_IEOR
;
3560 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3561 Change the old expression to NEQV, which will get replaced by IEOR,
3562 and wrap it in NOT. */
3563 tmp
= gfc_copy_expr (e
);
3564 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3565 tmp
= logical_to_bitwise (tmp
);
3566 isym
= GFC_ISYM_NOT
;
3571 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3574 /* Inherit the original operation's operands as arguments. */
3575 args
= gfc_get_actual_arglist ();
3579 args
->next
= gfc_get_actual_arglist ();
3580 args
->next
->expr
= op2
;
3583 /* Convert the expression to a function call. */
3584 e
->expr_type
= EXPR_FUNCTION
;
3585 e
->value
.function
.actual
= args
;
3586 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3587 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3588 e
->value
.function
.esym
= NULL
;
3590 /* Make up a pre-resolved function call symtree if we need to. */
3591 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3594 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3595 sym
= e
->symtree
->n
.sym
;
3597 sym
->attr
.flavor
= FL_PROCEDURE
;
3598 sym
->attr
.function
= 1;
3599 sym
->attr
.elemental
= 1;
3601 sym
->attr
.referenced
= 1;
3602 gfc_intrinsic_symbol (sym
);
3603 gfc_commit_symbol (sym
);
3606 args
->name
= e
->value
.function
.isym
->formal
->name
;
3607 if (e
->value
.function
.isym
->formal
->next
)
3608 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3613 /* Resolve an operator expression node. This can involve replacing the
3614 operation with a user defined function call. */
3617 resolve_operator (gfc_expr
*e
)
3619 gfc_expr
*op1
, *op2
;
3621 bool dual_locus_error
;
3624 /* Resolve all subnodes-- give them types. */
3626 switch (e
->value
.op
.op
)
3629 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3635 case INTRINSIC_UPLUS
:
3636 case INTRINSIC_UMINUS
:
3637 case INTRINSIC_PARENTHESES
:
3638 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3643 /* Typecheck the new node. */
3645 op1
= e
->value
.op
.op1
;
3646 op2
= e
->value
.op
.op2
;
3647 dual_locus_error
= false;
3649 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3650 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3652 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3656 switch (e
->value
.op
.op
)
3658 case INTRINSIC_UPLUS
:
3659 case INTRINSIC_UMINUS
:
3660 if (op1
->ts
.type
== BT_INTEGER
3661 || op1
->ts
.type
== BT_REAL
3662 || op1
->ts
.type
== BT_COMPLEX
)
3668 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3669 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3672 case INTRINSIC_PLUS
:
3673 case INTRINSIC_MINUS
:
3674 case INTRINSIC_TIMES
:
3675 case INTRINSIC_DIVIDE
:
3676 case INTRINSIC_POWER
:
3677 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3679 gfc_type_convert_binary (e
, 1);
3684 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3685 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3686 gfc_typename (&op2
->ts
));
3689 case INTRINSIC_CONCAT
:
3690 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3691 && op1
->ts
.kind
== op2
->ts
.kind
)
3693 e
->ts
.type
= BT_CHARACTER
;
3694 e
->ts
.kind
= op1
->ts
.kind
;
3699 _("Operands of string concatenation operator at %%L are %s/%s"),
3700 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3706 case INTRINSIC_NEQV
:
3707 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3709 e
->ts
.type
= BT_LOGICAL
;
3710 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3711 if (op1
->ts
.kind
< e
->ts
.kind
)
3712 gfc_convert_type (op1
, &e
->ts
, 2);
3713 else if (op2
->ts
.kind
< e
->ts
.kind
)
3714 gfc_convert_type (op2
, &e
->ts
, 2);
3718 /* Logical ops on integers become bitwise ops with -fdec. */
3720 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
3722 e
->ts
.type
= BT_INTEGER
;
3723 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3724 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
3725 gfc_convert_type (op1
, &e
->ts
, 1);
3726 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
3727 gfc_convert_type (op2
, &e
->ts
, 1);
3728 e
= logical_to_bitwise (e
);
3729 return resolve_function (e
);
3732 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3733 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3734 gfc_typename (&op2
->ts
));
3739 /* Logical ops on integers become bitwise ops with -fdec. */
3740 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
3742 e
->ts
.type
= BT_INTEGER
;
3743 e
->ts
.kind
= op1
->ts
.kind
;
3744 e
= logical_to_bitwise (e
);
3745 return resolve_function (e
);
3748 if (op1
->ts
.type
== BT_LOGICAL
)
3750 e
->ts
.type
= BT_LOGICAL
;
3751 e
->ts
.kind
= op1
->ts
.kind
;
3755 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3756 gfc_typename (&op1
->ts
));
3760 case INTRINSIC_GT_OS
:
3762 case INTRINSIC_GE_OS
:
3764 case INTRINSIC_LT_OS
:
3766 case INTRINSIC_LE_OS
:
3767 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3769 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3776 case INTRINSIC_EQ_OS
:
3778 case INTRINSIC_NE_OS
:
3779 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3780 && op1
->ts
.kind
== op2
->ts
.kind
)
3782 e
->ts
.type
= BT_LOGICAL
;
3783 e
->ts
.kind
= gfc_default_logical_kind
;
3787 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3789 gfc_type_convert_binary (e
, 1);
3791 e
->ts
.type
= BT_LOGICAL
;
3792 e
->ts
.kind
= gfc_default_logical_kind
;
3794 if (warn_compare_reals
)
3796 gfc_intrinsic_op op
= e
->value
.op
.op
;
3798 /* Type conversion has made sure that the types of op1 and op2
3799 agree, so it is only necessary to check the first one. */
3800 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3801 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3802 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3806 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3807 msg
= "Equality comparison for %s at %L";
3809 msg
= "Inequality comparison for %s at %L";
3811 gfc_warning (OPT_Wcompare_reals
, msg
,
3812 gfc_typename (&op1
->ts
), &op1
->where
);
3819 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3821 _("Logicals at %%L must be compared with %s instead of %s"),
3822 (e
->value
.op
.op
== INTRINSIC_EQ
3823 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3824 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3827 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
3828 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3829 gfc_typename (&op2
->ts
));
3833 case INTRINSIC_USER
:
3834 if (e
->value
.op
.uop
->op
== NULL
)
3835 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"),
3836 e
->value
.op
.uop
->name
);
3837 else if (op2
== NULL
)
3838 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
3839 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3842 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
3843 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3844 gfc_typename (&op2
->ts
));
3845 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3850 case INTRINSIC_PARENTHESES
:
3852 if (e
->ts
.type
== BT_CHARACTER
)
3853 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3857 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3860 /* Deal with arrayness of an operand through an operator. */
3864 switch (e
->value
.op
.op
)
3866 case INTRINSIC_PLUS
:
3867 case INTRINSIC_MINUS
:
3868 case INTRINSIC_TIMES
:
3869 case INTRINSIC_DIVIDE
:
3870 case INTRINSIC_POWER
:
3871 case INTRINSIC_CONCAT
:
3875 case INTRINSIC_NEQV
:
3877 case INTRINSIC_EQ_OS
:
3879 case INTRINSIC_NE_OS
:
3881 case INTRINSIC_GT_OS
:
3883 case INTRINSIC_GE_OS
:
3885 case INTRINSIC_LT_OS
:
3887 case INTRINSIC_LE_OS
:
3889 if (op1
->rank
== 0 && op2
->rank
== 0)
3892 if (op1
->rank
== 0 && op2
->rank
!= 0)
3894 e
->rank
= op2
->rank
;
3896 if (e
->shape
== NULL
)
3897 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3900 if (op1
->rank
!= 0 && op2
->rank
== 0)
3902 e
->rank
= op1
->rank
;
3904 if (e
->shape
== NULL
)
3905 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3908 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3910 if (op1
->rank
== op2
->rank
)
3912 e
->rank
= op1
->rank
;
3913 if (e
->shape
== NULL
)
3915 t
= compare_shapes (op1
, op2
);
3919 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3924 /* Allow higher level expressions to work. */
3927 /* Try user-defined operators, and otherwise throw an error. */
3928 dual_locus_error
= true;
3930 _("Inconsistent ranks for operator at %%L and %%L"));
3937 case INTRINSIC_PARENTHESES
:
3939 case INTRINSIC_UPLUS
:
3940 case INTRINSIC_UMINUS
:
3941 /* Simply copy arrayness attribute */
3942 e
->rank
= op1
->rank
;
3944 if (e
->shape
== NULL
)
3945 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3953 /* Attempt to simplify the expression. */
3956 t
= gfc_simplify_expr (e
, 0);
3957 /* Some calls do not succeed in simplification and return false
3958 even though there is no error; e.g. variable references to
3959 PARAMETER arrays. */
3960 if (!gfc_is_constant_expr (e
))
3968 match m
= gfc_extend_expr (e
);
3971 if (m
== MATCH_ERROR
)
3975 if (dual_locus_error
)
3976 gfc_error (msg
, &op1
->where
, &op2
->where
);
3978 gfc_error (msg
, &e
->where
);
3984 /************** Array resolution subroutines **************/
3987 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
3989 /* Compare two integer expressions. */
3991 static compare_result
3992 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3996 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3997 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4000 /* If either of the types isn't INTEGER, we must have
4001 raised an error earlier. */
4003 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4006 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4016 /* Compare an integer expression with an integer. */
4018 static compare_result
4019 compare_bound_int (gfc_expr
*a
, int b
)
4023 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4026 if (a
->ts
.type
!= BT_INTEGER
)
4027 gfc_internal_error ("compare_bound_int(): Bad expression");
4029 i
= mpz_cmp_si (a
->value
.integer
, b
);
4039 /* Compare an integer expression with a mpz_t. */
4041 static compare_result
4042 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4046 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4049 if (a
->ts
.type
!= BT_INTEGER
)
4050 gfc_internal_error ("compare_bound_int(): Bad expression");
4052 i
= mpz_cmp (a
->value
.integer
, b
);
4062 /* Compute the last value of a sequence given by a triplet.
4063 Return 0 if it wasn't able to compute the last value, or if the
4064 sequence if empty, and 1 otherwise. */
4067 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4068 gfc_expr
*stride
, mpz_t last
)
4072 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4073 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4074 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4077 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4078 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4081 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4083 if (compare_bound (start
, end
) == CMP_GT
)
4085 mpz_set (last
, end
->value
.integer
);
4089 if (compare_bound_int (stride
, 0) == CMP_GT
)
4091 /* Stride is positive */
4092 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4097 /* Stride is negative */
4098 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4103 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4104 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4105 mpz_sub (last
, end
->value
.integer
, rem
);
4112 /* Compare a single dimension of an array reference to the array
4116 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4120 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4122 gcc_assert (ar
->stride
[i
] == NULL
);
4123 /* This implies [*] as [*:] and [*:3] are not possible. */
4124 if (ar
->start
[i
] == NULL
)
4126 gcc_assert (ar
->end
[i
] == NULL
);
4131 /* Given start, end and stride values, calculate the minimum and
4132 maximum referenced indexes. */
4134 switch (ar
->dimen_type
[i
])
4137 case DIMEN_THIS_IMAGE
:
4142 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4145 gfc_warning (0, "Array reference at %L is out of bounds "
4146 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4147 mpz_get_si (ar
->start
[i
]->value
.integer
),
4148 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4150 gfc_warning (0, "Array reference at %L is out of bounds "
4151 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4152 mpz_get_si (ar
->start
[i
]->value
.integer
),
4153 mpz_get_si (as
->lower
[i
]->value
.integer
),
4157 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4160 gfc_warning (0, "Array reference at %L is out of bounds "
4161 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4162 mpz_get_si (ar
->start
[i
]->value
.integer
),
4163 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4165 gfc_warning (0, "Array reference at %L is out of bounds "
4166 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4167 mpz_get_si (ar
->start
[i
]->value
.integer
),
4168 mpz_get_si (as
->upper
[i
]->value
.integer
),
4177 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4178 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4180 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4182 /* Check for zero stride, which is not allowed. */
4183 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4185 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4189 /* if start == len || (stride > 0 && start < len)
4190 || (stride < 0 && start > len),
4191 then the array section contains at least one element. In this
4192 case, there is an out-of-bounds access if
4193 (start < lower || start > upper). */
4194 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4195 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4196 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4197 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4198 && comp_start_end
== CMP_GT
))
4200 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4202 gfc_warning (0, "Lower array reference at %L is out of bounds "
4203 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4204 mpz_get_si (AR_START
->value
.integer
),
4205 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4208 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4210 gfc_warning (0, "Lower array reference at %L is out of bounds "
4211 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4212 mpz_get_si (AR_START
->value
.integer
),
4213 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4218 /* If we can compute the highest index of the array section,
4219 then it also has to be between lower and upper. */
4220 mpz_init (last_value
);
4221 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4224 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4226 gfc_warning (0, "Upper array reference at %L is out of bounds "
4227 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4228 mpz_get_si (last_value
),
4229 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4230 mpz_clear (last_value
);
4233 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4235 gfc_warning (0, "Upper array reference at %L is out of bounds "
4236 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4237 mpz_get_si (last_value
),
4238 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4239 mpz_clear (last_value
);
4243 mpz_clear (last_value
);
4251 gfc_internal_error ("check_dimension(): Bad array reference");
4258 /* Compare an array reference with an array specification. */
4261 compare_spec_to_ref (gfc_array_ref
*ar
)
4268 /* TODO: Full array sections are only allowed as actual parameters. */
4269 if (as
->type
== AS_ASSUMED_SIZE
4270 && (/*ar->type == AR_FULL
4271 ||*/ (ar
->type
== AR_SECTION
4272 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4274 gfc_error ("Rightmost upper bound of assumed size array section "
4275 "not specified at %L", &ar
->where
);
4279 if (ar
->type
== AR_FULL
)
4282 if (as
->rank
!= ar
->dimen
)
4284 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4285 &ar
->where
, ar
->dimen
, as
->rank
);
4289 /* ar->codimen == 0 is a local array. */
4290 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4292 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4293 &ar
->where
, ar
->codimen
, as
->corank
);
4297 for (i
= 0; i
< as
->rank
; i
++)
4298 if (!check_dimension (i
, ar
, as
))
4301 /* Local access has no coarray spec. */
4302 if (ar
->codimen
!= 0)
4303 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4305 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4306 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4308 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4309 i
+ 1 - as
->rank
, &ar
->where
);
4312 if (!check_dimension (i
, ar
, as
))
4320 /* Resolve one part of an array index. */
4323 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4324 int force_index_integer_kind
)
4331 if (!gfc_resolve_expr (index
))
4334 if (check_scalar
&& index
->rank
!= 0)
4336 gfc_error ("Array index at %L must be scalar", &index
->where
);
4340 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4342 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4343 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4347 if (index
->ts
.type
== BT_REAL
)
4348 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4352 if ((index
->ts
.kind
!= gfc_index_integer_kind
4353 && force_index_integer_kind
)
4354 || index
->ts
.type
!= BT_INTEGER
)
4357 ts
.type
= BT_INTEGER
;
4358 ts
.kind
= gfc_index_integer_kind
;
4360 gfc_convert_type_warn (index
, &ts
, 2, 0);
4366 /* Resolve one part of an array index. */
4369 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4371 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4374 /* Resolve a dim argument to an intrinsic function. */
4377 gfc_resolve_dim_arg (gfc_expr
*dim
)
4382 if (!gfc_resolve_expr (dim
))
4387 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4392 if (dim
->ts
.type
!= BT_INTEGER
)
4394 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4398 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4403 ts
.type
= BT_INTEGER
;
4404 ts
.kind
= gfc_index_integer_kind
;
4406 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4412 /* Given an expression that contains array references, update those array
4413 references to point to the right array specifications. While this is
4414 filled in during matching, this information is difficult to save and load
4415 in a module, so we take care of it here.
4417 The idea here is that the original array reference comes from the
4418 base symbol. We traverse the list of reference structures, setting
4419 the stored reference to references. Component references can
4420 provide an additional array specification. */
4423 find_array_spec (gfc_expr
*e
)
4429 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4430 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4432 as
= e
->symtree
->n
.sym
->as
;
4434 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4439 gfc_internal_error ("find_array_spec(): Missing spec");
4446 c
= ref
->u
.c
.component
;
4447 if (c
->attr
.dimension
)
4450 gfc_internal_error ("find_array_spec(): unused as(1)");
4461 gfc_internal_error ("find_array_spec(): unused as(2)");
4465 /* Resolve an array reference. */
4468 resolve_array_ref (gfc_array_ref
*ar
)
4470 int i
, check_scalar
;
4473 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4475 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4477 /* Do not force gfc_index_integer_kind for the start. We can
4478 do fine with any integer kind. This avoids temporary arrays
4479 created for indexing with a vector. */
4480 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4482 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4484 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4489 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4493 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4497 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4498 if (e
->expr_type
== EXPR_VARIABLE
4499 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4500 ar
->start
[i
] = gfc_get_parentheses (e
);
4504 gfc_error ("Array index at %L is an array of rank %d",
4505 &ar
->c_where
[i
], e
->rank
);
4509 /* Fill in the upper bound, which may be lower than the
4510 specified one for something like a(2:10:5), which is
4511 identical to a(2:7:5). Only relevant for strides not equal
4512 to one. Don't try a division by zero. */
4513 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4514 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4515 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4516 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4520 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4522 if (ar
->end
[i
] == NULL
)
4525 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4527 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4529 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4530 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4532 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4543 if (ar
->type
== AR_FULL
)
4545 if (ar
->as
->rank
== 0)
4546 ar
->type
= AR_ELEMENT
;
4548 /* Make sure array is the same as array(:,:), this way
4549 we don't need to special case all the time. */
4550 ar
->dimen
= ar
->as
->rank
;
4551 for (i
= 0; i
< ar
->dimen
; i
++)
4553 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4555 gcc_assert (ar
->start
[i
] == NULL
);
4556 gcc_assert (ar
->end
[i
] == NULL
);
4557 gcc_assert (ar
->stride
[i
] == NULL
);
4561 /* If the reference type is unknown, figure out what kind it is. */
4563 if (ar
->type
== AR_UNKNOWN
)
4565 ar
->type
= AR_ELEMENT
;
4566 for (i
= 0; i
< ar
->dimen
; i
++)
4567 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4568 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4570 ar
->type
= AR_SECTION
;
4575 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4578 if (ar
->as
->corank
&& ar
->codimen
== 0)
4581 ar
->codimen
= ar
->as
->corank
;
4582 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4583 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4591 resolve_substring (gfc_ref
*ref
)
4593 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4595 if (ref
->u
.ss
.start
!= NULL
)
4597 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4600 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4602 gfc_error ("Substring start index at %L must be of type INTEGER",
4603 &ref
->u
.ss
.start
->where
);
4607 if (ref
->u
.ss
.start
->rank
!= 0)
4609 gfc_error ("Substring start index at %L must be scalar",
4610 &ref
->u
.ss
.start
->where
);
4614 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4615 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4616 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4618 gfc_error ("Substring start index at %L is less than one",
4619 &ref
->u
.ss
.start
->where
);
4624 if (ref
->u
.ss
.end
!= NULL
)
4626 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4629 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4631 gfc_error ("Substring end index at %L must be of type INTEGER",
4632 &ref
->u
.ss
.end
->where
);
4636 if (ref
->u
.ss
.end
->rank
!= 0)
4638 gfc_error ("Substring end index at %L must be scalar",
4639 &ref
->u
.ss
.end
->where
);
4643 if (ref
->u
.ss
.length
!= NULL
4644 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4645 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4646 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4648 gfc_error ("Substring end index at %L exceeds the string length",
4649 &ref
->u
.ss
.start
->where
);
4653 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4654 gfc_integer_kinds
[k
].huge
) == 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 is too large",
4659 &ref
->u
.ss
.end
->where
);
4668 /* This function supplies missing substring charlens. */
4671 gfc_resolve_substring_charlen (gfc_expr
*e
)
4674 gfc_expr
*start
, *end
;
4675 gfc_typespec
*ts
= NULL
;
4677 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4679 if (char_ref
->type
== REF_SUBSTRING
)
4681 if (char_ref
->type
== REF_COMPONENT
)
4682 ts
= &char_ref
->u
.c
.component
->ts
;
4688 gcc_assert (char_ref
->next
== NULL
);
4692 if (e
->ts
.u
.cl
->length
)
4693 gfc_free_expr (e
->ts
.u
.cl
->length
);
4694 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4698 e
->ts
.type
= BT_CHARACTER
;
4699 e
->ts
.kind
= gfc_default_character_kind
;
4702 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4704 if (char_ref
->u
.ss
.start
)
4705 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4707 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4709 if (char_ref
->u
.ss
.end
)
4710 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4711 else if (e
->expr_type
== EXPR_VARIABLE
)
4714 ts
= &e
->symtree
->n
.sym
->ts
;
4715 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4722 gfc_free_expr (start
);
4723 gfc_free_expr (end
);
4727 /* Length = (end - start + 1). */
4728 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4729 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4730 gfc_get_int_expr (gfc_default_integer_kind
,
4733 /* F2008, 6.4.1: Both the starting point and the ending point shall
4734 be within the range 1, 2, ..., n unless the starting point exceeds
4735 the ending point, in which case the substring has length zero. */
4737 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4738 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4740 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4741 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4743 /* Make sure that the length is simplified. */
4744 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4745 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4749 /* Resolve subtype references. */
4752 resolve_ref (gfc_expr
*expr
)
4754 int current_part_dimension
, n_components
, seen_part_dimension
;
4757 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4758 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4760 find_array_spec (expr
);
4764 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4768 if (!resolve_array_ref (&ref
->u
.ar
))
4776 if (!resolve_substring (ref
))
4781 /* Check constraints on part references. */
4783 current_part_dimension
= 0;
4784 seen_part_dimension
= 0;
4787 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4792 switch (ref
->u
.ar
.type
)
4795 /* Coarray scalar. */
4796 if (ref
->u
.ar
.as
->rank
== 0)
4798 current_part_dimension
= 0;
4803 current_part_dimension
= 1;
4807 current_part_dimension
= 0;
4811 gfc_internal_error ("resolve_ref(): Bad array reference");
4817 if (current_part_dimension
|| seen_part_dimension
)
4820 if (ref
->u
.c
.component
->attr
.pointer
4821 || ref
->u
.c
.component
->attr
.proc_pointer
4822 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4823 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4825 gfc_error ("Component to the right of a part reference "
4826 "with nonzero rank must not have the POINTER "
4827 "attribute at %L", &expr
->where
);
4830 else if (ref
->u
.c
.component
->attr
.allocatable
4831 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4832 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4835 gfc_error ("Component to the right of a part reference "
4836 "with nonzero rank must not have the ALLOCATABLE "
4837 "attribute at %L", &expr
->where
);
4849 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4850 || ref
->next
== NULL
)
4851 && current_part_dimension
4852 && seen_part_dimension
)
4854 gfc_error ("Two or more part references with nonzero rank must "
4855 "not be specified at %L", &expr
->where
);
4859 if (ref
->type
== REF_COMPONENT
)
4861 if (current_part_dimension
)
4862 seen_part_dimension
= 1;
4864 /* reset to make sure */
4865 current_part_dimension
= 0;
4873 /* Given an expression, determine its shape. This is easier than it sounds.
4874 Leaves the shape array NULL if it is not possible to determine the shape. */
4877 expression_shape (gfc_expr
*e
)
4879 mpz_t array
[GFC_MAX_DIMENSIONS
];
4882 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4885 for (i
= 0; i
< e
->rank
; i
++)
4886 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4889 e
->shape
= gfc_get_shape (e
->rank
);
4891 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4896 for (i
--; i
>= 0; i
--)
4897 mpz_clear (array
[i
]);
4901 /* Given a variable expression node, compute the rank of the expression by
4902 examining the base symbol and any reference structures it may have. */
4905 expression_rank (gfc_expr
*e
)
4910 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4911 could lead to serious confusion... */
4912 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4916 if (e
->expr_type
== EXPR_ARRAY
)
4918 /* Constructors can have a rank different from one via RESHAPE(). */
4920 if (e
->symtree
== NULL
)
4926 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4927 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4933 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4935 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4936 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4937 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4939 if (ref
->type
!= REF_ARRAY
)
4942 if (ref
->u
.ar
.type
== AR_FULL
)
4944 rank
= ref
->u
.ar
.as
->rank
;
4948 if (ref
->u
.ar
.type
== AR_SECTION
)
4950 /* Figure out the rank of the section. */
4952 gfc_internal_error ("expression_rank(): Two array specs");
4954 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4955 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4956 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4966 expression_shape (e
);
4971 add_caf_get_intrinsic (gfc_expr
*e
)
4973 gfc_expr
*wrapper
, *tmp_expr
;
4977 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4978 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4983 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4984 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4987 tmp_expr
= XCNEW (gfc_expr
);
4989 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4990 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4991 wrapper
->ts
= e
->ts
;
4992 wrapper
->rank
= e
->rank
;
4994 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5001 remove_caf_get_intrinsic (gfc_expr
*e
)
5003 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5004 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5005 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5006 e
->value
.function
.actual
->expr
= NULL
;
5007 gfc_free_actual_arglist (e
->value
.function
.actual
);
5008 gfc_free_shape (&e
->shape
, e
->rank
);
5014 /* Resolve a variable expression. */
5017 resolve_variable (gfc_expr
*e
)
5024 if (e
->symtree
== NULL
)
5026 sym
= e
->symtree
->n
.sym
;
5028 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5029 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5030 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5032 if (!actual_arg
|| inquiry_argument
)
5034 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5035 "be used as actual argument", sym
->name
, &e
->where
);
5039 /* TS 29113, 407b. */
5040 else if (e
->ts
.type
== BT_ASSUMED
)
5044 gfc_error ("Assumed-type variable %s at %L may only be used "
5045 "as actual argument", sym
->name
, &e
->where
);
5048 else if (inquiry_argument
&& !first_actual_arg
)
5050 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5051 for all inquiry functions in resolve_function; the reason is
5052 that the function-name resolution happens too late in that
5054 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5055 "an inquiry function shall be the first argument",
5056 sym
->name
, &e
->where
);
5060 /* TS 29113, C535b. */
5061 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5062 && CLASS_DATA (sym
)->as
5063 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5064 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5065 && sym
->as
->type
== AS_ASSUMED_RANK
))
5069 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5070 "actual argument", sym
->name
, &e
->where
);
5073 else if (inquiry_argument
&& !first_actual_arg
)
5075 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5076 for all inquiry functions in resolve_function; the reason is
5077 that the function-name resolution happens too late in that
5079 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5080 "to an inquiry function shall be the first argument",
5081 sym
->name
, &e
->where
);
5086 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5087 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5088 && e
->ref
->next
== NULL
))
5090 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5091 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5094 /* TS 29113, 407b. */
5095 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5096 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5097 && e
->ref
->next
== NULL
))
5099 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5100 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5104 /* TS 29113, C535b. */
5105 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5106 && CLASS_DATA (sym
)->as
5107 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5108 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5109 && sym
->as
->type
== AS_ASSUMED_RANK
))
5111 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5112 && e
->ref
->next
== NULL
))
5114 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5115 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5119 /* For variables that are used in an associate (target => object) where
5120 the object's basetype is array valued while the target is scalar,
5121 the ts' type of the component refs is still array valued, which
5122 can't be translated that way. */
5123 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5124 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5125 && CLASS_DATA (sym
->assoc
->target
)->as
)
5127 gfc_ref
*ref
= e
->ref
;
5133 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5134 /* Stop the loop. */
5144 /* If this is an associate-name, it may be parsed with an array reference
5145 in error even though the target is scalar. Fail directly in this case.
5146 TODO Understand why class scalar expressions must be excluded. */
5147 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5149 if (sym
->ts
.type
== BT_CLASS
)
5150 gfc_fix_class_refs (e
);
5151 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5155 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5156 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5158 /* On the other hand, the parser may not have known this is an array;
5159 in this case, we have to add a FULL reference. */
5160 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5162 e
->ref
= gfc_get_ref ();
5163 e
->ref
->type
= REF_ARRAY
;
5164 e
->ref
->u
.ar
.type
= AR_FULL
;
5165 e
->ref
->u
.ar
.dimen
= 0;
5168 /* Like above, but for class types, where the checking whether an array
5169 ref is present is more complicated. Furthermore make sure not to add
5170 the full array ref to _vptr or _len refs. */
5171 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5172 && CLASS_DATA (sym
)->attr
.dimension
5173 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5175 gfc_ref
*ref
, *newref
;
5177 newref
= gfc_get_ref ();
5178 newref
->type
= REF_ARRAY
;
5179 newref
->u
.ar
.type
= AR_FULL
;
5180 newref
->u
.ar
.dimen
= 0;
5181 /* Because this is an associate var and the first ref either is a ref to
5182 the _data component or not, no traversal of the ref chain is
5183 needed. The array ref needs to be inserted after the _data ref,
5184 or when that is not present, which may happend for polymorphic
5185 types, then at the first position. */
5189 else if (ref
->type
== REF_COMPONENT
5190 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5192 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5194 newref
->next
= ref
->next
;
5198 /* Array ref present already. */
5199 gfc_free_ref_list (newref
);
5201 else if (ref
->type
== REF_ARRAY
)
5202 /* Array ref present already. */
5203 gfc_free_ref_list (newref
);
5211 if (e
->ref
&& !resolve_ref (e
))
5214 if (sym
->attr
.flavor
== FL_PROCEDURE
5215 && (!sym
->attr
.function
5216 || (sym
->attr
.function
&& sym
->result
5217 && sym
->result
->attr
.proc_pointer
5218 && !sym
->result
->attr
.function
)))
5220 e
->ts
.type
= BT_PROCEDURE
;
5221 goto resolve_procedure
;
5224 if (sym
->ts
.type
!= BT_UNKNOWN
)
5225 gfc_variable_attr (e
, &e
->ts
);
5226 else if (sym
->attr
.flavor
== FL_PROCEDURE
5227 && sym
->attr
.function
&& sym
->result
5228 && sym
->result
->ts
.type
!= BT_UNKNOWN
5229 && sym
->result
->attr
.proc_pointer
)
5230 e
->ts
= sym
->result
->ts
;
5233 /* Must be a simple variable reference. */
5234 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5239 if (check_assumed_size_reference (sym
, e
))
5242 /* Deal with forward references to entries during gfc_resolve_code, to
5243 satisfy, at least partially, 12.5.2.5. */
5244 if (gfc_current_ns
->entries
5245 && current_entry_id
== sym
->entry_id
5248 && cs_base
->current
->op
!= EXEC_ENTRY
)
5250 gfc_entry_list
*entry
;
5251 gfc_formal_arglist
*formal
;
5253 bool seen
, saved_specification_expr
;
5255 /* If the symbol is a dummy... */
5256 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5258 entry
= gfc_current_ns
->entries
;
5261 /* ...test if the symbol is a parameter of previous entries. */
5262 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5263 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5265 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5272 /* If it has not been seen as a dummy, this is an error. */
5275 if (specification_expr
)
5276 gfc_error ("Variable %qs, used in a specification expression"
5277 ", is referenced at %L before the ENTRY statement "
5278 "in which it is a parameter",
5279 sym
->name
, &cs_base
->current
->loc
);
5281 gfc_error ("Variable %qs is used at %L before the ENTRY "
5282 "statement in which it is a parameter",
5283 sym
->name
, &cs_base
->current
->loc
);
5288 /* Now do the same check on the specification expressions. */
5289 saved_specification_expr
= specification_expr
;
5290 specification_expr
= true;
5291 if (sym
->ts
.type
== BT_CHARACTER
5292 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5296 for (n
= 0; n
< sym
->as
->rank
; n
++)
5298 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5300 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5303 specification_expr
= saved_specification_expr
;
5306 /* Update the symbol's entry level. */
5307 sym
->entry_id
= current_entry_id
+ 1;
5310 /* If a symbol has been host_associated mark it. This is used latter,
5311 to identify if aliasing is possible via host association. */
5312 if (sym
->attr
.flavor
== FL_VARIABLE
5313 && gfc_current_ns
->parent
5314 && (gfc_current_ns
->parent
== sym
->ns
5315 || (gfc_current_ns
->parent
->parent
5316 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5317 sym
->attr
.host_assoc
= 1;
5319 if (gfc_current_ns
->proc_name
5320 && sym
->attr
.dimension
5321 && (sym
->ns
!= gfc_current_ns
5322 || sym
->attr
.use_assoc
5323 || sym
->attr
.in_common
))
5324 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5327 if (t
&& !resolve_procedure_expression (e
))
5330 /* F2008, C617 and C1229. */
5331 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5332 && gfc_is_coindexed (e
))
5334 gfc_ref
*ref
, *ref2
= NULL
;
5336 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5338 if (ref
->type
== REF_COMPONENT
)
5340 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5344 for ( ; ref
; ref
= ref
->next
)
5345 if (ref
->type
== REF_COMPONENT
)
5348 /* Expression itself is not coindexed object. */
5349 if (ref
&& e
->ts
.type
== BT_CLASS
)
5351 gfc_error ("Polymorphic subobject of coindexed object at %L",
5356 /* Expression itself is coindexed object. */
5360 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5361 for ( ; c
; c
= c
->next
)
5362 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5364 gfc_error ("Coindexed object with polymorphic allocatable "
5365 "subcomponent at %L", &e
->where
);
5373 expression_rank (e
);
5375 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5376 add_caf_get_intrinsic (e
);
5382 /* Checks to see that the correct symbol has been host associated.
5383 The only situation where this arises is that in which a twice
5384 contained function is parsed after the host association is made.
5385 Therefore, on detecting this, change the symbol in the expression
5386 and convert the array reference into an actual arglist if the old
5387 symbol is a variable. */
5389 check_host_association (gfc_expr
*e
)
5391 gfc_symbol
*sym
, *old_sym
;
5395 gfc_actual_arglist
*arg
, *tail
= NULL
;
5396 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5398 /* If the expression is the result of substitution in
5399 interface.c(gfc_extend_expr) because there is no way in
5400 which the host association can be wrong. */
5401 if (e
->symtree
== NULL
5402 || e
->symtree
->n
.sym
== NULL
5403 || e
->user_operator
)
5406 old_sym
= e
->symtree
->n
.sym
;
5408 if (gfc_current_ns
->parent
5409 && old_sym
->ns
!= gfc_current_ns
)
5411 /* Use the 'USE' name so that renamed module symbols are
5412 correctly handled. */
5413 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5415 if (sym
&& old_sym
!= sym
5416 && sym
->ts
.type
== old_sym
->ts
.type
5417 && sym
->attr
.flavor
== FL_PROCEDURE
5418 && sym
->attr
.contained
)
5420 /* Clear the shape, since it might not be valid. */
5421 gfc_free_shape (&e
->shape
, e
->rank
);
5423 /* Give the expression the right symtree! */
5424 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5425 gcc_assert (st
!= NULL
);
5427 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5428 || e
->expr_type
== EXPR_FUNCTION
)
5430 /* Original was function so point to the new symbol, since
5431 the actual argument list is already attached to the
5433 e
->value
.function
.esym
= NULL
;
5438 /* Original was variable so convert array references into
5439 an actual arglist. This does not need any checking now
5440 since resolve_function will take care of it. */
5441 e
->value
.function
.actual
= NULL
;
5442 e
->expr_type
= EXPR_FUNCTION
;
5445 /* Ambiguity will not arise if the array reference is not
5446 the last reference. */
5447 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5448 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5451 gcc_assert (ref
->type
== REF_ARRAY
);
5453 /* Grab the start expressions from the array ref and
5454 copy them into actual arguments. */
5455 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5457 arg
= gfc_get_actual_arglist ();
5458 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5459 if (e
->value
.function
.actual
== NULL
)
5460 tail
= e
->value
.function
.actual
= arg
;
5468 /* Dump the reference list and set the rank. */
5469 gfc_free_ref_list (e
->ref
);
5471 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5474 gfc_resolve_expr (e
);
5478 /* This might have changed! */
5479 return e
->expr_type
== EXPR_FUNCTION
;
5484 gfc_resolve_character_operator (gfc_expr
*e
)
5486 gfc_expr
*op1
= e
->value
.op
.op1
;
5487 gfc_expr
*op2
= e
->value
.op
.op2
;
5488 gfc_expr
*e1
= NULL
;
5489 gfc_expr
*e2
= NULL
;
5491 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5493 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5494 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5495 else if (op1
->expr_type
== EXPR_CONSTANT
)
5496 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5497 op1
->value
.character
.length
);
5499 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5500 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5501 else if (op2
->expr_type
== EXPR_CONSTANT
)
5502 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5503 op2
->value
.character
.length
);
5505 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5515 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5516 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5517 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5518 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5519 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5525 /* Ensure that an character expression has a charlen and, if possible, a
5526 length expression. */
5529 fixup_charlen (gfc_expr
*e
)
5531 /* The cases fall through so that changes in expression type and the need
5532 for multiple fixes are picked up. In all circumstances, a charlen should
5533 be available for the middle end to hang a backend_decl on. */
5534 switch (e
->expr_type
)
5537 gfc_resolve_character_operator (e
);
5541 if (e
->expr_type
== EXPR_ARRAY
)
5542 gfc_resolve_character_array_constructor (e
);
5545 case EXPR_SUBSTRING
:
5546 if (!e
->ts
.u
.cl
&& e
->ref
)
5547 gfc_resolve_substring_charlen (e
);
5552 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5559 /* Update an actual argument to include the passed-object for type-bound
5560 procedures at the right position. */
5562 static gfc_actual_arglist
*
5563 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5566 gcc_assert (argpos
> 0);
5570 gfc_actual_arglist
* result
;
5572 result
= gfc_get_actual_arglist ();
5576 result
->name
= name
;
5582 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5584 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5589 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5592 extract_compcall_passed_object (gfc_expr
* e
)
5596 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5598 if (e
->value
.compcall
.base_object
)
5599 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5602 po
= gfc_get_expr ();
5603 po
->expr_type
= EXPR_VARIABLE
;
5604 po
->symtree
= e
->symtree
;
5605 po
->ref
= gfc_copy_ref (e
->ref
);
5606 po
->where
= e
->where
;
5609 if (!gfc_resolve_expr (po
))
5616 /* Update the arglist of an EXPR_COMPCALL expression to include the
5620 update_compcall_arglist (gfc_expr
* e
)
5623 gfc_typebound_proc
* tbp
;
5625 tbp
= e
->value
.compcall
.tbp
;
5630 po
= extract_compcall_passed_object (e
);
5634 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5640 gcc_assert (tbp
->pass_arg_num
> 0);
5641 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5649 /* Extract the passed object from a PPC call (a copy of it). */
5652 extract_ppc_passed_object (gfc_expr
*e
)
5657 po
= gfc_get_expr ();
5658 po
->expr_type
= EXPR_VARIABLE
;
5659 po
->symtree
= e
->symtree
;
5660 po
->ref
= gfc_copy_ref (e
->ref
);
5661 po
->where
= e
->where
;
5663 /* Remove PPC reference. */
5665 while ((*ref
)->next
)
5666 ref
= &(*ref
)->next
;
5667 gfc_free_ref_list (*ref
);
5670 if (!gfc_resolve_expr (po
))
5677 /* Update the actual arglist of a procedure pointer component to include the
5681 update_ppc_arglist (gfc_expr
* e
)
5685 gfc_typebound_proc
* tb
;
5687 ppc
= gfc_get_proc_ptr_comp (e
);
5695 else if (tb
->nopass
)
5698 po
= extract_ppc_passed_object (e
);
5705 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5710 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5712 gfc_error ("Base object for procedure-pointer component call at %L is of"
5713 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5717 gcc_assert (tb
->pass_arg_num
> 0);
5718 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5726 /* Check that the object a TBP is called on is valid, i.e. it must not be
5727 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5730 check_typebound_baseobject (gfc_expr
* e
)
5733 bool return_value
= false;
5735 base
= extract_compcall_passed_object (e
);
5739 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5741 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5745 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5747 gfc_error ("Base object for type-bound procedure call at %L is of"
5748 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5752 /* F08:C1230. If the procedure called is NOPASS,
5753 the base object must be scalar. */
5754 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5756 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5757 " be scalar", &e
->where
);
5761 return_value
= true;
5764 gfc_free_expr (base
);
5765 return return_value
;
5769 /* Resolve a call to a type-bound procedure, either function or subroutine,
5770 statically from the data in an EXPR_COMPCALL expression. The adapted
5771 arglist and the target-procedure symtree are returned. */
5774 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5775 gfc_actual_arglist
** actual
)
5777 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5778 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5780 /* Update the actual arglist for PASS. */
5781 if (!update_compcall_arglist (e
))
5784 *actual
= e
->value
.compcall
.actual
;
5785 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5787 gfc_free_ref_list (e
->ref
);
5789 e
->value
.compcall
.actual
= NULL
;
5791 /* If we find a deferred typebound procedure, check for derived types
5792 that an overriding typebound procedure has not been missed. */
5793 if (e
->value
.compcall
.name
5794 && !e
->value
.compcall
.tbp
->non_overridable
5795 && e
->value
.compcall
.base_object
5796 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5799 gfc_symbol
*derived
;
5801 /* Use the derived type of the base_object. */
5802 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5805 /* If necessary, go through the inheritance chain. */
5806 while (!st
&& derived
)
5808 /* Look for the typebound procedure 'name'. */
5809 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5810 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5811 e
->value
.compcall
.name
);
5813 derived
= gfc_get_derived_super_type (derived
);
5816 /* Now find the specific name in the derived type namespace. */
5817 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5818 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5819 derived
->ns
, 1, &st
);
5827 /* Get the ultimate declared type from an expression. In addition,
5828 return the last class/derived type reference and the copy of the
5829 reference list. If check_types is set true, derived types are
5830 identified as well as class references. */
5832 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5833 gfc_expr
*e
, bool check_types
)
5835 gfc_symbol
*declared
;
5842 *new_ref
= gfc_copy_ref (e
->ref
);
5844 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5846 if (ref
->type
!= REF_COMPONENT
)
5849 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5850 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
5851 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5853 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5859 if (declared
== NULL
)
5860 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5866 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5867 which of the specific bindings (if any) matches the arglist and transform
5868 the expression into a call of that binding. */
5871 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5873 gfc_typebound_proc
* genproc
;
5874 const char* genname
;
5876 gfc_symbol
*derived
;
5878 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5879 genname
= e
->value
.compcall
.name
;
5880 genproc
= e
->value
.compcall
.tbp
;
5882 if (!genproc
->is_generic
)
5885 /* Try the bindings on this type and in the inheritance hierarchy. */
5886 for (; genproc
; genproc
= genproc
->overridden
)
5890 gcc_assert (genproc
->is_generic
);
5891 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5894 gfc_actual_arglist
* args
;
5897 gcc_assert (g
->specific
);
5899 if (g
->specific
->error
)
5902 target
= g
->specific
->u
.specific
->n
.sym
;
5904 /* Get the right arglist by handling PASS/NOPASS. */
5905 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5906 if (!g
->specific
->nopass
)
5909 po
= extract_compcall_passed_object (e
);
5912 gfc_free_actual_arglist (args
);
5916 gcc_assert (g
->specific
->pass_arg_num
> 0);
5917 gcc_assert (!g
->specific
->error
);
5918 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5919 g
->specific
->pass_arg
);
5921 resolve_actual_arglist (args
, target
->attr
.proc
,
5922 is_external_proc (target
)
5923 && gfc_sym_get_dummy_args (target
) == NULL
);
5925 /* Check if this arglist matches the formal. */
5926 matches
= gfc_arglist_matches_symbol (&args
, target
);
5928 /* Clean up and break out of the loop if we've found it. */
5929 gfc_free_actual_arglist (args
);
5932 e
->value
.compcall
.tbp
= g
->specific
;
5933 genname
= g
->specific_st
->name
;
5934 /* Pass along the name for CLASS methods, where the vtab
5935 procedure pointer component has to be referenced. */
5943 /* Nothing matching found! */
5944 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5945 " %qs at %L", genname
, &e
->where
);
5949 /* Make sure that we have the right specific instance for the name. */
5950 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5952 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5954 e
->value
.compcall
.tbp
= st
->n
.tb
;
5960 /* Resolve a call to a type-bound subroutine. */
5963 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5965 gfc_actual_arglist
* newactual
;
5966 gfc_symtree
* target
;
5968 /* Check that's really a SUBROUTINE. */
5969 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5971 gfc_error ("%qs at %L should be a SUBROUTINE",
5972 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5976 if (!check_typebound_baseobject (c
->expr1
))
5979 /* Pass along the name for CLASS methods, where the vtab
5980 procedure pointer component has to be referenced. */
5982 *name
= c
->expr1
->value
.compcall
.name
;
5984 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5987 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5989 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5991 /* Transform into an ordinary EXEC_CALL for now. */
5993 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5996 c
->ext
.actual
= newactual
;
5997 c
->symtree
= target
;
5998 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6000 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6002 gfc_free_expr (c
->expr1
);
6003 c
->expr1
= gfc_get_expr ();
6004 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6005 c
->expr1
->symtree
= target
;
6006 c
->expr1
->where
= c
->loc
;
6008 return resolve_call (c
);
6012 /* Resolve a component-call expression. */
6014 resolve_compcall (gfc_expr
* e
, const char **name
)
6016 gfc_actual_arglist
* newactual
;
6017 gfc_symtree
* target
;
6019 /* Check that's really a FUNCTION. */
6020 if (!e
->value
.compcall
.tbp
->function
)
6022 gfc_error ("%qs at %L should be a FUNCTION",
6023 e
->value
.compcall
.name
, &e
->where
);
6027 /* These must not be assign-calls! */
6028 gcc_assert (!e
->value
.compcall
.assign
);
6030 if (!check_typebound_baseobject (e
))
6033 /* Pass along the name for CLASS methods, where the vtab
6034 procedure pointer component has to be referenced. */
6036 *name
= e
->value
.compcall
.name
;
6038 if (!resolve_typebound_generic_call (e
, name
))
6040 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6042 /* Take the rank from the function's symbol. */
6043 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6044 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6046 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6047 arglist to the TBP's binding target. */
6049 if (!resolve_typebound_static (e
, &target
, &newactual
))
6052 e
->value
.function
.actual
= newactual
;
6053 e
->value
.function
.name
= NULL
;
6054 e
->value
.function
.esym
= target
->n
.sym
;
6055 e
->value
.function
.isym
= NULL
;
6056 e
->symtree
= target
;
6057 e
->ts
= target
->n
.sym
->ts
;
6058 e
->expr_type
= EXPR_FUNCTION
;
6060 /* Resolution is not necessary if this is a class subroutine; this
6061 function only has to identify the specific proc. Resolution of
6062 the call will be done next in resolve_typebound_call. */
6063 return gfc_resolve_expr (e
);
6067 static bool resolve_fl_derived (gfc_symbol
*sym
);
6070 /* Resolve a typebound function, or 'method'. First separate all
6071 the non-CLASS references by calling resolve_compcall directly. */
6074 resolve_typebound_function (gfc_expr
* e
)
6076 gfc_symbol
*declared
;
6088 /* Deal with typebound operators for CLASS objects. */
6089 expr
= e
->value
.compcall
.base_object
;
6090 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6091 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6093 /* If the base_object is not a variable, the corresponding actual
6094 argument expression must be stored in e->base_expression so
6095 that the corresponding tree temporary can be used as the base
6096 object in gfc_conv_procedure_call. */
6097 if (expr
->expr_type
!= EXPR_VARIABLE
)
6099 gfc_actual_arglist
*args
;
6101 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6103 if (expr
== args
->expr
)
6108 /* Since the typebound operators are generic, we have to ensure
6109 that any delays in resolution are corrected and that the vtab
6112 declared
= ts
.u
.derived
;
6113 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6114 if (c
->ts
.u
.derived
== NULL
)
6115 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6117 if (!resolve_compcall (e
, &name
))
6120 /* Use the generic name if it is there. */
6121 name
= name
? name
: e
->value
.function
.esym
->name
;
6122 e
->symtree
= expr
->symtree
;
6123 e
->ref
= gfc_copy_ref (expr
->ref
);
6124 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6126 /* Trim away the extraneous references that emerge from nested
6127 use of interface.c (extend_expr). */
6128 if (class_ref
&& class_ref
->next
)
6130 gfc_free_ref_list (class_ref
->next
);
6131 class_ref
->next
= NULL
;
6133 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6135 gfc_free_ref_list (e
->ref
);
6139 gfc_add_vptr_component (e
);
6140 gfc_add_component_ref (e
, name
);
6141 e
->value
.function
.esym
= NULL
;
6142 if (expr
->expr_type
!= EXPR_VARIABLE
)
6143 e
->base_expr
= expr
;
6148 return resolve_compcall (e
, NULL
);
6150 if (!resolve_ref (e
))
6153 /* Get the CLASS declared type. */
6154 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6156 if (!resolve_fl_derived (declared
))
6159 /* Weed out cases of the ultimate component being a derived type. */
6160 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6161 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6163 gfc_free_ref_list (new_ref
);
6164 return resolve_compcall (e
, NULL
);
6167 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6168 declared
= c
->ts
.u
.derived
;
6170 /* Treat the call as if it is a typebound procedure, in order to roll
6171 out the correct name for the specific function. */
6172 if (!resolve_compcall (e
, &name
))
6174 gfc_free_ref_list (new_ref
);
6181 /* Convert the expression to a procedure pointer component call. */
6182 e
->value
.function
.esym
= NULL
;
6188 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6189 gfc_add_vptr_component (e
);
6190 gfc_add_component_ref (e
, name
);
6192 /* Recover the typespec for the expression. This is really only
6193 necessary for generic procedures, where the additional call
6194 to gfc_add_component_ref seems to throw the collection of the
6195 correct typespec. */
6199 gfc_free_ref_list (new_ref
);
6204 /* Resolve a typebound subroutine, or 'method'. First separate all
6205 the non-CLASS references by calling resolve_typebound_call
6209 resolve_typebound_subroutine (gfc_code
*code
)
6211 gfc_symbol
*declared
;
6221 st
= code
->expr1
->symtree
;
6223 /* Deal with typebound operators for CLASS objects. */
6224 expr
= code
->expr1
->value
.compcall
.base_object
;
6225 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6226 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6228 /* If the base_object is not a variable, the corresponding actual
6229 argument expression must be stored in e->base_expression so
6230 that the corresponding tree temporary can be used as the base
6231 object in gfc_conv_procedure_call. */
6232 if (expr
->expr_type
!= EXPR_VARIABLE
)
6234 gfc_actual_arglist
*args
;
6236 args
= code
->expr1
->value
.function
.actual
;
6237 for (; args
; args
= args
->next
)
6238 if (expr
== args
->expr
)
6242 /* Since the typebound operators are generic, we have to ensure
6243 that any delays in resolution are corrected and that the vtab
6245 declared
= expr
->ts
.u
.derived
;
6246 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6247 if (c
->ts
.u
.derived
== NULL
)
6248 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6250 if (!resolve_typebound_call (code
, &name
, NULL
))
6253 /* Use the generic name if it is there. */
6254 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6255 code
->expr1
->symtree
= expr
->symtree
;
6256 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6258 /* Trim away the extraneous references that emerge from nested
6259 use of interface.c (extend_expr). */
6260 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6261 if (class_ref
&& class_ref
->next
)
6263 gfc_free_ref_list (class_ref
->next
);
6264 class_ref
->next
= NULL
;
6266 else if (code
->expr1
->ref
&& !class_ref
)
6268 gfc_free_ref_list (code
->expr1
->ref
);
6269 code
->expr1
->ref
= NULL
;
6272 /* Now use the procedure in the vtable. */
6273 gfc_add_vptr_component (code
->expr1
);
6274 gfc_add_component_ref (code
->expr1
, name
);
6275 code
->expr1
->value
.function
.esym
= NULL
;
6276 if (expr
->expr_type
!= EXPR_VARIABLE
)
6277 code
->expr1
->base_expr
= expr
;
6282 return resolve_typebound_call (code
, NULL
, NULL
);
6284 if (!resolve_ref (code
->expr1
))
6287 /* Get the CLASS declared type. */
6288 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6290 /* Weed out cases of the ultimate component being a derived type. */
6291 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6292 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6294 gfc_free_ref_list (new_ref
);
6295 return resolve_typebound_call (code
, NULL
, NULL
);
6298 if (!resolve_typebound_call (code
, &name
, &overridable
))
6300 gfc_free_ref_list (new_ref
);
6303 ts
= code
->expr1
->ts
;
6307 /* Convert the expression to a procedure pointer component call. */
6308 code
->expr1
->value
.function
.esym
= NULL
;
6309 code
->expr1
->symtree
= st
;
6312 code
->expr1
->ref
= new_ref
;
6314 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6315 gfc_add_vptr_component (code
->expr1
);
6316 gfc_add_component_ref (code
->expr1
, name
);
6318 /* Recover the typespec for the expression. This is really only
6319 necessary for generic procedures, where the additional call
6320 to gfc_add_component_ref seems to throw the collection of the
6321 correct typespec. */
6322 code
->expr1
->ts
= ts
;
6325 gfc_free_ref_list (new_ref
);
6331 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6334 resolve_ppc_call (gfc_code
* c
)
6336 gfc_component
*comp
;
6338 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6339 gcc_assert (comp
!= NULL
);
6341 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6342 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6344 if (!comp
->attr
.subroutine
)
6345 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6347 if (!resolve_ref (c
->expr1
))
6350 if (!update_ppc_arglist (c
->expr1
))
6353 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6355 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6356 !(comp
->ts
.interface
6357 && comp
->ts
.interface
->formal
)))
6360 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6363 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6369 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6372 resolve_expr_ppc (gfc_expr
* e
)
6374 gfc_component
*comp
;
6376 comp
= gfc_get_proc_ptr_comp (e
);
6377 gcc_assert (comp
!= NULL
);
6379 /* Convert to EXPR_FUNCTION. */
6380 e
->expr_type
= EXPR_FUNCTION
;
6381 e
->value
.function
.isym
= NULL
;
6382 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6384 if (comp
->as
!= NULL
)
6385 e
->rank
= comp
->as
->rank
;
6387 if (!comp
->attr
.function
)
6388 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6390 if (!resolve_ref (e
))
6393 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6394 !(comp
->ts
.interface
6395 && comp
->ts
.interface
->formal
)))
6398 if (!update_ppc_arglist (e
))
6401 if (!check_pure_function(e
))
6404 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6411 gfc_is_expandable_expr (gfc_expr
*e
)
6413 gfc_constructor
*con
;
6415 if (e
->expr_type
== EXPR_ARRAY
)
6417 /* Traverse the constructor looking for variables that are flavor
6418 parameter. Parameters must be expanded since they are fully used at
6420 con
= gfc_constructor_first (e
->value
.constructor
);
6421 for (; con
; con
= gfc_constructor_next (con
))
6423 if (con
->expr
->expr_type
== EXPR_VARIABLE
6424 && con
->expr
->symtree
6425 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6426 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6428 if (con
->expr
->expr_type
== EXPR_ARRAY
6429 && gfc_is_expandable_expr (con
->expr
))
6438 /* Sometimes variables in specification expressions of the result
6439 of module procedures in submodules wind up not being the 'real'
6440 dummy. Find this, if possible, in the namespace of the first
6444 fixup_unique_dummy (gfc_expr
*e
)
6446 gfc_symtree
*st
= NULL
;
6447 gfc_symbol
*s
= NULL
;
6449 if (e
->symtree
->n
.sym
->ns
->proc_name
6450 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6451 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6454 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6457 && st
->n
.sym
!= NULL
6458 && st
->n
.sym
->attr
.dummy
)
6462 /* Resolve an expression. That is, make sure that types of operands agree
6463 with their operators, intrinsic operators are converted to function calls
6464 for overloaded types and unresolved function references are resolved. */
6467 gfc_resolve_expr (gfc_expr
*e
)
6470 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6475 /* inquiry_argument only applies to variables. */
6476 inquiry_save
= inquiry_argument
;
6477 actual_arg_save
= actual_arg
;
6478 first_actual_arg_save
= first_actual_arg
;
6480 if (e
->expr_type
!= EXPR_VARIABLE
)
6482 inquiry_argument
= false;
6484 first_actual_arg
= false;
6486 else if (e
->symtree
!= NULL
6487 && *e
->symtree
->name
== '@'
6488 && e
->symtree
->n
.sym
->attr
.dummy
)
6490 /* Deal with submodule specification expressions that are not
6491 found to be referenced in module.c(read_cleanup). */
6492 fixup_unique_dummy (e
);
6495 switch (e
->expr_type
)
6498 t
= resolve_operator (e
);
6504 if (check_host_association (e
))
6505 t
= resolve_function (e
);
6507 t
= resolve_variable (e
);
6509 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6510 && e
->ref
->type
!= REF_SUBSTRING
)
6511 gfc_resolve_substring_charlen (e
);
6516 t
= resolve_typebound_function (e
);
6519 case EXPR_SUBSTRING
:
6520 t
= resolve_ref (e
);
6529 t
= resolve_expr_ppc (e
);
6534 if (!resolve_ref (e
))
6537 t
= gfc_resolve_array_constructor (e
);
6538 /* Also try to expand a constructor. */
6541 expression_rank (e
);
6542 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6543 gfc_expand_constructor (e
, false);
6546 /* This provides the opportunity for the length of constructors with
6547 character valued function elements to propagate the string length
6548 to the expression. */
6549 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6551 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6552 here rather then add a duplicate test for it above. */
6553 gfc_expand_constructor (e
, false);
6554 t
= gfc_resolve_character_array_constructor (e
);
6559 case EXPR_STRUCTURE
:
6560 t
= resolve_ref (e
);
6564 t
= resolve_structure_cons (e
, 0);
6568 t
= gfc_simplify_expr (e
, 0);
6572 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6575 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6578 inquiry_argument
= inquiry_save
;
6579 actual_arg
= actual_arg_save
;
6580 first_actual_arg
= first_actual_arg_save
;
6586 /* Resolve an expression from an iterator. They must be scalar and have
6587 INTEGER or (optionally) REAL type. */
6590 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6591 const char *name_msgid
)
6593 if (!gfc_resolve_expr (expr
))
6596 if (expr
->rank
!= 0)
6598 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6602 if (expr
->ts
.type
!= BT_INTEGER
)
6604 if (expr
->ts
.type
== BT_REAL
)
6607 return gfc_notify_std (GFC_STD_F95_DEL
,
6608 "%s at %L must be integer",
6609 _(name_msgid
), &expr
->where
);
6612 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6619 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6627 /* Resolve the expressions in an iterator structure. If REAL_OK is
6628 false allow only INTEGER type iterators, otherwise allow REAL types.
6629 Set own_scope to true for ac-implied-do and data-implied-do as those
6630 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6633 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6635 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6638 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6639 _("iterator variable")))
6642 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6643 "Start expression in DO loop"))
6646 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6647 "End expression in DO loop"))
6650 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6651 "Step expression in DO loop"))
6654 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6656 if ((iter
->step
->ts
.type
== BT_INTEGER
6657 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6658 || (iter
->step
->ts
.type
== BT_REAL
6659 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6661 gfc_error ("Step expression in DO loop at %L cannot be zero",
6662 &iter
->step
->where
);
6667 /* Convert start, end, and step to the same type as var. */
6668 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6669 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6670 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6672 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6673 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6674 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6676 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6677 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6678 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
6680 if (iter
->start
->expr_type
== EXPR_CONSTANT
6681 && iter
->end
->expr_type
== EXPR_CONSTANT
6682 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6685 if (iter
->start
->ts
.type
== BT_INTEGER
)
6687 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6688 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6692 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6693 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6695 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6696 gfc_warning (OPT_Wzerotrip
,
6697 "DO loop at %L will be executed zero times",
6698 &iter
->step
->where
);
6701 if (iter
->end
->expr_type
== EXPR_CONSTANT
6702 && iter
->end
->ts
.type
== BT_INTEGER
6703 && iter
->step
->expr_type
== EXPR_CONSTANT
6704 && iter
->step
->ts
.type
== BT_INTEGER
6705 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
6706 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
6708 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
6709 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
6711 if (is_step_positive
6712 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
6713 gfc_warning (OPT_Wundefined_do_loop
,
6714 "DO loop at %L is undefined as it overflows",
6715 &iter
->step
->where
);
6716 else if (!is_step_positive
6717 && mpz_cmp (iter
->end
->value
.integer
,
6718 gfc_integer_kinds
[k
].min_int
) == 0)
6719 gfc_warning (OPT_Wundefined_do_loop
,
6720 "DO loop at %L is undefined as it underflows",
6721 &iter
->step
->where
);
6728 /* Traversal function for find_forall_index. f == 2 signals that
6729 that variable itself is not to be checked - only the references. */
6732 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6734 if (expr
->expr_type
!= EXPR_VARIABLE
)
6737 /* A scalar assignment */
6738 if (!expr
->ref
|| *f
== 1)
6740 if (expr
->symtree
->n
.sym
== sym
)
6752 /* Check whether the FORALL index appears in the expression or not.
6753 Returns true if SYM is found in EXPR. */
6756 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6758 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6765 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6766 to be a scalar INTEGER variable. The subscripts and stride are scalar
6767 INTEGERs, and if stride is a constant it must be nonzero.
6768 Furthermore "A subscript or stride in a forall-triplet-spec shall
6769 not contain a reference to any index-name in the
6770 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6773 resolve_forall_iterators (gfc_forall_iterator
*it
)
6775 gfc_forall_iterator
*iter
, *iter2
;
6777 for (iter
= it
; iter
; iter
= iter
->next
)
6779 if (gfc_resolve_expr (iter
->var
)
6780 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6781 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6784 if (gfc_resolve_expr (iter
->start
)
6785 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6786 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6787 &iter
->start
->where
);
6788 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6789 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6791 if (gfc_resolve_expr (iter
->end
)
6792 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6793 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6795 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6796 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6798 if (gfc_resolve_expr (iter
->stride
))
6800 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6801 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6802 &iter
->stride
->where
, "INTEGER");
6804 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6805 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6806 gfc_error ("FORALL stride expression at %L cannot be zero",
6807 &iter
->stride
->where
);
6809 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6810 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6813 for (iter
= it
; iter
; iter
= iter
->next
)
6814 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6816 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6817 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6818 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6819 gfc_error ("FORALL index %qs may not appear in triplet "
6820 "specification at %L", iter
->var
->symtree
->name
,
6821 &iter2
->start
->where
);
6826 /* Given a pointer to a symbol that is a derived type, see if it's
6827 inaccessible, i.e. if it's defined in another module and the components are
6828 PRIVATE. The search is recursive if necessary. Returns zero if no
6829 inaccessible components are found, nonzero otherwise. */
6832 derived_inaccessible (gfc_symbol
*sym
)
6836 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6839 for (c
= sym
->components
; c
; c
= c
->next
)
6841 /* Prevent an infinite loop through this function. */
6842 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
6843 && sym
== c
->ts
.u
.derived
)
6846 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6854 /* Resolve the argument of a deallocate expression. The expression must be
6855 a pointer or a full array. */
6858 resolve_deallocate_expr (gfc_expr
*e
)
6860 symbol_attribute attr
;
6861 int allocatable
, pointer
;
6867 if (!gfc_resolve_expr (e
))
6870 if (e
->expr_type
!= EXPR_VARIABLE
)
6873 sym
= e
->symtree
->n
.sym
;
6874 unlimited
= UNLIMITED_POLY(sym
);
6876 if (sym
->ts
.type
== BT_CLASS
)
6878 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6879 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6883 allocatable
= sym
->attr
.allocatable
;
6884 pointer
= sym
->attr
.pointer
;
6886 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6891 if (ref
->u
.ar
.type
!= AR_FULL
6892 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6893 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6898 c
= ref
->u
.c
.component
;
6899 if (c
->ts
.type
== BT_CLASS
)
6901 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6902 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6906 allocatable
= c
->attr
.allocatable
;
6907 pointer
= c
->attr
.pointer
;
6917 attr
= gfc_expr_attr (e
);
6919 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6922 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6928 if (gfc_is_coindexed (e
))
6930 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6935 && !gfc_check_vardef_context (e
, true, true, false,
6936 _("DEALLOCATE object")))
6938 if (!gfc_check_vardef_context (e
, false, true, false,
6939 _("DEALLOCATE object")))
6946 /* Returns true if the expression e contains a reference to the symbol sym. */
6948 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6950 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6957 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6959 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6963 /* Given the expression node e for an allocatable/pointer of derived type to be
6964 allocated, get the expression node to be initialized afterwards (needed for
6965 derived types with default initializers, and derived types with allocatable
6966 components that need nullification.) */
6969 gfc_expr_to_initialize (gfc_expr
*e
)
6975 result
= gfc_copy_expr (e
);
6977 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6978 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6979 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6981 ref
->u
.ar
.type
= AR_FULL
;
6983 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6984 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6989 gfc_free_shape (&result
->shape
, result
->rank
);
6991 /* Recalculate rank, shape, etc. */
6992 gfc_resolve_expr (result
);
6997 /* If the last ref of an expression is an array ref, return a copy of the
6998 expression with that one removed. Otherwise, a copy of the original
6999 expression. This is used for allocate-expressions and pointer assignment
7000 LHS, where there may be an array specification that needs to be stripped
7001 off when using gfc_check_vardef_context. */
7004 remove_last_array_ref (gfc_expr
* e
)
7009 e2
= gfc_copy_expr (e
);
7010 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7011 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7013 gfc_free_ref_list (*r
);
7022 /* Used in resolve_allocate_expr to check that a allocation-object and
7023 a source-expr are conformable. This does not catch all possible
7024 cases; in particular a runtime checking is needed. */
7027 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7030 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7032 /* First compare rank. */
7033 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7034 || (!tail
&& e1
->rank
!= e2
->rank
))
7036 gfc_error ("Source-expr at %L must be scalar or have the "
7037 "same rank as the allocate-object at %L",
7038 &e1
->where
, &e2
->where
);
7049 for (i
= 0; i
< e1
->rank
; i
++)
7051 if (tail
->u
.ar
.start
[i
] == NULL
)
7054 if (tail
->u
.ar
.end
[i
])
7056 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7057 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7058 mpz_add_ui (s
, s
, 1);
7062 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7065 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7067 gfc_error ("Source-expr at %L and allocate-object at %L must "
7068 "have the same shape", &e1
->where
, &e2
->where
);
7081 /* Resolve the expression in an ALLOCATE statement, doing the additional
7082 checks to see whether the expression is OK or not. The expression must
7083 have a trailing array reference that gives the size of the array. */
7086 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7088 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7092 symbol_attribute attr
;
7093 gfc_ref
*ref
, *ref2
;
7096 gfc_symbol
*sym
= NULL
;
7101 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7102 checking of coarrays. */
7103 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7104 if (ref
->next
== NULL
)
7107 if (ref
&& ref
->type
== REF_ARRAY
)
7108 ref
->u
.ar
.in_allocate
= true;
7110 if (!gfc_resolve_expr (e
))
7113 /* Make sure the expression is allocatable or a pointer. If it is
7114 pointer, the next-to-last reference must be a pointer. */
7118 sym
= e
->symtree
->n
.sym
;
7120 /* Check whether ultimate component is abstract and CLASS. */
7123 /* Is the allocate-object unlimited polymorphic? */
7124 unlimited
= UNLIMITED_POLY(e
);
7126 if (e
->expr_type
!= EXPR_VARIABLE
)
7129 attr
= gfc_expr_attr (e
);
7130 pointer
= attr
.pointer
;
7131 dimension
= attr
.dimension
;
7132 codimension
= attr
.codimension
;
7136 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7138 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7139 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7140 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7141 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7142 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7146 allocatable
= sym
->attr
.allocatable
;
7147 pointer
= sym
->attr
.pointer
;
7148 dimension
= sym
->attr
.dimension
;
7149 codimension
= sym
->attr
.codimension
;
7154 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7159 if (ref
->u
.ar
.codimen
> 0)
7162 for (n
= ref
->u
.ar
.dimen
;
7163 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7164 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7171 if (ref
->next
!= NULL
)
7179 gfc_error ("Coindexed allocatable object at %L",
7184 c
= ref
->u
.c
.component
;
7185 if (c
->ts
.type
== BT_CLASS
)
7187 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7188 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7189 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7190 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7191 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7195 allocatable
= c
->attr
.allocatable
;
7196 pointer
= c
->attr
.pointer
;
7197 dimension
= c
->attr
.dimension
;
7198 codimension
= c
->attr
.codimension
;
7199 is_abstract
= c
->attr
.abstract
;
7211 /* Check for F08:C628. */
7212 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7214 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7219 /* Some checks for the SOURCE tag. */
7222 /* Check F03:C631. */
7223 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7225 gfc_error ("Type of entity at %L is type incompatible with "
7226 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7230 /* Check F03:C632 and restriction following Note 6.18. */
7231 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7234 /* Check F03:C633. */
7235 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7237 gfc_error ("The allocate-object at %L and the source-expr at %L "
7238 "shall have the same kind type parameter",
7239 &e
->where
, &code
->expr3
->where
);
7243 /* Check F2008, C642. */
7244 if (code
->expr3
->ts
.type
== BT_DERIVED
7245 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7246 || (code
->expr3
->ts
.u
.derived
->from_intmod
7247 == INTMOD_ISO_FORTRAN_ENV
7248 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7249 == ISOFORTRAN_LOCK_TYPE
)))
7251 gfc_error ("The source-expr at %L shall neither be of type "
7252 "LOCK_TYPE nor have a LOCK_TYPE component if "
7253 "allocate-object at %L is a coarray",
7254 &code
->expr3
->where
, &e
->where
);
7258 /* Check TS18508, C702/C703. */
7259 if (code
->expr3
->ts
.type
== BT_DERIVED
7260 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7261 || (code
->expr3
->ts
.u
.derived
->from_intmod
7262 == INTMOD_ISO_FORTRAN_ENV
7263 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7264 == ISOFORTRAN_EVENT_TYPE
)))
7266 gfc_error ("The source-expr at %L shall neither be of type "
7267 "EVENT_TYPE nor have a EVENT_TYPE component if "
7268 "allocate-object at %L is a coarray",
7269 &code
->expr3
->where
, &e
->where
);
7274 /* Check F08:C629. */
7275 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7278 gcc_assert (e
->ts
.type
== BT_CLASS
);
7279 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7280 "type-spec or source-expr", sym
->name
, &e
->where
);
7284 /* Check F08:C632. */
7285 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7286 && !UNLIMITED_POLY (e
))
7288 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7289 code
->ext
.alloc
.ts
.u
.cl
->length
);
7290 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7292 gfc_error ("Allocating %s at %L with type-spec requires the same "
7293 "character-length parameter as in the declaration",
7294 sym
->name
, &e
->where
);
7299 /* In the variable definition context checks, gfc_expr_attr is used
7300 on the expression. This is fooled by the array specification
7301 present in e, thus we have to eliminate that one temporarily. */
7302 e2
= remove_last_array_ref (e
);
7305 t
= gfc_check_vardef_context (e2
, true, true, false,
7306 _("ALLOCATE object"));
7308 t
= gfc_check_vardef_context (e2
, false, true, false,
7309 _("ALLOCATE object"));
7314 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7315 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7317 /* For class arrays, the initialization with SOURCE is done
7318 using _copy and trans_call. It is convenient to exploit that
7319 when the allocated type is different from the declared type but
7320 no SOURCE exists by setting expr3. */
7321 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7323 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7324 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7325 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7327 /* We have to zero initialize the integer variable. */
7328 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7331 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7333 /* Make sure the vtab symbol is present when
7334 the module variables are generated. */
7335 gfc_typespec ts
= e
->ts
;
7337 ts
= code
->expr3
->ts
;
7338 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7339 ts
= code
->ext
.alloc
.ts
;
7341 /* Finding the vtab also publishes the type's symbol. Therefore this
7342 statement is necessary. */
7343 gfc_find_derived_vtab (ts
.u
.derived
);
7345 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7347 /* Again, make sure the vtab symbol is present when
7348 the module variables are generated. */
7349 gfc_typespec
*ts
= NULL
;
7351 ts
= &code
->expr3
->ts
;
7353 ts
= &code
->ext
.alloc
.ts
;
7357 /* Finding the vtab also publishes the type's symbol. Therefore this
7358 statement is necessary. */
7362 if (dimension
== 0 && codimension
== 0)
7365 /* Make sure the last reference node is an array specification. */
7367 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7368 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7373 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7374 "in ALLOCATE statement at %L", &e
->where
))
7376 if (code
->expr3
->rank
!= 0)
7377 *array_alloc_wo_spec
= true;
7380 gfc_error ("Array specification or array-valued SOURCE= "
7381 "expression required in ALLOCATE statement at %L",
7388 gfc_error ("Array specification required in ALLOCATE statement "
7389 "at %L", &e
->where
);
7394 /* Make sure that the array section reference makes sense in the
7395 context of an ALLOCATE specification. */
7400 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7401 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7403 gfc_error ("Coarray specification required in ALLOCATE statement "
7404 "at %L", &e
->where
);
7408 for (i
= 0; i
< ar
->dimen
; i
++)
7410 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7413 switch (ar
->dimen_type
[i
])
7419 if (ar
->start
[i
] != NULL
7420 && ar
->end
[i
] != NULL
7421 && ar
->stride
[i
] == NULL
)
7429 case DIMEN_THIS_IMAGE
:
7430 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7436 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7438 sym
= a
->expr
->symtree
->n
.sym
;
7440 /* TODO - check derived type components. */
7441 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7444 if ((ar
->start
[i
] != NULL
7445 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7446 || (ar
->end
[i
] != NULL
7447 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7449 gfc_error ("%qs must not appear in the array specification at "
7450 "%L in the same ALLOCATE statement where it is "
7451 "itself allocated", sym
->name
, &ar
->where
);
7457 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7459 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7460 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7462 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7464 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7465 "statement at %L", &e
->where
);
7471 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7472 && ar
->stride
[i
] == NULL
)
7475 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7489 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7491 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7492 gfc_alloc
*a
, *p
, *q
;
7495 errmsg
= code
->expr2
;
7497 /* Check the stat variable. */
7500 gfc_check_vardef_context (stat
, false, false, false,
7501 _("STAT variable"));
7503 if ((stat
->ts
.type
!= BT_INTEGER
7504 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7505 || stat
->ref
->type
== REF_COMPONENT
)))
7507 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7508 "variable", &stat
->where
);
7510 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7511 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7513 gfc_ref
*ref1
, *ref2
;
7516 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7517 ref1
= ref1
->next
, ref2
= ref2
->next
)
7519 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7521 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7530 gfc_error ("Stat-variable at %L shall not be %sd within "
7531 "the same %s statement", &stat
->where
, fcn
, fcn
);
7537 /* Check the errmsg variable. */
7541 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7544 gfc_check_vardef_context (errmsg
, false, false, false,
7545 _("ERRMSG variable"));
7547 if ((errmsg
->ts
.type
!= BT_CHARACTER
7549 && (errmsg
->ref
->type
== REF_ARRAY
7550 || errmsg
->ref
->type
== REF_COMPONENT
)))
7551 || errmsg
->rank
> 0 )
7552 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7553 "variable", &errmsg
->where
);
7555 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7556 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7558 gfc_ref
*ref1
, *ref2
;
7561 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7562 ref1
= ref1
->next
, ref2
= ref2
->next
)
7564 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7566 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7575 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7576 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7582 /* Check that an allocate-object appears only once in the statement. */
7584 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7587 for (q
= p
->next
; q
; q
= q
->next
)
7590 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7592 /* This is a potential collision. */
7593 gfc_ref
*pr
= pe
->ref
;
7594 gfc_ref
*qr
= qe
->ref
;
7596 /* Follow the references until
7597 a) They start to differ, in which case there is no error;
7598 you can deallocate a%b and a%c in a single statement
7599 b) Both of them stop, which is an error
7600 c) One of them stops, which is also an error. */
7603 if (pr
== NULL
&& qr
== NULL
)
7605 gfc_error ("Allocate-object at %L also appears at %L",
7606 &pe
->where
, &qe
->where
);
7609 else if (pr
!= NULL
&& qr
== NULL
)
7611 gfc_error ("Allocate-object at %L is subobject of"
7612 " object at %L", &pe
->where
, &qe
->where
);
7615 else if (pr
== NULL
&& qr
!= NULL
)
7617 gfc_error ("Allocate-object at %L is subobject of"
7618 " object at %L", &qe
->where
, &pe
->where
);
7621 /* Here, pr != NULL && qr != NULL */
7622 gcc_assert(pr
->type
== qr
->type
);
7623 if (pr
->type
== REF_ARRAY
)
7625 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7627 gcc_assert (qr
->type
== REF_ARRAY
);
7629 if (pr
->next
&& qr
->next
)
7632 gfc_array_ref
*par
= &(pr
->u
.ar
);
7633 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7635 for (i
=0; i
<par
->dimen
; i
++)
7637 if ((par
->start
[i
] != NULL
7638 || qar
->start
[i
] != NULL
)
7639 && gfc_dep_compare_expr (par
->start
[i
],
7640 qar
->start
[i
]) != 0)
7647 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7660 if (strcmp (fcn
, "ALLOCATE") == 0)
7662 bool arr_alloc_wo_spec
= false;
7664 /* Resolving the expr3 in the loop over all objects to allocate would
7665 execute loop invariant code for each loop item. Therefore do it just
7667 if (code
->expr3
&& code
->expr3
->mold
7668 && code
->expr3
->ts
.type
== BT_DERIVED
)
7670 /* Default initialization via MOLD (non-polymorphic). */
7671 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7674 gfc_resolve_expr (rhs
);
7675 gfc_free_expr (code
->expr3
);
7679 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7680 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7682 if (arr_alloc_wo_spec
&& code
->expr3
)
7684 /* Mark the allocate to have to take the array specification
7686 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7691 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7692 resolve_deallocate_expr (a
->expr
);
7697 /************ SELECT CASE resolution subroutines ************/
7699 /* Callback function for our mergesort variant. Determines interval
7700 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7701 op1 > op2. Assumes we're not dealing with the default case.
7702 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7703 There are nine situations to check. */
7706 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7710 if (op1
->low
== NULL
) /* op1 = (:L) */
7712 /* op2 = (:N), so overlap. */
7714 /* op2 = (M:) or (M:N), L < M */
7715 if (op2
->low
!= NULL
7716 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7719 else if (op1
->high
== NULL
) /* op1 = (K:) */
7721 /* op2 = (M:), so overlap. */
7723 /* op2 = (:N) or (M:N), K > N */
7724 if (op2
->high
!= NULL
7725 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7728 else /* op1 = (K:L) */
7730 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7731 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7733 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7734 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7736 else /* op2 = (M:N) */
7740 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7743 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7752 /* Merge-sort a double linked case list, detecting overlap in the
7753 process. LIST is the head of the double linked case list before it
7754 is sorted. Returns the head of the sorted list if we don't see any
7755 overlap, or NULL otherwise. */
7758 check_case_overlap (gfc_case
*list
)
7760 gfc_case
*p
, *q
, *e
, *tail
;
7761 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7763 /* If the passed list was empty, return immediately. */
7770 /* Loop unconditionally. The only exit from this loop is a return
7771 statement, when we've finished sorting the case list. */
7778 /* Count the number of merges we do in this pass. */
7781 /* Loop while there exists a merge to be done. */
7786 /* Count this merge. */
7789 /* Cut the list in two pieces by stepping INSIZE places
7790 forward in the list, starting from P. */
7793 for (i
= 0; i
< insize
; i
++)
7802 /* Now we have two lists. Merge them! */
7803 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7805 /* See from which the next case to merge comes from. */
7808 /* P is empty so the next case must come from Q. */
7813 else if (qsize
== 0 || q
== NULL
)
7822 cmp
= compare_cases (p
, q
);
7825 /* The whole case range for P is less than the
7833 /* The whole case range for Q is greater than
7834 the case range for P. */
7841 /* The cases overlap, or they are the same
7842 element in the list. Either way, we must
7843 issue an error and get the next case from P. */
7844 /* FIXME: Sort P and Q by line number. */
7845 gfc_error ("CASE label at %L overlaps with CASE "
7846 "label at %L", &p
->where
, &q
->where
);
7854 /* Add the next element to the merged list. */
7863 /* P has now stepped INSIZE places along, and so has Q. So
7864 they're the same. */
7869 /* If we have done only one merge or none at all, we've
7870 finished sorting the cases. */
7879 /* Otherwise repeat, merging lists twice the size. */
7885 /* Check to see if an expression is suitable for use in a CASE statement.
7886 Makes sure that all case expressions are scalar constants of the same
7887 type. Return false if anything is wrong. */
7890 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7892 if (e
== NULL
) return true;
7894 if (e
->ts
.type
!= case_expr
->ts
.type
)
7896 gfc_error ("Expression in CASE statement at %L must be of type %s",
7897 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7901 /* C805 (R808) For a given case-construct, each case-value shall be of
7902 the same type as case-expr. For character type, length differences
7903 are allowed, but the kind type parameters shall be the same. */
7905 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7907 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7908 &e
->where
, case_expr
->ts
.kind
);
7912 /* Convert the case value kind to that of case expression kind,
7915 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7916 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7920 gfc_error ("Expression in CASE statement at %L must be scalar",
7929 /* Given a completely parsed select statement, we:
7931 - Validate all expressions and code within the SELECT.
7932 - Make sure that the selection expression is not of the wrong type.
7933 - Make sure that no case ranges overlap.
7934 - Eliminate unreachable cases and unreachable code resulting from
7935 removing case labels.
7937 The standard does allow unreachable cases, e.g. CASE (5:3). But
7938 they are a hassle for code generation, and to prevent that, we just
7939 cut them out here. This is not necessary for overlapping cases
7940 because they are illegal and we never even try to generate code.
7942 We have the additional caveat that a SELECT construct could have
7943 been a computed GOTO in the source code. Fortunately we can fairly
7944 easily work around that here: The case_expr for a "real" SELECT CASE
7945 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7946 we have to do is make sure that the case_expr is a scalar integer
7950 resolve_select (gfc_code
*code
, bool select_type
)
7953 gfc_expr
*case_expr
;
7954 gfc_case
*cp
, *default_case
, *tail
, *head
;
7955 int seen_unreachable
;
7961 if (code
->expr1
== NULL
)
7963 /* This was actually a computed GOTO statement. */
7964 case_expr
= code
->expr2
;
7965 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7966 gfc_error ("Selection expression in computed GOTO statement "
7967 "at %L must be a scalar integer expression",
7970 /* Further checking is not necessary because this SELECT was built
7971 by the compiler, so it should always be OK. Just move the
7972 case_expr from expr2 to expr so that we can handle computed
7973 GOTOs as normal SELECTs from here on. */
7974 code
->expr1
= code
->expr2
;
7979 case_expr
= code
->expr1
;
7980 type
= case_expr
->ts
.type
;
7983 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7985 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7986 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7988 /* Punt. Going on here just produce more garbage error messages. */
7993 if (!select_type
&& case_expr
->rank
!= 0)
7995 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7996 "expression", &case_expr
->where
);
8002 /* Raise a warning if an INTEGER case value exceeds the range of
8003 the case-expr. Later, all expressions will be promoted to the
8004 largest kind of all case-labels. */
8006 if (type
== BT_INTEGER
)
8007 for (body
= code
->block
; body
; body
= body
->block
)
8008 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8011 && gfc_check_integer_range (cp
->low
->value
.integer
,
8012 case_expr
->ts
.kind
) != ARITH_OK
)
8013 gfc_warning (0, "Expression in CASE statement at %L is "
8014 "not in the range of %s", &cp
->low
->where
,
8015 gfc_typename (&case_expr
->ts
));
8018 && cp
->low
!= cp
->high
8019 && gfc_check_integer_range (cp
->high
->value
.integer
,
8020 case_expr
->ts
.kind
) != ARITH_OK
)
8021 gfc_warning (0, "Expression in CASE statement at %L is "
8022 "not in the range of %s", &cp
->high
->where
,
8023 gfc_typename (&case_expr
->ts
));
8026 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8027 of the SELECT CASE expression and its CASE values. Walk the lists
8028 of case values, and if we find a mismatch, promote case_expr to
8029 the appropriate kind. */
8031 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8033 for (body
= code
->block
; body
; body
= body
->block
)
8035 /* Walk the case label list. */
8036 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8038 /* Intercept the DEFAULT case. It does not have a kind. */
8039 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8042 /* Unreachable case ranges are discarded, so ignore. */
8043 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8044 && cp
->low
!= cp
->high
8045 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8049 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8050 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8052 if (cp
->high
!= NULL
8053 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8054 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8059 /* Assume there is no DEFAULT case. */
8060 default_case
= NULL
;
8065 for (body
= code
->block
; body
; body
= body
->block
)
8067 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8069 seen_unreachable
= 0;
8071 /* Walk the case label list, making sure that all case labels
8073 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8075 /* Count the number of cases in the whole construct. */
8078 /* Intercept the DEFAULT case. */
8079 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8081 if (default_case
!= NULL
)
8083 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8084 "by a second DEFAULT CASE at %L",
8085 &default_case
->where
, &cp
->where
);
8096 /* Deal with single value cases and case ranges. Errors are
8097 issued from the validation function. */
8098 if (!validate_case_label_expr (cp
->low
, case_expr
)
8099 || !validate_case_label_expr (cp
->high
, case_expr
))
8105 if (type
== BT_LOGICAL
8106 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8107 || cp
->low
!= cp
->high
))
8109 gfc_error ("Logical range in CASE statement at %L is not "
8110 "allowed", &cp
->low
->where
);
8115 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8118 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8119 if (value
& seen_logical
)
8121 gfc_error ("Constant logical value in CASE statement "
8122 "is repeated at %L",
8127 seen_logical
|= value
;
8130 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8131 && cp
->low
!= cp
->high
8132 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8134 if (warn_surprising
)
8135 gfc_warning (OPT_Wsurprising
,
8136 "Range specification at %L can never be matched",
8139 cp
->unreachable
= 1;
8140 seen_unreachable
= 1;
8144 /* If the case range can be matched, it can also overlap with
8145 other cases. To make sure it does not, we put it in a
8146 double linked list here. We sort that with a merge sort
8147 later on to detect any overlapping cases. */
8151 head
->right
= head
->left
= NULL
;
8156 tail
->right
->left
= tail
;
8163 /* It there was a failure in the previous case label, give up
8164 for this case label list. Continue with the next block. */
8168 /* See if any case labels that are unreachable have been seen.
8169 If so, we eliminate them. This is a bit of a kludge because
8170 the case lists for a single case statement (label) is a
8171 single forward linked lists. */
8172 if (seen_unreachable
)
8174 /* Advance until the first case in the list is reachable. */
8175 while (body
->ext
.block
.case_list
!= NULL
8176 && body
->ext
.block
.case_list
->unreachable
)
8178 gfc_case
*n
= body
->ext
.block
.case_list
;
8179 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8181 gfc_free_case_list (n
);
8184 /* Strip all other unreachable cases. */
8185 if (body
->ext
.block
.case_list
)
8187 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8189 if (cp
->next
->unreachable
)
8191 gfc_case
*n
= cp
->next
;
8192 cp
->next
= cp
->next
->next
;
8194 gfc_free_case_list (n
);
8201 /* See if there were overlapping cases. If the check returns NULL,
8202 there was overlap. In that case we don't do anything. If head
8203 is non-NULL, we prepend the DEFAULT case. The sorted list can
8204 then used during code generation for SELECT CASE constructs with
8205 a case expression of a CHARACTER type. */
8208 head
= check_case_overlap (head
);
8210 /* Prepend the default_case if it is there. */
8211 if (head
!= NULL
&& default_case
)
8213 default_case
->left
= NULL
;
8214 default_case
->right
= head
;
8215 head
->left
= default_case
;
8219 /* Eliminate dead blocks that may be the result if we've seen
8220 unreachable case labels for a block. */
8221 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8223 if (body
->block
->ext
.block
.case_list
== NULL
)
8225 /* Cut the unreachable block from the code chain. */
8226 gfc_code
*c
= body
->block
;
8227 body
->block
= c
->block
;
8229 /* Kill the dead block, but not the blocks below it. */
8231 gfc_free_statements (c
);
8235 /* More than two cases is legal but insane for logical selects.
8236 Issue a warning for it. */
8237 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8238 gfc_warning (OPT_Wsurprising
,
8239 "Logical SELECT CASE block at %L has more that two cases",
8244 /* Check if a derived type is extensible. */
8247 gfc_type_is_extensible (gfc_symbol
*sym
)
8249 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8250 || (sym
->attr
.is_class
8251 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8256 resolve_types (gfc_namespace
*ns
);
8258 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8259 correct as well as possibly the array-spec. */
8262 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8266 gcc_assert (sym
->assoc
);
8267 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8269 /* If this is for SELECT TYPE, the target may not yet be set. In that
8270 case, return. Resolution will be called later manually again when
8272 target
= sym
->assoc
->target
;
8275 gcc_assert (!sym
->assoc
->dangling
);
8277 if (resolve_target
&& !gfc_resolve_expr (target
))
8280 /* For variable targets, we get some attributes from the target. */
8281 if (target
->expr_type
== EXPR_VARIABLE
)
8285 gcc_assert (target
->symtree
);
8286 tsym
= target
->symtree
->n
.sym
;
8288 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8289 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8291 sym
->attr
.target
= tsym
->attr
.target
8292 || gfc_expr_attr (target
).pointer
;
8293 if (is_subref_array (target
))
8294 sym
->attr
.subref_array_pointer
= 1;
8297 /* Get type if this was not already set. Note that it can be
8298 some other type than the target in case this is a SELECT TYPE
8299 selector! So we must not update when the type is already there. */
8300 if (sym
->ts
.type
== BT_UNKNOWN
)
8301 sym
->ts
= target
->ts
;
8302 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8304 /* See if this is a valid association-to-variable. */
8305 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8306 && !gfc_has_vector_subscript (target
));
8308 /* Finally resolve if this is an array or not. */
8309 if (sym
->attr
.dimension
&& target
->rank
== 0)
8311 /* primary.c makes the assumption that a reference to an associate
8312 name followed by a left parenthesis is an array reference. */
8313 if (sym
->ts
.type
!= BT_CHARACTER
)
8314 gfc_error ("Associate-name %qs at %L is used as array",
8315 sym
->name
, &sym
->declared_at
);
8316 sym
->attr
.dimension
= 0;
8321 /* We cannot deal with class selectors that need temporaries. */
8322 if (target
->ts
.type
== BT_CLASS
8323 && gfc_ref_needs_temporary_p (target
->ref
))
8325 gfc_error ("CLASS selector at %L needs a temporary which is not "
8326 "yet implemented", &target
->where
);
8330 if (target
->ts
.type
== BT_CLASS
)
8331 gfc_fix_class_refs (target
);
8333 if (target
->rank
!= 0)
8336 /* The rank may be incorrectly guessed at parsing, therefore make sure
8337 it is corrected now. */
8338 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8341 sym
->as
= gfc_get_array_spec ();
8343 as
->rank
= target
->rank
;
8344 as
->type
= AS_DEFERRED
;
8345 as
->corank
= gfc_get_corank (target
);
8346 sym
->attr
.dimension
= 1;
8347 if (as
->corank
!= 0)
8348 sym
->attr
.codimension
= 1;
8353 /* target's rank is 0, but the type of the sym is still array valued,
8354 which has to be corrected. */
8355 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8358 symbol_attribute attr
;
8359 /* The associated variable's type is still the array type
8360 correct this now. */
8361 gfc_typespec
*ts
= &target
->ts
;
8364 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8369 ts
= &ref
->u
.c
.component
->ts
;
8372 if (ts
->type
== BT_CLASS
)
8373 ts
= &ts
->u
.derived
->components
->ts
;
8379 /* Create a scalar instance of the current class type. Because the
8380 rank of a class array goes into its name, the type has to be
8381 rebuild. The alternative of (re-)setting just the attributes
8382 and as in the current type, destroys the type also in other
8386 sym
->ts
.type
= BT_CLASS
;
8387 attr
= CLASS_DATA (sym
)->attr
;
8389 attr
.associate_var
= 1;
8390 attr
.dimension
= attr
.codimension
= 0;
8391 attr
.class_pointer
= 1;
8392 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8394 /* Make sure the _vptr is set. */
8395 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8396 if (c
->ts
.u
.derived
== NULL
)
8397 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8398 CLASS_DATA (sym
)->attr
.pointer
= 1;
8399 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8400 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8401 gfc_commit_symbol (sym
->ts
.u
.derived
);
8402 /* _vptr now has the _vtab in it, change it to the _vtype. */
8403 if (c
->ts
.u
.derived
->attr
.vtab
)
8404 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8405 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8406 resolve_types (c
->ts
.u
.derived
->ns
);
8410 /* Mark this as an associate variable. */
8411 sym
->attr
.associate_var
= 1;
8413 /* Fix up the type-spec for CHARACTER types. */
8414 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8417 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8419 if (!sym
->ts
.u
.cl
->length
)
8420 sym
->ts
.u
.cl
->length
8421 = gfc_get_int_expr (gfc_default_integer_kind
,
8422 NULL
, target
->value
.character
.length
);
8425 /* If the target is a good class object, so is the associate variable. */
8426 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8427 sym
->attr
.class_ok
= 1;
8431 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8432 array reference, where necessary. The symbols are artificial and so
8433 the dimension attribute and arrayspec can also be set. In addition,
8434 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8435 This is corrected here as well.*/
8438 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8439 int rank
, gfc_ref
*ref
)
8441 gfc_ref
*nref
= (*expr1
)->ref
;
8442 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8443 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8444 (*expr1
)->rank
= rank
;
8445 if (sym1
->ts
.type
== BT_CLASS
)
8447 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8448 (*expr1
)->ts
= sym1
->ts
;
8450 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8451 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8452 CLASS_DATA (sym1
)->as
8453 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8457 sym1
->attr
.dimension
= 1;
8458 if (sym1
->as
== NULL
&& sym2
)
8459 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8462 for (; nref
; nref
= nref
->next
)
8463 if (nref
->next
== NULL
)
8466 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8467 nref
->next
= gfc_copy_ref (ref
);
8468 else if (ref
&& !nref
)
8469 (*expr1
)->ref
= gfc_copy_ref (ref
);
8474 build_loc_call (gfc_expr
*sym_expr
)
8477 loc_call
= gfc_get_expr ();
8478 loc_call
->expr_type
= EXPR_FUNCTION
;
8479 gfc_get_sym_tree ("loc", gfc_current_ns
, &loc_call
->symtree
, false);
8480 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8481 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8482 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8483 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8484 loc_call
->ts
.type
= BT_INTEGER
;
8485 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8486 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8487 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8488 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8489 loc_call
->where
= sym_expr
->where
;
8493 /* Resolve a SELECT TYPE statement. */
8496 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8498 gfc_symbol
*selector_type
;
8499 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8500 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8503 char name
[GFC_MAX_SYMBOL_LEN
];
8508 gfc_ref
* ref
= NULL
;
8509 gfc_expr
*selector_expr
= NULL
;
8511 ns
= code
->ext
.block
.ns
;
8514 /* Check for F03:C813. */
8515 if (code
->expr1
->ts
.type
!= BT_CLASS
8516 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8518 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8519 "at %L", &code
->loc
);
8523 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8528 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8529 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8530 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8532 /* F2008: C803 The selector expression must not be coindexed. */
8533 if (gfc_is_coindexed (code
->expr2
))
8535 gfc_error ("Selector at %L must not be coindexed",
8536 &code
->expr2
->where
);
8543 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8545 if (gfc_is_coindexed (code
->expr1
))
8547 gfc_error ("Selector at %L must not be coindexed",
8548 &code
->expr1
->where
);
8553 /* Loop over TYPE IS / CLASS IS cases. */
8554 for (body
= code
->block
; body
; body
= body
->block
)
8556 c
= body
->ext
.block
.case_list
;
8560 /* Check for repeated cases. */
8561 for (tail
= code
->block
; tail
; tail
= tail
->block
)
8563 gfc_case
*d
= tail
->ext
.block
.case_list
;
8567 if (c
->ts
.type
== d
->ts
.type
8568 && ((c
->ts
.type
== BT_DERIVED
8569 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
8570 && !strcmp (c
->ts
.u
.derived
->name
,
8571 d
->ts
.u
.derived
->name
))
8572 || c
->ts
.type
== BT_UNKNOWN
8573 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8574 && c
->ts
.kind
== d
->ts
.kind
)))
8576 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8577 &c
->where
, &d
->where
);
8583 /* Check F03:C815. */
8584 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8585 && !selector_type
->attr
.unlimited_polymorphic
8586 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8588 gfc_error ("Derived type %qs at %L must be extensible",
8589 c
->ts
.u
.derived
->name
, &c
->where
);
8594 /* Check F03:C816. */
8595 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8596 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8597 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8599 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8600 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8601 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8603 gfc_error ("Unexpected intrinsic type %qs at %L",
8604 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8609 /* Check F03:C814. */
8610 if (c
->ts
.type
== BT_CHARACTER
8611 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
8613 gfc_error ("The type-spec at %L shall specify that each length "
8614 "type parameter is assumed", &c
->where
);
8619 /* Intercept the DEFAULT case. */
8620 if (c
->ts
.type
== BT_UNKNOWN
)
8622 /* Check F03:C818. */
8625 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8626 "by a second DEFAULT CASE at %L",
8627 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8632 default_case
= body
;
8639 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8640 target if present. If there are any EXIT statements referring to the
8641 SELECT TYPE construct, this is no problem because the gfc_code
8642 reference stays the same and EXIT is equally possible from the BLOCK
8643 it is changed to. */
8644 code
->op
= EXEC_BLOCK
;
8647 gfc_association_list
* assoc
;
8649 assoc
= gfc_get_association_list ();
8650 assoc
->st
= code
->expr1
->symtree
;
8651 assoc
->target
= gfc_copy_expr (code
->expr2
);
8652 assoc
->target
->where
= code
->expr2
->where
;
8653 /* assoc->variable will be set by resolve_assoc_var. */
8655 code
->ext
.block
.assoc
= assoc
;
8656 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8658 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8661 code
->ext
.block
.assoc
= NULL
;
8663 /* Ensure that the selector rank and arrayspec are available to
8664 correct expressions in which they might be missing. */
8665 if (code
->expr2
&& code
->expr2
->rank
)
8667 rank
= code
->expr2
->rank
;
8668 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
8669 if (ref
->next
== NULL
)
8671 if (ref
&& ref
->type
== REF_ARRAY
)
8672 ref
= gfc_copy_ref (ref
);
8674 /* Fixup expr1 if necessary. */
8676 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
8678 else if (code
->expr1
->rank
)
8680 rank
= code
->expr1
->rank
;
8681 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
8682 if (ref
->next
== NULL
)
8684 if (ref
&& ref
->type
== REF_ARRAY
)
8685 ref
= gfc_copy_ref (ref
);
8688 /* Add EXEC_SELECT to switch on type. */
8689 new_st
= gfc_get_code (code
->op
);
8690 new_st
->expr1
= code
->expr1
;
8691 new_st
->expr2
= code
->expr2
;
8692 new_st
->block
= code
->block
;
8693 code
->expr1
= code
->expr2
= NULL
;
8698 ns
->code
->next
= new_st
;
8700 code
->op
= EXEC_SELECT_TYPE
;
8702 /* Use the intrinsic LOC function to generate an integer expression
8703 for the vtable of the selector. Note that the rank of the selector
8704 expression has to be set to zero. */
8705 gfc_add_vptr_component (code
->expr1
);
8706 code
->expr1
->rank
= 0;
8707 code
->expr1
= build_loc_call (code
->expr1
);
8708 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
8710 /* Loop over TYPE IS / CLASS IS cases. */
8711 for (body
= code
->block
; body
; body
= body
->block
)
8715 c
= body
->ext
.block
.case_list
;
8717 /* Generate an index integer expression for address of the
8718 TYPE/CLASS vtable and store it in c->low. The hash expression
8719 is stored in c->high and is used to resolve intrinsic cases. */
8720 if (c
->ts
.type
!= BT_UNKNOWN
)
8722 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8724 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8726 c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8727 c
->ts
.u
.derived
->hash_value
);
8731 vtab
= gfc_find_vtab (&c
->ts
);
8732 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
8733 e
= CLASS_DATA (vtab
)->initializer
;
8734 c
->high
= gfc_copy_expr (e
);
8737 e
= gfc_lval_expr_from_sym (vtab
);
8738 c
->low
= build_loc_call (e
);
8743 /* Associate temporary to selector. This should only be done
8744 when this case is actually true, so build a new ASSOCIATE
8745 that does precisely this here (instead of using the
8748 if (c
->ts
.type
== BT_CLASS
)
8749 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8750 else if (c
->ts
.type
== BT_DERIVED
)
8751 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8752 else if (c
->ts
.type
== BT_CHARACTER
)
8754 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8755 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8756 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8757 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8758 charlen
, c
->ts
.kind
);
8761 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8764 st
= gfc_find_symtree (ns
->sym_root
, name
);
8765 gcc_assert (st
->n
.sym
->assoc
);
8766 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
8767 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
8768 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8770 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8771 /* Fixup the target expression if necessary. */
8773 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
8776 new_st
= gfc_get_code (EXEC_BLOCK
);
8777 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8778 new_st
->ext
.block
.ns
->code
= body
->next
;
8779 body
->next
= new_st
;
8781 /* Chain in the new list only if it is marked as dangling. Otherwise
8782 there is a CASE label overlap and this is already used. Just ignore,
8783 the error is diagnosed elsewhere. */
8784 if (st
->n
.sym
->assoc
->dangling
)
8786 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8787 st
->n
.sym
->assoc
->dangling
= 0;
8790 resolve_assoc_var (st
->n
.sym
, false);
8793 /* Take out CLASS IS cases for separate treatment. */
8795 while (body
&& body
->block
)
8797 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8799 /* Add to class_is list. */
8800 if (class_is
== NULL
)
8802 class_is
= body
->block
;
8807 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8808 tail
->block
= body
->block
;
8811 /* Remove from EXEC_SELECT list. */
8812 body
->block
= body
->block
->block
;
8825 /* Add a default case to hold the CLASS IS cases. */
8826 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8827 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8829 tail
->ext
.block
.case_list
= gfc_get_case ();
8830 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8832 default_case
= tail
;
8835 /* More than one CLASS IS block? */
8836 if (class_is
->block
)
8840 /* Sort CLASS IS blocks by extension level. */
8844 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8847 /* F03:C817 (check for doubles). */
8848 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8849 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8851 gfc_error ("Double CLASS IS block in SELECT TYPE "
8853 &c2
->ext
.block
.case_list
->where
);
8856 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8857 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8860 (*c1
)->block
= c2
->block
;
8870 /* Generate IF chain. */
8871 if_st
= gfc_get_code (EXEC_IF
);
8873 for (body
= class_is
; body
; body
= body
->block
)
8875 new_st
->block
= gfc_get_code (EXEC_IF
);
8876 new_st
= new_st
->block
;
8877 /* Set up IF condition: Call _gfortran_is_extension_of. */
8878 new_st
->expr1
= gfc_get_expr ();
8879 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8880 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8881 new_st
->expr1
->ts
.kind
= 4;
8882 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8883 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8884 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8885 /* Set up arguments. */
8886 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8887 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
8888 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8889 new_st
->expr1
->where
= code
->loc
;
8890 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8891 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8892 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8893 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8894 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8895 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
8896 new_st
->next
= body
->next
;
8898 if (default_case
->next
)
8900 new_st
->block
= gfc_get_code (EXEC_IF
);
8901 new_st
= new_st
->block
;
8902 new_st
->next
= default_case
->next
;
8905 /* Replace CLASS DEFAULT code by the IF chain. */
8906 default_case
->next
= if_st
;
8909 /* Resolve the internal code. This can not be done earlier because
8910 it requires that the sym->assoc of selectors is set already. */
8911 gfc_current_ns
= ns
;
8912 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8913 gfc_current_ns
= old_ns
;
8920 /* Resolve a transfer statement. This is making sure that:
8921 -- a derived type being transferred has only non-pointer components
8922 -- a derived type being transferred doesn't have private components, unless
8923 it's being transferred from the module where the type was defined
8924 -- we're not trying to transfer a whole assumed size array. */
8927 resolve_transfer (gfc_code
*code
)
8930 gfc_symbol
*sym
, *derived
;
8934 bool formatted
= false;
8935 gfc_dt
*dt
= code
->ext
.dt
;
8936 gfc_symbol
*dtio_sub
= NULL
;
8940 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8941 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8942 exp
= exp
->value
.op
.op1
;
8944 if (exp
&& exp
->expr_type
== EXPR_NULL
8947 gfc_error ("Invalid context for NULL () intrinsic at %L",
8952 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8953 && exp
->expr_type
!= EXPR_FUNCTION
8954 && exp
->expr_type
!= EXPR_STRUCTURE
))
8957 /* If we are reading, the variable will be changed. Note that
8958 code->ext.dt may be NULL if the TRANSFER is related to
8959 an INQUIRE statement -- but in this case, we are not reading, either. */
8960 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
8961 && !gfc_check_vardef_context (exp
, false, false, false,
8965 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8967 /* Go to actual component transferred. */
8968 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8969 if (ref
->type
== REF_COMPONENT
)
8970 ts
= &ref
->u
.c
.component
->ts
;
8972 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
8973 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
8975 if (ts
->type
== BT_DERIVED
)
8976 derived
= ts
->u
.derived
;
8978 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
8980 if (dt
->format_expr
)
8983 fmt
= gfc_widechar_to_char (dt
->format_expr
->value
.character
.string
,
8985 if (strtok (fmt
, "DT") != NULL
)
8988 else if (dt
->format_label
== &format_asterisk
)
8990 /* List directed io must call the formatted DTIO procedure. */
8994 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
8995 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
8996 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
8998 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9001 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9002 /* Check to see if this is a nested DTIO call, with the
9003 dummy as the io-list object. */
9004 if (sym
&& sym
== dtio_sub
&& sym
->formal
9005 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9006 && exp
->ref
== NULL
)
9008 if (!sym
->attr
.recursive
)
9010 gfc_error ("DTIO %s procedure at %L must be recursive",
9011 sym
->name
, &sym
->declared_at
);
9018 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9020 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9021 "it is processed by a defined input/output procedure",
9026 if (ts
->type
== BT_DERIVED
)
9028 /* Check that transferred derived type doesn't contain POINTER
9029 components unless it is processed by a defined input/output
9031 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9033 gfc_error ("Data transfer element at %L cannot have POINTER "
9034 "components unless it is processed by a defined "
9035 "input/output procedure", &code
->loc
);
9040 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9042 gfc_error ("Data transfer element at %L cannot have "
9043 "procedure pointer components", &code
->loc
);
9047 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9049 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9050 "components unless it is processed by a defined "
9051 "input/output procedure", &code
->loc
);
9055 /* C_PTR and C_FUNPTR have private components which means they can not
9056 be printed. However, if -std=gnu and not -pedantic, allow
9057 the component to be printed to help debugging. */
9058 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9060 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9061 "cannot have PRIVATE components", &code
->loc
))
9064 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9066 gfc_error ("Data transfer element at %L cannot have "
9067 "PRIVATE components unless it is processed by "
9068 "a defined input/output procedure", &code
->loc
);
9073 if (exp
->expr_type
== EXPR_STRUCTURE
)
9076 sym
= exp
->symtree
->n
.sym
;
9078 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9079 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9081 gfc_error ("Data transfer element at %L cannot be a full reference to "
9082 "an assumed-size array", &code
->loc
);
9088 /*********** Toplevel code resolution subroutines ***********/
9090 /* Find the set of labels that are reachable from this block. We also
9091 record the last statement in each block. */
9094 find_reachable_labels (gfc_code
*block
)
9101 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
9103 /* Collect labels in this block. We don't keep those corresponding
9104 to END {IF|SELECT}, these are checked in resolve_branch by going
9105 up through the code_stack. */
9106 for (c
= block
; c
; c
= c
->next
)
9108 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9109 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9112 /* Merge with labels from parent block. */
9115 gcc_assert (cs_base
->prev
->reachable_labels
);
9116 bitmap_ior_into (cs_base
->reachable_labels
,
9117 cs_base
->prev
->reachable_labels
);
9123 resolve_lock_unlock_event (gfc_code
*code
)
9125 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9126 && code
->expr1
->value
.function
.isym
9127 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9128 remove_caf_get_intrinsic (code
->expr1
);
9130 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9131 && (code
->expr1
->ts
.type
!= BT_DERIVED
9132 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9133 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9134 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9135 || code
->expr1
->rank
!= 0
9136 || (!gfc_is_coarray (code
->expr1
) &&
9137 !gfc_is_coindexed (code
->expr1
))))
9138 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9139 &code
->expr1
->where
);
9140 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9141 && (code
->expr1
->ts
.type
!= BT_DERIVED
9142 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9143 || code
->expr1
->ts
.u
.derived
->from_intmod
9144 != INTMOD_ISO_FORTRAN_ENV
9145 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9146 != ISOFORTRAN_EVENT_TYPE
9147 || code
->expr1
->rank
!= 0))
9148 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9149 &code
->expr1
->where
);
9150 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9151 && !gfc_is_coindexed (code
->expr1
))
9152 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9153 &code
->expr1
->where
);
9154 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9155 gfc_error ("Event variable argument at %L must be a coarray but not "
9156 "coindexed", &code
->expr1
->where
);
9160 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9161 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9162 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9163 &code
->expr2
->where
);
9166 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9167 _("STAT variable")))
9172 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9173 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9174 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9175 &code
->expr3
->where
);
9178 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9179 _("ERRMSG variable")))
9182 /* Check for LOCK the ACQUIRED_LOCK. */
9183 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9184 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9185 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9186 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9187 "variable", &code
->expr4
->where
);
9189 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9190 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9191 _("ACQUIRED_LOCK variable")))
9194 /* Check for EVENT WAIT the UNTIL_COUNT. */
9195 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9197 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9198 || code
->expr4
->rank
!= 0)
9199 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9200 "expression", &code
->expr4
->where
);
9206 resolve_critical (gfc_code
*code
)
9208 gfc_symtree
*symtree
;
9209 gfc_symbol
*lock_type
;
9210 char name
[GFC_MAX_SYMBOL_LEN
];
9211 static int serial
= 0;
9213 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9216 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9217 GFC_PREFIX ("lock_type"));
9219 lock_type
= symtree
->n
.sym
;
9222 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9225 lock_type
= symtree
->n
.sym
;
9226 lock_type
->attr
.flavor
= FL_DERIVED
;
9227 lock_type
->attr
.zero_comp
= 1;
9228 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9229 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9232 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9233 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9236 code
->resolved_sym
= symtree
->n
.sym
;
9237 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9238 symtree
->n
.sym
->attr
.referenced
= 1;
9239 symtree
->n
.sym
->attr
.artificial
= 1;
9240 symtree
->n
.sym
->attr
.codimension
= 1;
9241 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9242 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9243 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9244 symtree
->n
.sym
->as
->corank
= 1;
9245 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9246 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9247 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9249 gfc_commit_symbols();
9254 resolve_sync (gfc_code
*code
)
9256 /* Check imageset. The * case matches expr1 == NULL. */
9259 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9260 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9261 "INTEGER expression", &code
->expr1
->where
);
9262 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9263 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9264 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9265 &code
->expr1
->where
);
9266 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9267 && gfc_simplify_expr (code
->expr1
, 0))
9269 gfc_constructor
*cons
;
9270 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9271 for (; cons
; cons
= gfc_constructor_next (cons
))
9272 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9273 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9274 gfc_error ("Imageset argument at %L must between 1 and "
9275 "num_images()", &cons
->expr
->where
);
9281 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9282 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9283 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9284 &code
->expr2
->where
);
9288 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9289 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9290 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9291 &code
->expr3
->where
);
9295 /* Given a branch to a label, see if the branch is conforming.
9296 The code node describes where the branch is located. */
9299 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9306 /* Step one: is this a valid branching target? */
9308 if (label
->defined
== ST_LABEL_UNKNOWN
)
9310 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9315 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9317 gfc_error ("Statement at %L is not a valid branch target statement "
9318 "for the branch statement at %L", &label
->where
, &code
->loc
);
9322 /* Step two: make sure this branch is not a branch to itself ;-) */
9324 if (code
->here
== label
)
9327 "Branch at %L may result in an infinite loop", &code
->loc
);
9331 /* Step three: See if the label is in the same block as the
9332 branching statement. The hard work has been done by setting up
9333 the bitmap reachable_labels. */
9335 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9337 /* Check now whether there is a CRITICAL construct; if so, check
9338 whether the label is still visible outside of the CRITICAL block,
9339 which is invalid. */
9340 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9342 if (stack
->current
->op
== EXEC_CRITICAL
9343 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9344 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9345 "label at %L", &code
->loc
, &label
->where
);
9346 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9347 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9348 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9349 "for label at %L", &code
->loc
, &label
->where
);
9355 /* Step four: If we haven't found the label in the bitmap, it may
9356 still be the label of the END of the enclosing block, in which
9357 case we find it by going up the code_stack. */
9359 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9361 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9363 if (stack
->current
->op
== EXEC_CRITICAL
)
9365 /* Note: A label at END CRITICAL does not leave the CRITICAL
9366 construct as END CRITICAL is still part of it. */
9367 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9368 " at %L", &code
->loc
, &label
->where
);
9371 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9373 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9374 "label at %L", &code
->loc
, &label
->where
);
9381 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9385 /* The label is not in an enclosing block, so illegal. This was
9386 allowed in Fortran 66, so we allow it as extension. No
9387 further checks are necessary in this case. */
9388 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9389 "as the GOTO statement at %L", &label
->where
,
9395 /* Check whether EXPR1 has the same shape as EXPR2. */
9398 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9400 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9401 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9402 bool result
= false;
9405 /* Compare the rank. */
9406 if (expr1
->rank
!= expr2
->rank
)
9409 /* Compare the size of each dimension. */
9410 for (i
=0; i
<expr1
->rank
; i
++)
9412 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9415 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9418 if (mpz_cmp (shape
[i
], shape2
[i
]))
9422 /* When either of the two expression is an assumed size array, we
9423 ignore the comparison of dimension sizes. */
9428 gfc_clear_shape (shape
, i
);
9429 gfc_clear_shape (shape2
, i
);
9434 /* Check whether a WHERE assignment target or a WHERE mask expression
9435 has the same shape as the outmost WHERE mask expression. */
9438 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9444 cblock
= code
->block
;
9446 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9447 In case of nested WHERE, only the outmost one is stored. */
9448 if (mask
== NULL
) /* outmost WHERE */
9450 else /* inner WHERE */
9457 /* Check if the mask-expr has a consistent shape with the
9458 outmost WHERE mask-expr. */
9459 if (!resolve_where_shape (cblock
->expr1
, e
))
9460 gfc_error ("WHERE mask at %L has inconsistent shape",
9461 &cblock
->expr1
->where
);
9464 /* the assignment statement of a WHERE statement, or the first
9465 statement in where-body-construct of a WHERE construct */
9466 cnext
= cblock
->next
;
9471 /* WHERE assignment statement */
9474 /* Check shape consistent for WHERE assignment target. */
9475 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9476 gfc_error ("WHERE assignment target at %L has "
9477 "inconsistent shape", &cnext
->expr1
->where
);
9481 case EXEC_ASSIGN_CALL
:
9482 resolve_call (cnext
);
9483 if (!cnext
->resolved_sym
->attr
.elemental
)
9484 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9485 &cnext
->ext
.actual
->expr
->where
);
9488 /* WHERE or WHERE construct is part of a where-body-construct */
9490 resolve_where (cnext
, e
);
9494 gfc_error ("Unsupported statement inside WHERE at %L",
9497 /* the next statement within the same where-body-construct */
9498 cnext
= cnext
->next
;
9500 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9501 cblock
= cblock
->block
;
9506 /* Resolve assignment in FORALL construct.
9507 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9508 FORALL index variables. */
9511 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9515 for (n
= 0; n
< nvar
; n
++)
9517 gfc_symbol
*forall_index
;
9519 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9521 /* Check whether the assignment target is one of the FORALL index
9523 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9524 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9525 gfc_error ("Assignment to a FORALL index variable at %L",
9526 &code
->expr1
->where
);
9529 /* If one of the FORALL index variables doesn't appear in the
9530 assignment variable, then there could be a many-to-one
9531 assignment. Emit a warning rather than an error because the
9532 mask could be resolving this problem. */
9533 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9534 gfc_warning (0, "The FORALL with index %qs is not used on the "
9535 "left side of the assignment at %L and so might "
9536 "cause multiple assignment to this object",
9537 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9543 /* Resolve WHERE statement in FORALL construct. */
9546 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9547 gfc_expr
**var_expr
)
9552 cblock
= code
->block
;
9555 /* the assignment statement of a WHERE statement, or the first
9556 statement in where-body-construct of a WHERE construct */
9557 cnext
= cblock
->next
;
9562 /* WHERE assignment statement */
9564 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9567 /* WHERE operator assignment statement */
9568 case EXEC_ASSIGN_CALL
:
9569 resolve_call (cnext
);
9570 if (!cnext
->resolved_sym
->attr
.elemental
)
9571 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9572 &cnext
->ext
.actual
->expr
->where
);
9575 /* WHERE or WHERE construct is part of a where-body-construct */
9577 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9581 gfc_error ("Unsupported statement inside WHERE at %L",
9584 /* the next statement within the same where-body-construct */
9585 cnext
= cnext
->next
;
9587 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9588 cblock
= cblock
->block
;
9593 /* Traverse the FORALL body to check whether the following errors exist:
9594 1. For assignment, check if a many-to-one assignment happens.
9595 2. For WHERE statement, check the WHERE body to see if there is any
9596 many-to-one assignment. */
9599 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9603 c
= code
->block
->next
;
9609 case EXEC_POINTER_ASSIGN
:
9610 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9613 case EXEC_ASSIGN_CALL
:
9617 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9618 there is no need to handle it here. */
9622 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9627 /* The next statement in the FORALL body. */
9633 /* Counts the number of iterators needed inside a forall construct, including
9634 nested forall constructs. This is used to allocate the needed memory
9635 in gfc_resolve_forall. */
9638 gfc_count_forall_iterators (gfc_code
*code
)
9640 int max_iters
, sub_iters
, current_iters
;
9641 gfc_forall_iterator
*fa
;
9643 gcc_assert(code
->op
== EXEC_FORALL
);
9647 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9650 code
= code
->block
->next
;
9654 if (code
->op
== EXEC_FORALL
)
9656 sub_iters
= gfc_count_forall_iterators (code
);
9657 if (sub_iters
> max_iters
)
9658 max_iters
= sub_iters
;
9663 return current_iters
+ max_iters
;
9667 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9668 gfc_resolve_forall_body to resolve the FORALL body. */
9671 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9673 static gfc_expr
**var_expr
;
9674 static int total_var
= 0;
9675 static int nvar
= 0;
9676 int i
, old_nvar
, tmp
;
9677 gfc_forall_iterator
*fa
;
9681 /* Start to resolve a FORALL construct */
9682 if (forall_save
== 0)
9684 /* Count the total number of FORALL indices in the nested FORALL
9685 construct in order to allocate the VAR_EXPR with proper size. */
9686 total_var
= gfc_count_forall_iterators (code
);
9688 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9689 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9692 /* The information about FORALL iterator, including FORALL indices start, end
9693 and stride. An outer FORALL indice cannot appear in start, end or stride. */
9694 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9696 /* Fortran 20008: C738 (R753). */
9697 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
9699 gfc_error ("FORALL index-name at %L must be a scalar variable "
9700 "of type integer", &fa
->var
->where
);
9704 /* Check if any outer FORALL index name is the same as the current
9706 for (i
= 0; i
< nvar
; i
++)
9708 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9709 gfc_error ("An outer FORALL construct already has an index "
9710 "with this name %L", &fa
->var
->where
);
9713 /* Record the current FORALL index. */
9714 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9718 /* No memory leak. */
9719 gcc_assert (nvar
<= total_var
);
9722 /* Resolve the FORALL body. */
9723 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9725 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9726 gfc_resolve_blocks (code
->block
, ns
);
9730 /* Free only the VAR_EXPRs allocated in this frame. */
9731 for (i
= nvar
; i
< tmp
; i
++)
9732 gfc_free_expr (var_expr
[i
]);
9736 /* We are in the outermost FORALL construct. */
9737 gcc_assert (forall_save
== 0);
9739 /* VAR_EXPR is not needed any more. */
9746 /* Resolve a BLOCK construct statement. */
9749 resolve_block_construct (gfc_code
* code
)
9751 /* Resolve the BLOCK's namespace. */
9752 gfc_resolve (code
->ext
.block
.ns
);
9754 /* For an ASSOCIATE block, the associations (and their targets) are already
9755 resolved during resolve_symbol. */
9759 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9763 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9767 for (; b
; b
= b
->block
)
9769 t
= gfc_resolve_expr (b
->expr1
);
9770 if (!gfc_resolve_expr (b
->expr2
))
9776 if (t
&& b
->expr1
!= NULL
9777 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9778 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9785 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9786 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9791 resolve_branch (b
->label1
, b
);
9795 resolve_block_construct (b
);
9799 case EXEC_SELECT_TYPE
:
9803 case EXEC_DO_CONCURRENT
:
9811 case EXEC_OMP_ATOMIC
:
9812 case EXEC_OACC_ATOMIC
:
9814 gfc_omp_atomic_op aop
9815 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
9817 /* Verify this before calling gfc_resolve_code, which might
9819 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
9820 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
9821 && b
->next
->next
== NULL
)
9822 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
9823 && b
->next
->next
!= NULL
9824 && b
->next
->next
->op
== EXEC_ASSIGN
9825 && b
->next
->next
->next
== NULL
));
9829 case EXEC_OACC_PARALLEL_LOOP
:
9830 case EXEC_OACC_PARALLEL
:
9831 case EXEC_OACC_KERNELS_LOOP
:
9832 case EXEC_OACC_KERNELS
:
9833 case EXEC_OACC_DATA
:
9834 case EXEC_OACC_HOST_DATA
:
9835 case EXEC_OACC_LOOP
:
9836 case EXEC_OACC_UPDATE
:
9837 case EXEC_OACC_WAIT
:
9838 case EXEC_OACC_CACHE
:
9839 case EXEC_OACC_ENTER_DATA
:
9840 case EXEC_OACC_EXIT_DATA
:
9841 case EXEC_OACC_ROUTINE
:
9842 case EXEC_OMP_CRITICAL
:
9843 case EXEC_OMP_DISTRIBUTE
:
9844 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9845 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9846 case EXEC_OMP_DISTRIBUTE_SIMD
:
9848 case EXEC_OMP_DO_SIMD
:
9849 case EXEC_OMP_MASTER
:
9850 case EXEC_OMP_ORDERED
:
9851 case EXEC_OMP_PARALLEL
:
9852 case EXEC_OMP_PARALLEL_DO
:
9853 case EXEC_OMP_PARALLEL_DO_SIMD
:
9854 case EXEC_OMP_PARALLEL_SECTIONS
:
9855 case EXEC_OMP_PARALLEL_WORKSHARE
:
9856 case EXEC_OMP_SECTIONS
:
9858 case EXEC_OMP_SINGLE
:
9859 case EXEC_OMP_TARGET
:
9860 case EXEC_OMP_TARGET_DATA
:
9861 case EXEC_OMP_TARGET_ENTER_DATA
:
9862 case EXEC_OMP_TARGET_EXIT_DATA
:
9863 case EXEC_OMP_TARGET_PARALLEL
:
9864 case EXEC_OMP_TARGET_PARALLEL_DO
:
9865 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
9866 case EXEC_OMP_TARGET_SIMD
:
9867 case EXEC_OMP_TARGET_TEAMS
:
9868 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9869 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9870 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9871 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9872 case EXEC_OMP_TARGET_UPDATE
:
9874 case EXEC_OMP_TASKGROUP
:
9875 case EXEC_OMP_TASKLOOP
:
9876 case EXEC_OMP_TASKLOOP_SIMD
:
9877 case EXEC_OMP_TASKWAIT
:
9878 case EXEC_OMP_TASKYIELD
:
9879 case EXEC_OMP_TEAMS
:
9880 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9881 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9882 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9883 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9884 case EXEC_OMP_WORKSHARE
:
9888 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9891 gfc_resolve_code (b
->next
, ns
);
9896 /* Does everything to resolve an ordinary assignment. Returns true
9897 if this is an interface assignment. */
9899 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9908 symbol_attribute attr
;
9910 if (gfc_extend_assign (code
, ns
))
9914 if (code
->op
== EXEC_ASSIGN_CALL
)
9916 lhs
= code
->ext
.actual
->expr
;
9917 rhsptr
= &code
->ext
.actual
->next
->expr
;
9921 gfc_actual_arglist
* args
;
9922 gfc_typebound_proc
* tbp
;
9924 gcc_assert (code
->op
== EXEC_COMPCALL
);
9926 args
= code
->expr1
->value
.compcall
.actual
;
9928 rhsptr
= &args
->next
->expr
;
9930 tbp
= code
->expr1
->value
.compcall
.tbp
;
9931 gcc_assert (!tbp
->is_generic
);
9934 /* Make a temporary rhs when there is a default initializer
9935 and rhs is the same symbol as the lhs. */
9936 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9937 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9938 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9939 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9940 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9949 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9950 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9954 /* Handle the case of a BOZ literal on the RHS. */
9955 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9958 if (warn_surprising
)
9959 gfc_warning (OPT_Wsurprising
,
9960 "BOZ literal at %L is bitwise transferred "
9961 "non-integer symbol %qs", &code
->loc
,
9962 lhs
->symtree
->n
.sym
->name
);
9964 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9966 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9968 if (rc
== ARITH_UNDERFLOW
)
9969 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9970 ". This check can be disabled with the option "
9971 "%<-fno-range-check%>", &rhs
->where
);
9972 else if (rc
== ARITH_OVERFLOW
)
9973 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9974 ". This check can be disabled with the option "
9975 "%<-fno-range-check%>", &rhs
->where
);
9976 else if (rc
== ARITH_NAN
)
9977 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9978 ". This check can be disabled with the option "
9979 "%<-fno-range-check%>", &rhs
->where
);
9984 if (lhs
->ts
.type
== BT_CHARACTER
9985 && warn_character_truncation
)
9987 if (lhs
->ts
.u
.cl
!= NULL
9988 && lhs
->ts
.u
.cl
->length
!= NULL
9989 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9990 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9992 if (rhs
->expr_type
== EXPR_CONSTANT
)
9993 rlen
= rhs
->value
.character
.length
;
9995 else if (rhs
->ts
.u
.cl
!= NULL
9996 && rhs
->ts
.u
.cl
->length
!= NULL
9997 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9998 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
10000 if (rlen
&& llen
&& rlen
> llen
)
10001 gfc_warning_now (OPT_Wcharacter_truncation
,
10002 "CHARACTER expression will be truncated "
10003 "in assignment (%d/%d) at %L",
10004 llen
, rlen
, &code
->loc
);
10007 /* Ensure that a vector index expression for the lvalue is evaluated
10008 to a temporary if the lvalue symbol is referenced in it. */
10011 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10012 if (ref
->type
== REF_ARRAY
)
10014 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10015 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10016 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10017 ref
->u
.ar
.start
[n
]))
10019 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10023 if (gfc_pure (NULL
))
10025 if (lhs
->ts
.type
== BT_DERIVED
10026 && lhs
->expr_type
== EXPR_VARIABLE
10027 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10028 && rhs
->expr_type
== EXPR_VARIABLE
10029 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10030 || gfc_is_coindexed (rhs
)))
10032 /* F2008, C1283. */
10033 if (gfc_is_coindexed (rhs
))
10034 gfc_error ("Coindexed expression at %L is assigned to "
10035 "a derived type variable with a POINTER "
10036 "component in a PURE procedure",
10039 gfc_error ("The impure variable at %L is assigned to "
10040 "a derived type variable with a POINTER "
10041 "component in a PURE procedure (12.6)",
10046 /* Fortran 2008, C1283. */
10047 if (gfc_is_coindexed (lhs
))
10049 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10050 "procedure", &rhs
->where
);
10055 if (gfc_implicit_pure (NULL
))
10057 if (lhs
->expr_type
== EXPR_VARIABLE
10058 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10059 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10060 gfc_unset_implicit_pure (NULL
);
10062 if (lhs
->ts
.type
== BT_DERIVED
10063 && lhs
->expr_type
== EXPR_VARIABLE
10064 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10065 && rhs
->expr_type
== EXPR_VARIABLE
10066 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10067 || gfc_is_coindexed (rhs
)))
10068 gfc_unset_implicit_pure (NULL
);
10070 /* Fortran 2008, C1283. */
10071 if (gfc_is_coindexed (lhs
))
10072 gfc_unset_implicit_pure (NULL
);
10075 /* F2008, 7.2.1.2. */
10076 attr
= gfc_expr_attr (lhs
);
10077 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10079 if (attr
.codimension
)
10081 gfc_error ("Assignment to polymorphic coarray at %L is not "
10082 "permitted", &lhs
->where
);
10085 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10086 "polymorphic variable at %L", &lhs
->where
))
10088 if (!flag_realloc_lhs
)
10090 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10091 "requires %<-frealloc-lhs%>", &lhs
->where
);
10095 else if (lhs
->ts
.type
== BT_CLASS
)
10097 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10098 "assignment at %L - check that there is a matching specific "
10099 "subroutine for '=' operator", &lhs
->where
);
10103 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10105 /* F2008, Section 7.2.1.2. */
10106 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10108 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10109 "component in assignment at %L", &lhs
->where
);
10113 /* Assign the 'data' of a class object to a derived type. */
10114 if (lhs
->ts
.type
== BT_DERIVED
10115 && rhs
->ts
.type
== BT_CLASS
)
10116 gfc_add_data_component (rhs
);
10118 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10120 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10121 && code
->expr2
->value
.function
.isym
10122 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10123 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10124 && !gfc_expr_attr (rhs
).allocatable
10125 && !gfc_has_vector_subscript (rhs
)));
10127 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10129 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10130 Additionally, insert this code when the RHS is a CAF as we then use the
10131 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10132 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10133 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10135 if (caf_convert_to_send
)
10137 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10138 && code
->expr2
->value
.function
.isym
10139 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10140 remove_caf_get_intrinsic (code
->expr2
);
10141 code
->op
= EXEC_CALL
;
10142 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10143 code
->resolved_sym
= code
->symtree
->n
.sym
;
10144 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10145 code
->resolved_sym
->attr
.intrinsic
= 1;
10146 code
->resolved_sym
->attr
.subroutine
= 1;
10147 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10148 gfc_commit_symbol (code
->resolved_sym
);
10149 code
->ext
.actual
= gfc_get_actual_arglist ();
10150 code
->ext
.actual
->expr
= lhs
;
10151 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10152 code
->ext
.actual
->next
->expr
= rhs
;
10153 code
->expr1
= NULL
;
10154 code
->expr2
= NULL
;
10161 /* Add a component reference onto an expression. */
10164 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10169 ref
= &((*ref
)->next
);
10170 *ref
= gfc_get_ref ();
10171 (*ref
)->type
= REF_COMPONENT
;
10172 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10173 (*ref
)->u
.c
.component
= c
;
10176 /* Add a full array ref, as necessary. */
10179 gfc_add_full_array_ref (e
, c
->as
);
10180 e
->rank
= c
->as
->rank
;
10185 /* Build an assignment. Keep the argument 'op' for future use, so that
10186 pointer assignments can be made. */
10189 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10190 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10192 gfc_code
*this_code
;
10194 this_code
= gfc_get_code (op
);
10195 this_code
->next
= NULL
;
10196 this_code
->expr1
= gfc_copy_expr (expr1
);
10197 this_code
->expr2
= gfc_copy_expr (expr2
);
10198 this_code
->loc
= loc
;
10199 if (comp1
&& comp2
)
10201 add_comp_ref (this_code
->expr1
, comp1
);
10202 add_comp_ref (this_code
->expr2
, comp2
);
10209 /* Makes a temporary variable expression based on the characteristics of
10210 a given variable expression. */
10213 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10215 static int serial
= 0;
10216 char name
[GFC_MAX_SYMBOL_LEN
];
10218 gfc_array_spec
*as
;
10219 gfc_array_ref
*aref
;
10222 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10223 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10224 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10230 /* Obtain the arrayspec for the temporary. */
10231 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10232 && e
->expr_type
!= EXPR_FUNCTION
10233 && e
->expr_type
!= EXPR_OP
)
10235 aref
= gfc_find_array_ref (e
);
10236 if (e
->expr_type
== EXPR_VARIABLE
10237 && e
->symtree
->n
.sym
->as
== aref
->as
)
10241 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10242 if (ref
->type
== REF_COMPONENT
10243 && ref
->u
.c
.component
->as
== aref
->as
)
10251 /* Add the attributes and the arrayspec to the temporary. */
10252 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10253 tmp
->n
.sym
->attr
.function
= 0;
10254 tmp
->n
.sym
->attr
.result
= 0;
10255 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10259 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10262 if (as
->type
== AS_DEFERRED
)
10263 tmp
->n
.sym
->attr
.allocatable
= 1;
10265 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10266 || e
->expr_type
== EXPR_FUNCTION
10267 || e
->expr_type
== EXPR_OP
))
10269 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10270 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10271 tmp
->n
.sym
->as
->rank
= e
->rank
;
10272 tmp
->n
.sym
->attr
.allocatable
= 1;
10273 tmp
->n
.sym
->attr
.dimension
= 1;
10276 tmp
->n
.sym
->attr
.dimension
= 0;
10278 gfc_set_sym_referenced (tmp
->n
.sym
);
10279 gfc_commit_symbol (tmp
->n
.sym
);
10280 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10282 /* Should the lhs be a section, use its array ref for the
10283 temporary expression. */
10284 if (aref
&& aref
->type
!= AR_FULL
)
10286 gfc_free_ref_list (e
->ref
);
10287 e
->ref
= gfc_copy_ref (ref
);
10293 /* Add one line of code to the code chain, making sure that 'head' and
10294 'tail' are appropriately updated. */
10297 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10299 gcc_assert (this_code
);
10301 *head
= *tail
= *this_code
;
10303 *tail
= gfc_append_code (*tail
, *this_code
);
10308 /* Counts the potential number of part array references that would
10309 result from resolution of typebound defined assignments. */
10312 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10315 int c_depth
= 0, t_depth
;
10317 for (c
= derived
->components
; c
; c
= c
->next
)
10319 if ((!gfc_bt_struct (c
->ts
.type
)
10321 || c
->attr
.allocatable
10322 || c
->attr
.proc_pointer_comp
10323 || c
->attr
.class_pointer
10324 || c
->attr
.proc_pointer
)
10325 && !c
->attr
.defined_assign_comp
)
10328 if (c
->as
&& c_depth
== 0)
10331 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10332 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10337 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10339 return depth
+ c_depth
;
10343 /* Implement 7.2.1.3 of the F08 standard:
10344 "An intrinsic assignment where the variable is of derived type is
10345 performed as if each component of the variable were assigned from the
10346 corresponding component of expr using pointer assignment (7.2.2) for
10347 each pointer component, defined assignment for each nonpointer
10348 nonallocatable component of a type that has a type-bound defined
10349 assignment consistent with the component, intrinsic assignment for
10350 each other nonpointer nonallocatable component, ..."
10352 The pointer assignments are taken care of by the intrinsic
10353 assignment of the structure itself. This function recursively adds
10354 defined assignments where required. The recursion is accomplished
10355 by calling gfc_resolve_code.
10357 When the lhs in a defined assignment has intent INOUT, we need a
10358 temporary for the lhs. In pseudo-code:
10360 ! Only call function lhs once.
10361 if (lhs is not a constant or an variable)
10364 ! Do the intrinsic assignment
10366 ! Now do the defined assignments
10367 do over components with typebound defined assignment [%cmp]
10368 #if one component's assignment procedure is INOUT
10370 #if expr2 non-variable
10376 t1%cmp {defined=} expr2%cmp
10382 expr1%cmp {defined=} expr2%cmp
10386 /* The temporary assignments have to be put on top of the additional
10387 code to avoid the result being changed by the intrinsic assignment.
10389 static int component_assignment_level
= 0;
10390 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10393 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10395 gfc_component
*comp1
, *comp2
;
10396 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10398 int error_count
, depth
;
10400 gfc_get_errors (NULL
, &error_count
);
10402 /* Filter out continuing processing after an error. */
10404 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10405 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10408 /* TODO: Handle more than one part array reference in assignments. */
10409 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10410 (*code
)->expr1
->rank
? 1 : 0);
10413 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10414 "done because multiple part array references would "
10415 "occur in intermediate expressions.", &(*code
)->loc
);
10419 component_assignment_level
++;
10421 /* Create a temporary so that functions get called only once. */
10422 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10423 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10425 gfc_expr
*tmp_expr
;
10427 /* Assign the rhs to the temporary. */
10428 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10429 this_code
= build_assignment (EXEC_ASSIGN
,
10430 tmp_expr
, (*code
)->expr2
,
10431 NULL
, NULL
, (*code
)->loc
);
10432 /* Add the code and substitute the rhs expression. */
10433 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10434 gfc_free_expr ((*code
)->expr2
);
10435 (*code
)->expr2
= tmp_expr
;
10438 /* Do the intrinsic assignment. This is not needed if the lhs is one
10439 of the temporaries generated here, since the intrinsic assignment
10440 to the final result already does this. */
10441 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10443 this_code
= build_assignment (EXEC_ASSIGN
,
10444 (*code
)->expr1
, (*code
)->expr2
,
10445 NULL
, NULL
, (*code
)->loc
);
10446 add_code_to_chain (&this_code
, &head
, &tail
);
10449 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10450 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10453 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10455 bool inout
= false;
10457 /* The intrinsic assignment does the right thing for pointers
10458 of all kinds and allocatable components. */
10459 if (!gfc_bt_struct (comp1
->ts
.type
)
10460 || comp1
->attr
.pointer
10461 || comp1
->attr
.allocatable
10462 || comp1
->attr
.proc_pointer_comp
10463 || comp1
->attr
.class_pointer
10464 || comp1
->attr
.proc_pointer
)
10467 /* Make an assigment for this component. */
10468 this_code
= build_assignment (EXEC_ASSIGN
,
10469 (*code
)->expr1
, (*code
)->expr2
,
10470 comp1
, comp2
, (*code
)->loc
);
10472 /* Convert the assignment if there is a defined assignment for
10473 this type. Otherwise, using the call from gfc_resolve_code,
10474 recurse into its components. */
10475 gfc_resolve_code (this_code
, ns
);
10477 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10479 gfc_formal_arglist
*dummy_args
;
10481 /* Check that there is a typebound defined assignment. If not,
10482 then this must be a module defined assignment. We cannot
10483 use the defined_assign_comp attribute here because it must
10484 be this derived type that has the defined assignment and not
10486 if (!(comp1
->ts
.u
.derived
->f2k_derived
10487 && comp1
->ts
.u
.derived
->f2k_derived
10488 ->tb_op
[INTRINSIC_ASSIGN
]))
10490 gfc_free_statements (this_code
);
10495 /* If the first argument of the subroutine has intent INOUT
10496 a temporary must be generated and used instead. */
10497 rsym
= this_code
->resolved_sym
;
10498 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10500 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10502 gfc_code
*temp_code
;
10505 /* Build the temporary required for the assignment and put
10506 it at the head of the generated code. */
10509 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10510 temp_code
= build_assignment (EXEC_ASSIGN
,
10511 t1
, (*code
)->expr1
,
10512 NULL
, NULL
, (*code
)->loc
);
10514 /* For allocatable LHS, check whether it is allocated. Note
10515 that allocatable components with defined assignment are
10516 not yet support. See PR 57696. */
10517 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10521 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10522 block
= gfc_get_code (EXEC_IF
);
10523 block
->block
= gfc_get_code (EXEC_IF
);
10524 block
->block
->expr1
10525 = gfc_build_intrinsic_call (ns
,
10526 GFC_ISYM_ALLOCATED
, "allocated",
10527 (*code
)->loc
, 1, e
);
10528 block
->block
->next
= temp_code
;
10531 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10534 /* Replace the first actual arg with the component of the
10536 gfc_free_expr (this_code
->ext
.actual
->expr
);
10537 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10538 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10540 /* If the LHS variable is allocatable and wasn't allocated and
10541 the temporary is allocatable, pointer assign the address of
10542 the freshly allocated LHS to the temporary. */
10543 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10544 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10549 cond
= gfc_get_expr ();
10550 cond
->ts
.type
= BT_LOGICAL
;
10551 cond
->ts
.kind
= gfc_default_logical_kind
;
10552 cond
->expr_type
= EXPR_OP
;
10553 cond
->where
= (*code
)->loc
;
10554 cond
->value
.op
.op
= INTRINSIC_NOT
;
10555 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10556 GFC_ISYM_ALLOCATED
, "allocated",
10557 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10558 block
= gfc_get_code (EXEC_IF
);
10559 block
->block
= gfc_get_code (EXEC_IF
);
10560 block
->block
->expr1
= cond
;
10561 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10562 t1
, (*code
)->expr1
,
10563 NULL
, NULL
, (*code
)->loc
);
10564 add_code_to_chain (&block
, &head
, &tail
);
10568 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10570 /* Don't add intrinsic assignments since they are already
10571 effected by the intrinsic assignment of the structure. */
10572 gfc_free_statements (this_code
);
10577 add_code_to_chain (&this_code
, &head
, &tail
);
10581 /* Transfer the value to the final result. */
10582 this_code
= build_assignment (EXEC_ASSIGN
,
10583 (*code
)->expr1
, t1
,
10584 comp1
, comp2
, (*code
)->loc
);
10585 add_code_to_chain (&this_code
, &head
, &tail
);
10589 /* Put the temporary assignments at the top of the generated code. */
10590 if (tmp_head
&& component_assignment_level
== 1)
10592 gfc_append_code (tmp_head
, head
);
10594 tmp_head
= tmp_tail
= NULL
;
10597 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10598 // not accidentally deallocated. Hence, nullify t1.
10599 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10600 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10606 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10607 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10608 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10609 block
= gfc_get_code (EXEC_IF
);
10610 block
->block
= gfc_get_code (EXEC_IF
);
10611 block
->block
->expr1
= cond
;
10612 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10613 t1
, gfc_get_null_expr (&(*code
)->loc
),
10614 NULL
, NULL
, (*code
)->loc
);
10615 gfc_append_code (tail
, block
);
10619 /* Now attach the remaining code chain to the input code. Step on
10620 to the end of the new code since resolution is complete. */
10621 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10622 tail
->next
= (*code
)->next
;
10623 /* Overwrite 'code' because this would place the intrinsic assignment
10624 before the temporary for the lhs is created. */
10625 gfc_free_expr ((*code
)->expr1
);
10626 gfc_free_expr ((*code
)->expr2
);
10632 component_assignment_level
--;
10636 /* F2008: Pointer function assignments are of the form:
10637 ptr_fcn (args) = expr
10638 This function breaks these assignments into two statements:
10639 temporary_pointer => ptr_fcn(args)
10640 temporary_pointer = expr */
10643 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10645 gfc_expr
*tmp_ptr_expr
;
10646 gfc_code
*this_code
;
10647 gfc_component
*comp
;
10650 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10653 /* Even if standard does not support this feature, continue to build
10654 the two statements to avoid upsetting frontend_passes.c. */
10655 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10656 "%L", &(*code
)->loc
);
10658 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10661 s
= comp
->ts
.interface
;
10663 s
= (*code
)->expr1
->symtree
->n
.sym
;
10665 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10667 gfc_error ("The function result on the lhs of the assignment at "
10668 "%L must have the pointer attribute.",
10669 &(*code
)->expr1
->where
);
10670 (*code
)->op
= EXEC_NOP
;
10674 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10676 /* get_temp_from_expression is set up for ordinary assignments. To that
10677 end, where array bounds are not known, arrays are made allocatable.
10678 Change the temporary to a pointer here. */
10679 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10680 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10681 tmp_ptr_expr
->where
= (*code
)->loc
;
10683 this_code
= build_assignment (EXEC_ASSIGN
,
10684 tmp_ptr_expr
, (*code
)->expr2
,
10685 NULL
, NULL
, (*code
)->loc
);
10686 this_code
->next
= (*code
)->next
;
10687 (*code
)->next
= this_code
;
10688 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10689 (*code
)->expr2
= (*code
)->expr1
;
10690 (*code
)->expr1
= tmp_ptr_expr
;
10696 /* Deferred character length assignments from an operator expression
10697 require a temporary because the character length of the lhs can
10698 change in the course of the assignment. */
10701 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10703 gfc_expr
*tmp_expr
;
10704 gfc_code
*this_code
;
10706 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10707 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10708 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10711 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10714 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10715 tmp_expr
->where
= (*code
)->loc
;
10717 /* A new charlen is required to ensure that the variable string
10718 length is different to that of the original lhs. */
10719 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10720 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10721 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10722 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10724 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10726 this_code
= build_assignment (EXEC_ASSIGN
,
10728 gfc_copy_expr (tmp_expr
),
10729 NULL
, NULL
, (*code
)->loc
);
10731 (*code
)->expr1
= tmp_expr
;
10733 this_code
->next
= (*code
)->next
;
10734 (*code
)->next
= this_code
;
10740 /* Given a block of code, recursively resolve everything pointed to by this
10744 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10746 int omp_workshare_save
;
10747 int forall_save
, do_concurrent_save
;
10751 frame
.prev
= cs_base
;
10755 find_reachable_labels (code
);
10757 for (; code
; code
= code
->next
)
10759 frame
.current
= code
;
10760 forall_save
= forall_flag
;
10761 do_concurrent_save
= gfc_do_concurrent_flag
;
10763 if (code
->op
== EXEC_FORALL
)
10766 gfc_resolve_forall (code
, ns
, forall_save
);
10769 else if (code
->block
)
10771 omp_workshare_save
= -1;
10774 case EXEC_OACC_PARALLEL_LOOP
:
10775 case EXEC_OACC_PARALLEL
:
10776 case EXEC_OACC_KERNELS_LOOP
:
10777 case EXEC_OACC_KERNELS
:
10778 case EXEC_OACC_DATA
:
10779 case EXEC_OACC_HOST_DATA
:
10780 case EXEC_OACC_LOOP
:
10781 gfc_resolve_oacc_blocks (code
, ns
);
10783 case EXEC_OMP_PARALLEL_WORKSHARE
:
10784 omp_workshare_save
= omp_workshare_flag
;
10785 omp_workshare_flag
= 1;
10786 gfc_resolve_omp_parallel_blocks (code
, ns
);
10788 case EXEC_OMP_PARALLEL
:
10789 case EXEC_OMP_PARALLEL_DO
:
10790 case EXEC_OMP_PARALLEL_DO_SIMD
:
10791 case EXEC_OMP_PARALLEL_SECTIONS
:
10792 case EXEC_OMP_TARGET_PARALLEL
:
10793 case EXEC_OMP_TARGET_PARALLEL_DO
:
10794 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10795 case EXEC_OMP_TARGET_TEAMS
:
10796 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10797 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10798 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10799 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10800 case EXEC_OMP_TASK
:
10801 case EXEC_OMP_TEAMS
:
10802 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10803 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10804 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10805 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10806 omp_workshare_save
= omp_workshare_flag
;
10807 omp_workshare_flag
= 0;
10808 gfc_resolve_omp_parallel_blocks (code
, ns
);
10810 case EXEC_OMP_DISTRIBUTE
:
10811 case EXEC_OMP_DISTRIBUTE_SIMD
:
10813 case EXEC_OMP_DO_SIMD
:
10814 case EXEC_OMP_SIMD
:
10815 case EXEC_OMP_TARGET_SIMD
:
10816 case EXEC_OMP_TASKLOOP
:
10817 case EXEC_OMP_TASKLOOP_SIMD
:
10818 gfc_resolve_omp_do_blocks (code
, ns
);
10820 case EXEC_SELECT_TYPE
:
10821 /* Blocks are handled in resolve_select_type because we have
10822 to transform the SELECT TYPE into ASSOCIATE first. */
10824 case EXEC_DO_CONCURRENT
:
10825 gfc_do_concurrent_flag
= 1;
10826 gfc_resolve_blocks (code
->block
, ns
);
10827 gfc_do_concurrent_flag
= 2;
10829 case EXEC_OMP_WORKSHARE
:
10830 omp_workshare_save
= omp_workshare_flag
;
10831 omp_workshare_flag
= 1;
10834 gfc_resolve_blocks (code
->block
, ns
);
10838 if (omp_workshare_save
!= -1)
10839 omp_workshare_flag
= omp_workshare_save
;
10843 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10844 t
= gfc_resolve_expr (code
->expr1
);
10845 forall_flag
= forall_save
;
10846 gfc_do_concurrent_flag
= do_concurrent_save
;
10848 if (!gfc_resolve_expr (code
->expr2
))
10851 if (code
->op
== EXEC_ALLOCATE
10852 && !gfc_resolve_expr (code
->expr3
))
10858 case EXEC_END_BLOCK
:
10859 case EXEC_END_NESTED_BLOCK
:
10863 case EXEC_ERROR_STOP
:
10865 case EXEC_CONTINUE
:
10867 case EXEC_ASSIGN_CALL
:
10870 case EXEC_CRITICAL
:
10871 resolve_critical (code
);
10874 case EXEC_SYNC_ALL
:
10875 case EXEC_SYNC_IMAGES
:
10876 case EXEC_SYNC_MEMORY
:
10877 resolve_sync (code
);
10882 case EXEC_EVENT_POST
:
10883 case EXEC_EVENT_WAIT
:
10884 resolve_lock_unlock_event (code
);
10887 case EXEC_FAIL_IMAGE
:
10891 /* Keep track of which entry we are up to. */
10892 current_entry_id
= code
->ext
.entry
->id
;
10896 resolve_where (code
, NULL
);
10900 if (code
->expr1
!= NULL
)
10902 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10903 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10904 "INTEGER variable", &code
->expr1
->where
);
10905 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10906 gfc_error ("Variable %qs has not been assigned a target "
10907 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10908 &code
->expr1
->where
);
10911 resolve_branch (code
->label1
, code
);
10915 if (code
->expr1
!= NULL
10916 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10917 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10918 "INTEGER return specifier", &code
->expr1
->where
);
10921 case EXEC_INIT_ASSIGN
:
10922 case EXEC_END_PROCEDURE
:
10929 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10931 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10932 && code
->expr1
->value
.function
.isym
10933 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10934 remove_caf_get_intrinsic (code
->expr1
);
10936 /* If this is a pointer function in an lvalue variable context,
10937 the new code will have to be resolved afresh. This is also the
10938 case with an error, where the code is transformed into NOP to
10939 prevent ICEs downstream. */
10940 if (resolve_ptr_fcn_assign (&code
, ns
)
10941 || code
->op
== EXEC_NOP
)
10944 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10948 if (resolve_ordinary_assign (code
, ns
))
10950 if (code
->op
== EXEC_COMPCALL
)
10956 /* Check for dependencies in deferred character length array
10957 assignments and generate a temporary, if necessary. */
10958 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
10961 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10962 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10963 && code
->expr1
->ts
.u
.derived
10964 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10965 generate_component_assignments (&code
, ns
);
10969 case EXEC_LABEL_ASSIGN
:
10970 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10971 gfc_error ("Label %d referenced at %L is never defined",
10972 code
->label1
->value
, &code
->label1
->where
);
10974 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10975 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10976 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10977 != gfc_default_integer_kind
10978 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10979 gfc_error ("ASSIGN statement at %L requires a scalar "
10980 "default INTEGER variable", &code
->expr1
->where
);
10983 case EXEC_POINTER_ASSIGN
:
10990 /* This is both a variable definition and pointer assignment
10991 context, so check both of them. For rank remapping, a final
10992 array ref may be present on the LHS and fool gfc_expr_attr
10993 used in gfc_check_vardef_context. Remove it. */
10994 e
= remove_last_array_ref (code
->expr1
);
10995 t
= gfc_check_vardef_context (e
, true, false, false,
10996 _("pointer assignment"));
10998 t
= gfc_check_vardef_context (e
, false, false, false,
10999 _("pointer assignment"));
11004 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
11006 /* Assigning a class object always is a regular assign. */
11007 if (code
->expr2
->ts
.type
== BT_CLASS
11008 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11009 && !(UNLIMITED_POLY (code
->expr2
)
11010 && code
->expr1
->ts
.type
== BT_DERIVED
11011 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
11012 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
11013 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11014 && code
->expr2
->expr_type
== EXPR_VARIABLE
11015 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11017 code
->op
= EXEC_ASSIGN
;
11021 case EXEC_ARITHMETIC_IF
:
11023 gfc_expr
*e
= code
->expr1
;
11025 gfc_resolve_expr (e
);
11026 if (e
->expr_type
== EXPR_NULL
)
11027 gfc_error ("Invalid NULL at %L", &e
->where
);
11029 if (t
&& (e
->rank
> 0
11030 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11031 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11032 "REAL or INTEGER expression", &e
->where
);
11034 resolve_branch (code
->label1
, code
);
11035 resolve_branch (code
->label2
, code
);
11036 resolve_branch (code
->label3
, code
);
11041 if (t
&& code
->expr1
!= NULL
11042 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11043 || code
->expr1
->rank
!= 0))
11044 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11045 &code
->expr1
->where
);
11050 resolve_call (code
);
11053 case EXEC_COMPCALL
:
11055 resolve_typebound_subroutine (code
);
11058 case EXEC_CALL_PPC
:
11059 resolve_ppc_call (code
);
11063 /* Select is complicated. Also, a SELECT construct could be
11064 a transformed computed GOTO. */
11065 resolve_select (code
, false);
11068 case EXEC_SELECT_TYPE
:
11069 resolve_select_type (code
, ns
);
11073 resolve_block_construct (code
);
11077 if (code
->ext
.iterator
!= NULL
)
11079 gfc_iterator
*iter
= code
->ext
.iterator
;
11080 if (gfc_resolve_iterator (iter
, true, false))
11081 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
11085 case EXEC_DO_WHILE
:
11086 if (code
->expr1
== NULL
)
11087 gfc_internal_error ("gfc_resolve_code(): No expression on "
11090 && (code
->expr1
->rank
!= 0
11091 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11092 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11093 "a scalar LOGICAL expression", &code
->expr1
->where
);
11096 case EXEC_ALLOCATE
:
11098 resolve_allocate_deallocate (code
, "ALLOCATE");
11102 case EXEC_DEALLOCATE
:
11104 resolve_allocate_deallocate (code
, "DEALLOCATE");
11109 if (!gfc_resolve_open (code
->ext
.open
))
11112 resolve_branch (code
->ext
.open
->err
, code
);
11116 if (!gfc_resolve_close (code
->ext
.close
))
11119 resolve_branch (code
->ext
.close
->err
, code
);
11122 case EXEC_BACKSPACE
:
11126 if (!gfc_resolve_filepos (code
->ext
.filepos
))
11129 resolve_branch (code
->ext
.filepos
->err
, code
);
11133 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11136 resolve_branch (code
->ext
.inquire
->err
, code
);
11139 case EXEC_IOLENGTH
:
11140 gcc_assert (code
->ext
.inquire
!= NULL
);
11141 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11144 resolve_branch (code
->ext
.inquire
->err
, code
);
11148 if (!gfc_resolve_wait (code
->ext
.wait
))
11151 resolve_branch (code
->ext
.wait
->err
, code
);
11152 resolve_branch (code
->ext
.wait
->end
, code
);
11153 resolve_branch (code
->ext
.wait
->eor
, code
);
11158 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11161 resolve_branch (code
->ext
.dt
->err
, code
);
11162 resolve_branch (code
->ext
.dt
->end
, code
);
11163 resolve_branch (code
->ext
.dt
->eor
, code
);
11166 case EXEC_TRANSFER
:
11167 resolve_transfer (code
);
11170 case EXEC_DO_CONCURRENT
:
11172 resolve_forall_iterators (code
->ext
.forall_iterator
);
11174 if (code
->expr1
!= NULL
11175 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11176 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11177 "expression", &code
->expr1
->where
);
11180 case EXEC_OACC_PARALLEL_LOOP
:
11181 case EXEC_OACC_PARALLEL
:
11182 case EXEC_OACC_KERNELS_LOOP
:
11183 case EXEC_OACC_KERNELS
:
11184 case EXEC_OACC_DATA
:
11185 case EXEC_OACC_HOST_DATA
:
11186 case EXEC_OACC_LOOP
:
11187 case EXEC_OACC_UPDATE
:
11188 case EXEC_OACC_WAIT
:
11189 case EXEC_OACC_CACHE
:
11190 case EXEC_OACC_ENTER_DATA
:
11191 case EXEC_OACC_EXIT_DATA
:
11192 case EXEC_OACC_ATOMIC
:
11193 case EXEC_OACC_DECLARE
:
11194 gfc_resolve_oacc_directive (code
, ns
);
11197 case EXEC_OMP_ATOMIC
:
11198 case EXEC_OMP_BARRIER
:
11199 case EXEC_OMP_CANCEL
:
11200 case EXEC_OMP_CANCELLATION_POINT
:
11201 case EXEC_OMP_CRITICAL
:
11202 case EXEC_OMP_FLUSH
:
11203 case EXEC_OMP_DISTRIBUTE
:
11204 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11205 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11206 case EXEC_OMP_DISTRIBUTE_SIMD
:
11208 case EXEC_OMP_DO_SIMD
:
11209 case EXEC_OMP_MASTER
:
11210 case EXEC_OMP_ORDERED
:
11211 case EXEC_OMP_SECTIONS
:
11212 case EXEC_OMP_SIMD
:
11213 case EXEC_OMP_SINGLE
:
11214 case EXEC_OMP_TARGET
:
11215 case EXEC_OMP_TARGET_DATA
:
11216 case EXEC_OMP_TARGET_ENTER_DATA
:
11217 case EXEC_OMP_TARGET_EXIT_DATA
:
11218 case EXEC_OMP_TARGET_PARALLEL
:
11219 case EXEC_OMP_TARGET_PARALLEL_DO
:
11220 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11221 case EXEC_OMP_TARGET_SIMD
:
11222 case EXEC_OMP_TARGET_TEAMS
:
11223 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11224 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11225 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11226 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11227 case EXEC_OMP_TARGET_UPDATE
:
11228 case EXEC_OMP_TASK
:
11229 case EXEC_OMP_TASKGROUP
:
11230 case EXEC_OMP_TASKLOOP
:
11231 case EXEC_OMP_TASKLOOP_SIMD
:
11232 case EXEC_OMP_TASKWAIT
:
11233 case EXEC_OMP_TASKYIELD
:
11234 case EXEC_OMP_TEAMS
:
11235 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11236 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11237 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11238 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11239 case EXEC_OMP_WORKSHARE
:
11240 gfc_resolve_omp_directive (code
, ns
);
11243 case EXEC_OMP_PARALLEL
:
11244 case EXEC_OMP_PARALLEL_DO
:
11245 case EXEC_OMP_PARALLEL_DO_SIMD
:
11246 case EXEC_OMP_PARALLEL_SECTIONS
:
11247 case EXEC_OMP_PARALLEL_WORKSHARE
:
11248 omp_workshare_save
= omp_workshare_flag
;
11249 omp_workshare_flag
= 0;
11250 gfc_resolve_omp_directive (code
, ns
);
11251 omp_workshare_flag
= omp_workshare_save
;
11255 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11259 cs_base
= frame
.prev
;
11263 /* Resolve initial values and make sure they are compatible with
11267 resolve_values (gfc_symbol
*sym
)
11271 if (sym
->value
== NULL
)
11274 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11275 t
= resolve_structure_cons (sym
->value
, 1);
11277 t
= gfc_resolve_expr (sym
->value
);
11282 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11286 /* Verify any BIND(C) derived types in the namespace so we can report errors
11287 for them once, rather than for each variable declared of that type. */
11290 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11292 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11293 && derived_sym
->attr
.is_bind_c
== 1)
11294 verify_bind_c_derived_type (derived_sym
);
11300 /* Check the interfaces of DTIO procedures associated with derived
11301 type 'sym'. These procedures can either have typebound bindings or
11302 can appear in DTIO generic interfaces. */
11305 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11307 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11310 gfc_check_dtio_interfaces (sym
);
11315 /* Verify that any binding labels used in a given namespace do not collide
11316 with the names or binding labels of any global symbols. Multiple INTERFACE
11317 for the same procedure are permitted. */
11320 gfc_verify_binding_labels (gfc_symbol
*sym
)
11323 const char *module
;
11325 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11326 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11329 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11332 module
= sym
->module
;
11333 else if (sym
->ns
&& sym
->ns
->proc_name
11334 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11335 module
= sym
->ns
->proc_name
->name
;
11336 else if (sym
->ns
&& sym
->ns
->parent
11337 && sym
->ns
&& sym
->ns
->parent
->proc_name
11338 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11339 module
= sym
->ns
->parent
->proc_name
->name
;
11345 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11348 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11349 gsym
->where
= sym
->declared_at
;
11350 gsym
->sym_name
= sym
->name
;
11351 gsym
->binding_label
= sym
->binding_label
;
11352 gsym
->ns
= sym
->ns
;
11353 gsym
->mod_name
= module
;
11354 if (sym
->attr
.function
)
11355 gsym
->type
= GSYM_FUNCTION
;
11356 else if (sym
->attr
.subroutine
)
11357 gsym
->type
= GSYM_SUBROUTINE
;
11358 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11359 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11363 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11365 gfc_error ("Variable %s with binding label %s at %L uses the same global "
11366 "identifier as entity at %L", sym
->name
,
11367 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11368 /* Clear the binding label to prevent checking multiple times. */
11369 sym
->binding_label
= NULL
;
11372 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11373 && (strcmp (module
, gsym
->mod_name
) != 0
11374 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11376 /* This can only happen if the variable is defined in a module - if it
11377 isn't the same module, reject it. */
11378 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
11379 "the same global identifier as entity at %L from module %s",
11380 sym
->name
, module
, sym
->binding_label
,
11381 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11382 sym
->binding_label
= NULL
;
11384 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11385 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11386 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11387 && sym
!= gsym
->ns
->proc_name
11388 && (module
!= gsym
->mod_name
11389 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11390 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11392 /* Print an error if the procedure is defined multiple times; we have to
11393 exclude references to the same procedure via module association or
11394 multiple checks for the same procedure. */
11395 gfc_error ("Procedure %s with binding label %s at %L uses the same "
11396 "global identifier as entity at %L", sym
->name
,
11397 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11398 sym
->binding_label
= NULL
;
11403 /* Resolve an index expression. */
11406 resolve_index_expr (gfc_expr
*e
)
11408 if (!gfc_resolve_expr (e
))
11411 if (!gfc_simplify_expr (e
, 0))
11414 if (!gfc_specification_expr (e
))
11421 /* Resolve a charlen structure. */
11424 resolve_charlen (gfc_charlen
*cl
)
11427 bool saved_specification_expr
;
11433 saved_specification_expr
= specification_expr
;
11434 specification_expr
= true;
11436 if (cl
->length_from_typespec
)
11438 if (!gfc_resolve_expr (cl
->length
))
11440 specification_expr
= saved_specification_expr
;
11444 if (!gfc_simplify_expr (cl
->length
, 0))
11446 specification_expr
= saved_specification_expr
;
11453 if (!resolve_index_expr (cl
->length
))
11455 specification_expr
= saved_specification_expr
;
11460 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11461 a negative value, the length of character entities declared is zero. */
11462 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
11463 gfc_replace_expr (cl
->length
,
11464 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
11466 /* Check that the character length is not too large. */
11467 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11468 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11469 && cl
->length
->ts
.type
== BT_INTEGER
11470 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11472 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11473 specification_expr
= saved_specification_expr
;
11477 specification_expr
= saved_specification_expr
;
11482 /* Test for non-constant shape arrays. */
11485 is_non_constant_shape_array (gfc_symbol
*sym
)
11491 not_constant
= false;
11492 if (sym
->as
!= NULL
)
11494 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11495 has not been simplified; parameter array references. Do the
11496 simplification now. */
11497 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11499 e
= sym
->as
->lower
[i
];
11500 if (e
&& (!resolve_index_expr(e
)
11501 || !gfc_is_constant_expr (e
)))
11502 not_constant
= true;
11503 e
= sym
->as
->upper
[i
];
11504 if (e
&& (!resolve_index_expr(e
)
11505 || !gfc_is_constant_expr (e
)))
11506 not_constant
= true;
11509 return not_constant
;
11512 /* Given a symbol and an initialization expression, add code to initialize
11513 the symbol to the function entry. */
11515 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11519 gfc_namespace
*ns
= sym
->ns
;
11521 /* Search for the function namespace if this is a contained
11522 function without an explicit result. */
11523 if (sym
->attr
.function
&& sym
== sym
->result
11524 && sym
->name
!= sym
->ns
->proc_name
->name
)
11526 ns
= ns
->contained
;
11527 for (;ns
; ns
= ns
->sibling
)
11528 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11534 gfc_free_expr (init
);
11538 /* Build an l-value expression for the result. */
11539 lval
= gfc_lval_expr_from_sym (sym
);
11541 /* Add the code at scope entry. */
11542 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11543 init_st
->next
= ns
->code
;
11544 ns
->code
= init_st
;
11546 /* Assign the default initializer to the l-value. */
11547 init_st
->loc
= sym
->declared_at
;
11548 init_st
->expr1
= lval
;
11549 init_st
->expr2
= init
;
11553 /* Whether or not we can generate a default initializer for a symbol. */
11556 can_generate_init (gfc_symbol
*sym
)
11558 symbol_attribute
*a
;
11563 /* These symbols should never have a default initialization. */
11568 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11569 && (CLASS_DATA (sym
)->attr
.class_pointer
11570 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11571 || a
->in_equivalence
11578 || (!a
->referenced
&& !a
->result
)
11579 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
11580 || (a
->function
&& sym
!= sym
->result
)
11585 /* Assign the default initializer to a derived type variable or result. */
11588 apply_default_init (gfc_symbol
*sym
)
11590 gfc_expr
*init
= NULL
;
11592 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11595 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11596 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11598 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11601 build_init_assign (sym
, init
);
11602 sym
->attr
.referenced
= 1;
11606 /* Build an initializer for a local. Returns null if the symbol should not have
11607 a default initialization. */
11610 build_default_init_expr (gfc_symbol
*sym
)
11612 /* These symbols should never have a default initialization. */
11613 if (sym
->attr
.allocatable
11614 || sym
->attr
.external
11616 || sym
->attr
.pointer
11617 || sym
->attr
.in_equivalence
11618 || sym
->attr
.in_common
11621 || sym
->attr
.cray_pointee
11622 || sym
->attr
.cray_pointer
11626 /* Get the appropriate init expression. */
11627 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
11630 /* Add an initialization expression to a local variable. */
11632 apply_default_init_local (gfc_symbol
*sym
)
11634 gfc_expr
*init
= NULL
;
11636 /* The symbol should be a variable or a function return value. */
11637 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11638 || (sym
->attr
.function
&& sym
->result
!= sym
))
11641 /* Try to build the initializer expression. If we can't initialize
11642 this symbol, then init will be NULL. */
11643 init
= build_default_init_expr (sym
);
11647 /* For saved variables, we don't want to add an initializer at function
11648 entry, so we just add a static initializer. Note that automatic variables
11649 are stack allocated even with -fno-automatic; we have also to exclude
11650 result variable, which are also nonstatic. */
11651 if (!sym
->attr
.automatic
11652 && (sym
->attr
.save
|| sym
->ns
->save_all
11653 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11654 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11655 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
11657 /* Don't clobber an existing initializer! */
11658 gcc_assert (sym
->value
== NULL
);
11663 build_init_assign (sym
, init
);
11667 /* Resolution of common features of flavors variable and procedure. */
11670 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11672 gfc_array_spec
*as
;
11674 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11675 as
= CLASS_DATA (sym
)->as
;
11679 /* Constraints on deferred shape variable. */
11680 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11682 bool pointer
, allocatable
, dimension
;
11684 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11686 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11687 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11688 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11692 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11693 allocatable
= sym
->attr
.allocatable
;
11694 dimension
= sym
->attr
.dimension
;
11699 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11701 gfc_error ("Allocatable array %qs at %L must have a deferred "
11702 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11705 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11706 "%qs at %L may not be ALLOCATABLE",
11707 sym
->name
, &sym
->declared_at
))
11711 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11713 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11714 "assumed rank", sym
->name
, &sym
->declared_at
);
11720 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11721 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11723 gfc_error ("Array %qs at %L cannot have a deferred shape",
11724 sym
->name
, &sym
->declared_at
);
11729 /* Constraints on polymorphic variables. */
11730 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11733 if (sym
->attr
.class_ok
11734 && !sym
->attr
.select_type_temporary
11735 && !UNLIMITED_POLY (sym
)
11736 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11738 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11739 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11740 &sym
->declared_at
);
11745 /* Assume that use associated symbols were checked in the module ns.
11746 Class-variables that are associate-names are also something special
11747 and excepted from the test. */
11748 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11750 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11751 "or pointer", sym
->name
, &sym
->declared_at
);
11760 /* Additional checks for symbols with flavor variable and derived
11761 type. To be called from resolve_fl_variable. */
11764 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11766 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11768 /* Check to see if a derived type is blocked from being host
11769 associated by the presence of another class I symbol in the same
11770 namespace. 14.6.1.3 of the standard and the discussion on
11771 comp.lang.fortran. */
11772 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11773 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11776 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11777 if (s
&& s
->attr
.generic
)
11778 s
= gfc_find_dt_in_generic (s
);
11779 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
11781 gfc_error ("The type %qs cannot be host associated at %L "
11782 "because it is blocked by an incompatible object "
11783 "of the same name declared at %L",
11784 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11790 /* 4th constraint in section 11.3: "If an object of a type for which
11791 component-initialization is specified (R429) appears in the
11792 specification-part of a module and does not have the ALLOCATABLE
11793 or POINTER attribute, the object shall have the SAVE attribute."
11795 The check for initializers is performed with
11796 gfc_has_default_initializer because gfc_default_initializer generates
11797 a hidden default for allocatable components. */
11798 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11799 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11800 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
11801 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11802 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11803 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11804 "%qs at %L, needed due to the default "
11805 "initialization", sym
->name
, &sym
->declared_at
))
11808 /* Assign default initializer. */
11809 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11810 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11811 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11817 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
11818 except in the declaration of an entity or component that has the POINTER
11819 or ALLOCATABLE attribute. */
11822 deferred_requirements (gfc_symbol
*sym
)
11824 if (sym
->ts
.deferred
11825 && !(sym
->attr
.pointer
11826 || sym
->attr
.allocatable
11827 || sym
->attr
.omp_udr_artificial_var
))
11829 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11830 "requires either the POINTER or ALLOCATABLE attribute",
11831 sym
->name
, &sym
->declared_at
);
11838 /* Resolve symbols with flavor variable. */
11841 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11843 int no_init_flag
, automatic_flag
;
11845 const char *auto_save_msg
;
11846 bool saved_specification_expr
;
11848 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11851 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11854 /* Set this flag to check that variables are parameters of all entries.
11855 This check is effected by the call to gfc_resolve_expr through
11856 is_non_constant_shape_array. */
11857 saved_specification_expr
= specification_expr
;
11858 specification_expr
= true;
11860 if (sym
->ns
->proc_name
11861 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11862 || sym
->ns
->proc_name
->attr
.is_main_program
)
11863 && !sym
->attr
.use_assoc
11864 && !sym
->attr
.allocatable
11865 && !sym
->attr
.pointer
11866 && is_non_constant_shape_array (sym
))
11868 /* F08:C541. The shape of an array defined in a main program or module
11869 * needs to be constant. */
11870 gfc_error ("The module or main program array %qs at %L must "
11871 "have constant shape", sym
->name
, &sym
->declared_at
);
11872 specification_expr
= saved_specification_expr
;
11876 /* Constraints on deferred type parameter. */
11877 if (!deferred_requirements (sym
))
11880 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
11882 /* Make sure that character string variables with assumed length are
11883 dummy arguments. */
11884 e
= sym
->ts
.u
.cl
->length
;
11885 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11886 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11887 && !sym
->attr
.omp_udr_artificial_var
)
11889 gfc_error ("Entity with assumed character length at %L must be a "
11890 "dummy argument or a PARAMETER", &sym
->declared_at
);
11891 specification_expr
= saved_specification_expr
;
11895 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11897 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11898 specification_expr
= saved_specification_expr
;
11902 if (!gfc_is_constant_expr (e
)
11903 && !(e
->expr_type
== EXPR_VARIABLE
11904 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11906 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11907 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11908 || sym
->ns
->proc_name
->attr
.is_main_program
))
11910 gfc_error ("%qs at %L must have constant character length "
11911 "in this context", sym
->name
, &sym
->declared_at
);
11912 specification_expr
= saved_specification_expr
;
11915 if (sym
->attr
.in_common
)
11917 gfc_error ("COMMON variable %qs at %L must have constant "
11918 "character length", sym
->name
, &sym
->declared_at
);
11919 specification_expr
= saved_specification_expr
;
11925 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11926 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11928 /* Determine if the symbol may not have an initializer. */
11929 no_init_flag
= automatic_flag
= 0;
11930 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11931 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11933 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11934 && is_non_constant_shape_array (sym
))
11936 no_init_flag
= automatic_flag
= 1;
11938 /* Also, they must not have the SAVE attribute.
11939 SAVE_IMPLICIT is checked below. */
11940 if (sym
->as
&& sym
->attr
.codimension
)
11942 int corank
= sym
->as
->corank
;
11943 sym
->as
->corank
= 0;
11944 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11945 sym
->as
->corank
= corank
;
11947 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11949 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11950 specification_expr
= saved_specification_expr
;
11955 /* Ensure that any initializer is simplified. */
11957 gfc_simplify_expr (sym
->value
, 1);
11959 /* Reject illegal initializers. */
11960 if (!sym
->mark
&& sym
->value
)
11962 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11963 && CLASS_DATA (sym
)->attr
.allocatable
))
11964 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11965 sym
->name
, &sym
->declared_at
);
11966 else if (sym
->attr
.external
)
11967 gfc_error ("External %qs at %L cannot have an initializer",
11968 sym
->name
, &sym
->declared_at
);
11969 else if (sym
->attr
.dummy
11970 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11971 gfc_error ("Dummy %qs at %L cannot have an initializer",
11972 sym
->name
, &sym
->declared_at
);
11973 else if (sym
->attr
.intrinsic
)
11974 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11975 sym
->name
, &sym
->declared_at
);
11976 else if (sym
->attr
.result
)
11977 gfc_error ("Function result %qs at %L cannot have an initializer",
11978 sym
->name
, &sym
->declared_at
);
11979 else if (automatic_flag
)
11980 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11981 sym
->name
, &sym
->declared_at
);
11983 goto no_init_error
;
11984 specification_expr
= saved_specification_expr
;
11989 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11991 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11992 specification_expr
= saved_specification_expr
;
11996 specification_expr
= saved_specification_expr
;
12001 /* Compare the dummy characteristics of a module procedure interface
12002 declaration with the corresponding declaration in a submodule. */
12003 static gfc_formal_arglist
*new_formal
;
12004 static char errmsg
[200];
12007 compare_fsyms (gfc_symbol
*sym
)
12011 if (sym
== NULL
|| new_formal
== NULL
)
12014 fsym
= new_formal
->sym
;
12019 if (strcmp (sym
->name
, fsym
->name
) == 0)
12021 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12022 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12027 /* Resolve a procedure. */
12030 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12032 gfc_formal_arglist
*arg
;
12034 if (sym
->attr
.function
12035 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12038 if (sym
->ts
.type
== BT_CHARACTER
)
12040 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12042 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12043 && !resolve_charlen (cl
))
12046 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12047 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12049 gfc_error ("Character-valued statement function %qs at %L must "
12050 "have constant length", sym
->name
, &sym
->declared_at
);
12055 /* Ensure that derived type for are not of a private type. Internal
12056 module procedures are excluded by 2.2.3.3 - i.e., they are not
12057 externally accessible and can access all the objects accessible in
12059 if (!(sym
->ns
->parent
12060 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12061 && gfc_check_symbol_access (sym
))
12063 gfc_interface
*iface
;
12065 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12068 && arg
->sym
->ts
.type
== BT_DERIVED
12069 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12070 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12071 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12072 "and cannot be a dummy argument"
12073 " of %qs, which is PUBLIC at %L",
12074 arg
->sym
->name
, sym
->name
,
12075 &sym
->declared_at
))
12077 /* Stop this message from recurring. */
12078 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12083 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12084 PRIVATE to the containing module. */
12085 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12087 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12090 && arg
->sym
->ts
.type
== BT_DERIVED
12091 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12092 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12093 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12094 "PUBLIC interface %qs at %L "
12095 "takes dummy arguments of %qs which "
12096 "is PRIVATE", iface
->sym
->name
,
12097 sym
->name
, &iface
->sym
->declared_at
,
12098 gfc_typename(&arg
->sym
->ts
)))
12100 /* Stop this message from recurring. */
12101 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12108 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12109 && !sym
->attr
.proc_pointer
)
12111 gfc_error ("Function %qs at %L cannot have an initializer",
12112 sym
->name
, &sym
->declared_at
);
12116 /* An external symbol may not have an initializer because it is taken to be
12117 a procedure. Exception: Procedure Pointers. */
12118 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12120 gfc_error ("External object %qs at %L may not have an initializer",
12121 sym
->name
, &sym
->declared_at
);
12125 /* An elemental function is required to return a scalar 12.7.1 */
12126 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
12128 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12129 "result", sym
->name
, &sym
->declared_at
);
12130 /* Reset so that the error only occurs once. */
12131 sym
->attr
.elemental
= 0;
12135 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12136 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12138 gfc_error ("Statement function %qs at %L may not have pointer or "
12139 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12143 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12144 char-len-param shall not be array-valued, pointer-valued, recursive
12145 or pure. ....snip... A character value of * may only be used in the
12146 following ways: (i) Dummy arg of procedure - dummy associates with
12147 actual length; (ii) To declare a named constant; or (iii) External
12148 function - but length must be declared in calling scoping unit. */
12149 if (sym
->attr
.function
12150 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12151 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12153 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12154 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12156 if (sym
->as
&& sym
->as
->rank
)
12157 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12158 "array-valued", sym
->name
, &sym
->declared_at
);
12160 if (sym
->attr
.pointer
)
12161 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12162 "pointer-valued", sym
->name
, &sym
->declared_at
);
12164 if (sym
->attr
.pure
)
12165 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12166 "pure", sym
->name
, &sym
->declared_at
);
12168 if (sym
->attr
.recursive
)
12169 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12170 "recursive", sym
->name
, &sym
->declared_at
);
12175 /* Appendix B.2 of the standard. Contained functions give an
12176 error anyway. Deferred character length is an F2003 feature.
12177 Don't warn on intrinsic conversion functions, which start
12178 with two underscores. */
12179 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12180 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12181 gfc_notify_std (GFC_STD_F95_OBS
,
12182 "CHARACTER(*) function %qs at %L",
12183 sym
->name
, &sym
->declared_at
);
12186 /* F2008, C1218. */
12187 if (sym
->attr
.elemental
)
12189 if (sym
->attr
.proc_pointer
)
12191 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12192 sym
->name
, &sym
->declared_at
);
12195 if (sym
->attr
.dummy
)
12197 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12198 sym
->name
, &sym
->declared_at
);
12203 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12205 gfc_formal_arglist
*curr_arg
;
12206 int has_non_interop_arg
= 0;
12208 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12209 sym
->common_block
))
12211 /* Clear these to prevent looking at them again if there was an
12213 sym
->attr
.is_bind_c
= 0;
12214 sym
->attr
.is_c_interop
= 0;
12215 sym
->ts
.is_c_interop
= 0;
12219 /* So far, no errors have been found. */
12220 sym
->attr
.is_c_interop
= 1;
12221 sym
->ts
.is_c_interop
= 1;
12224 curr_arg
= gfc_sym_get_dummy_args (sym
);
12225 while (curr_arg
!= NULL
)
12227 /* Skip implicitly typed dummy args here. */
12228 if (curr_arg
->sym
->attr
.implicit_type
== 0)
12229 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12230 /* If something is found to fail, record the fact so we
12231 can mark the symbol for the procedure as not being
12232 BIND(C) to try and prevent multiple errors being
12234 has_non_interop_arg
= 1;
12236 curr_arg
= curr_arg
->next
;
12239 /* See if any of the arguments were not interoperable and if so, clear
12240 the procedure symbol to prevent duplicate error messages. */
12241 if (has_non_interop_arg
!= 0)
12243 sym
->attr
.is_c_interop
= 0;
12244 sym
->ts
.is_c_interop
= 0;
12245 sym
->attr
.is_bind_c
= 0;
12249 if (!sym
->attr
.proc_pointer
)
12251 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12253 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12254 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12257 if (sym
->attr
.intent
)
12259 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12260 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12263 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12265 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12266 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12269 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12270 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12271 || sym
->attr
.contained
))
12273 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12274 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12277 if (strcmp ("ppr@", sym
->name
) == 0)
12279 gfc_error ("Procedure pointer result %qs at %L "
12280 "is missing the pointer attribute",
12281 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12286 /* Assume that a procedure whose body is not known has references
12287 to external arrays. */
12288 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12289 sym
->attr
.array_outer_dependency
= 1;
12291 /* Compare the characteristics of a module procedure with the
12292 interface declaration. Ideally this would be done with
12293 gfc_compare_interfaces but, at present, the formal interface
12294 cannot be copied to the ts.interface. */
12295 if (sym
->attr
.module_procedure
12296 && sym
->attr
.if_source
== IFSRC_DECL
)
12299 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12301 char *submodule_name
;
12302 strcpy (name
, sym
->ns
->proc_name
->name
);
12303 module_name
= strtok (name
, ".");
12304 submodule_name
= strtok (NULL
, ".");
12306 iface
= sym
->tlink
;
12309 /* Make sure that the result uses the correct charlen for deferred
12311 if (iface
&& sym
->result
12312 && iface
->ts
.type
== BT_CHARACTER
12313 && iface
->ts
.deferred
)
12314 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12319 /* Check the procedure characteristics. */
12320 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12322 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12323 "PROCEDURE at %L and its interface in %s",
12324 &sym
->declared_at
, module_name
);
12328 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12330 gfc_error ("Mismatch in PURE attribute between MODULE "
12331 "PROCEDURE at %L and its interface in %s",
12332 &sym
->declared_at
, module_name
);
12336 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12338 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12339 "PROCEDURE at %L and its interface in %s",
12340 &sym
->declared_at
, module_name
);
12344 /* Check the result characteristics. */
12345 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12347 gfc_error ("%s between the MODULE PROCEDURE declaration "
12348 "in MODULE %qs and the declaration at %L in "
12350 errmsg
, module_name
, &sym
->declared_at
,
12351 submodule_name
? submodule_name
: module_name
);
12356 /* Check the characteristics of the formal arguments. */
12357 if (sym
->formal
&& sym
->formal_ns
)
12359 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12362 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12370 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12371 been defined and we now know their defined arguments, check that they fulfill
12372 the requirements of the standard for procedures used as finalizers. */
12375 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12377 gfc_finalizer
* list
;
12378 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12379 bool result
= true;
12380 bool seen_scalar
= false;
12383 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12386 gfc_resolve_finalizers (parent
, finalizable
);
12388 /* Ensure that derived-type components have a their finalizers resolved. */
12389 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12390 for (c
= derived
->components
; c
; c
= c
->next
)
12391 if (c
->ts
.type
== BT_DERIVED
12392 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12394 bool has_final2
= false;
12395 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12396 return false; /* Error. */
12397 has_final
= has_final
|| has_final2
;
12399 /* Return early if not finalizable. */
12403 *finalizable
= false;
12407 /* Walk over the list of finalizer-procedures, check them, and if any one
12408 does not fit in with the standard's definition, print an error and remove
12409 it from the list. */
12410 prev_link
= &derived
->f2k_derived
->finalizers
;
12411 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12413 gfc_formal_arglist
*dummy_args
;
12418 /* Skip this finalizer if we already resolved it. */
12419 if (list
->proc_tree
)
12421 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12422 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
12423 seen_scalar
= true;
12424 prev_link
= &(list
->next
);
12428 /* Check this exists and is a SUBROUTINE. */
12429 if (!list
->proc_sym
->attr
.subroutine
)
12431 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12432 list
->proc_sym
->name
, &list
->where
);
12436 /* We should have exactly one argument. */
12437 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12438 if (!dummy_args
|| dummy_args
->next
)
12440 gfc_error ("FINAL procedure at %L must have exactly one argument",
12444 arg
= dummy_args
->sym
;
12446 /* This argument must be of our type. */
12447 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12449 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12450 &arg
->declared_at
, derived
->name
);
12454 /* It must neither be a pointer nor allocatable nor optional. */
12455 if (arg
->attr
.pointer
)
12457 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12458 &arg
->declared_at
);
12461 if (arg
->attr
.allocatable
)
12463 gfc_error ("Argument of FINAL procedure at %L must not be"
12464 " ALLOCATABLE", &arg
->declared_at
);
12467 if (arg
->attr
.optional
)
12469 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12470 &arg
->declared_at
);
12474 /* It must not be INTENT(OUT). */
12475 if (arg
->attr
.intent
== INTENT_OUT
)
12477 gfc_error ("Argument of FINAL procedure at %L must not be"
12478 " INTENT(OUT)", &arg
->declared_at
);
12482 /* Warn if the procedure is non-scalar and not assumed shape. */
12483 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12484 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12485 gfc_warning (OPT_Wsurprising
,
12486 "Non-scalar FINAL procedure at %L should have assumed"
12487 " shape argument", &arg
->declared_at
);
12489 /* Check that it does not match in kind and rank with a FINAL procedure
12490 defined earlier. To really loop over the *earlier* declarations,
12491 we need to walk the tail of the list as new ones were pushed at the
12493 /* TODO: Handle kind parameters once they are implemented. */
12494 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12495 for (i
= list
->next
; i
; i
= i
->next
)
12497 gfc_formal_arglist
*dummy_args
;
12499 /* Argument list might be empty; that is an error signalled earlier,
12500 but we nevertheless continued resolving. */
12501 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12504 gfc_symbol
* i_arg
= dummy_args
->sym
;
12505 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12506 if (i_rank
== my_rank
)
12508 gfc_error ("FINAL procedure %qs declared at %L has the same"
12509 " rank (%d) as %qs",
12510 list
->proc_sym
->name
, &list
->where
, my_rank
,
12511 i
->proc_sym
->name
);
12517 /* Is this the/a scalar finalizer procedure? */
12519 seen_scalar
= true;
12521 /* Find the symtree for this procedure. */
12522 gcc_assert (!list
->proc_tree
);
12523 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12525 prev_link
= &list
->next
;
12528 /* Remove wrong nodes immediately from the list so we don't risk any
12529 troubles in the future when they might fail later expectations. */
12532 *prev_link
= list
->next
;
12533 gfc_free_finalizer (i
);
12537 if (result
== false)
12540 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12541 were nodes in the list, must have been for arrays. It is surely a good
12542 idea to have a scalar version there if there's something to finalize. */
12543 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
12544 gfc_warning (OPT_Wsurprising
,
12545 "Only array FINAL procedures declared for derived type %qs"
12546 " defined at %L, suggest also scalar one",
12547 derived
->name
, &derived
->declared_at
);
12549 vtab
= gfc_find_derived_vtab (derived
);
12550 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12551 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12554 *finalizable
= true;
12560 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12563 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12564 const char* generic_name
, locus where
)
12566 gfc_symbol
*sym1
, *sym2
;
12567 const char *pass1
, *pass2
;
12568 gfc_formal_arglist
*dummy_args
;
12570 gcc_assert (t1
->specific
&& t2
->specific
);
12571 gcc_assert (!t1
->specific
->is_generic
);
12572 gcc_assert (!t2
->specific
->is_generic
);
12573 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12575 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12576 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12581 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12582 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12583 || sym1
->attr
.function
!= sym2
->attr
.function
)
12585 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12586 " GENERIC %qs at %L",
12587 sym1
->name
, sym2
->name
, generic_name
, &where
);
12591 /* Determine PASS arguments. */
12592 if (t1
->specific
->nopass
)
12594 else if (t1
->specific
->pass_arg
)
12595 pass1
= t1
->specific
->pass_arg
;
12598 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12600 pass1
= dummy_args
->sym
->name
;
12604 if (t2
->specific
->nopass
)
12606 else if (t2
->specific
->pass_arg
)
12607 pass2
= t2
->specific
->pass_arg
;
12610 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12612 pass2
= dummy_args
->sym
->name
;
12617 /* Compare the interfaces. */
12618 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12619 NULL
, 0, pass1
, pass2
))
12621 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12622 sym1
->name
, sym2
->name
, generic_name
, &where
);
12630 /* Worker function for resolving a generic procedure binding; this is used to
12631 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12633 The difference between those cases is finding possible inherited bindings
12634 that are overridden, as one has to look for them in tb_sym_root,
12635 tb_uop_root or tb_op, respectively. Thus the caller must already find
12636 the super-type and set p->overridden correctly. */
12639 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12640 gfc_typebound_proc
* p
, const char* name
)
12642 gfc_tbp_generic
* target
;
12643 gfc_symtree
* first_target
;
12644 gfc_symtree
* inherited
;
12646 gcc_assert (p
&& p
->is_generic
);
12648 /* Try to find the specific bindings for the symtrees in our target-list. */
12649 gcc_assert (p
->u
.generic
);
12650 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12651 if (!target
->specific
)
12653 gfc_typebound_proc
* overridden_tbp
;
12654 gfc_tbp_generic
* g
;
12655 const char* target_name
;
12657 target_name
= target
->specific_st
->name
;
12659 /* Defined for this type directly. */
12660 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12662 target
->specific
= target
->specific_st
->n
.tb
;
12663 goto specific_found
;
12666 /* Look for an inherited specific binding. */
12669 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12674 gcc_assert (inherited
->n
.tb
);
12675 target
->specific
= inherited
->n
.tb
;
12676 goto specific_found
;
12680 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12681 " at %L", target_name
, name
, &p
->where
);
12684 /* Once we've found the specific binding, check it is not ambiguous with
12685 other specifics already found or inherited for the same GENERIC. */
12687 gcc_assert (target
->specific
);
12689 /* This must really be a specific binding! */
12690 if (target
->specific
->is_generic
)
12692 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12693 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12697 /* Check those already resolved on this type directly. */
12698 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12699 if (g
!= target
&& g
->specific
12700 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12703 /* Check for ambiguity with inherited specific targets. */
12704 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12705 overridden_tbp
= overridden_tbp
->overridden
)
12706 if (overridden_tbp
->is_generic
)
12708 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12710 gcc_assert (g
->specific
);
12711 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12717 /* If we attempt to "overwrite" a specific binding, this is an error. */
12718 if (p
->overridden
&& !p
->overridden
->is_generic
)
12720 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12721 " the same name", name
, &p
->where
);
12725 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12726 all must have the same attributes here. */
12727 first_target
= p
->u
.generic
->specific
->u
.specific
;
12728 gcc_assert (first_target
);
12729 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12730 p
->function
= first_target
->n
.sym
->attr
.function
;
12736 /* Resolve a GENERIC procedure binding for a derived type. */
12739 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12741 gfc_symbol
* super_type
;
12743 /* Find the overridden binding if any. */
12744 st
->n
.tb
->overridden
= NULL
;
12745 super_type
= gfc_get_derived_super_type (derived
);
12748 gfc_symtree
* overridden
;
12749 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12752 if (overridden
&& overridden
->n
.tb
)
12753 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12756 /* Resolve using worker function. */
12757 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12761 /* Retrieve the target-procedure of an operator binding and do some checks in
12762 common for intrinsic and user-defined type-bound operators. */
12765 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12767 gfc_symbol
* target_proc
;
12769 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12770 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12771 gcc_assert (target_proc
);
12773 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12774 if (target
->specific
->nopass
)
12776 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12780 return target_proc
;
12784 /* Resolve a type-bound intrinsic operator. */
12787 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12788 gfc_typebound_proc
* p
)
12790 gfc_symbol
* super_type
;
12791 gfc_tbp_generic
* target
;
12793 /* If there's already an error here, do nothing (but don't fail again). */
12797 /* Operators should always be GENERIC bindings. */
12798 gcc_assert (p
->is_generic
);
12800 /* Look for an overridden binding. */
12801 super_type
= gfc_get_derived_super_type (derived
);
12802 if (super_type
&& super_type
->f2k_derived
)
12803 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12806 p
->overridden
= NULL
;
12808 /* Resolve general GENERIC properties using worker function. */
12809 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
12812 /* Check the targets to be procedures of correct interface. */
12813 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12815 gfc_symbol
* target_proc
;
12817 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12821 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12824 /* Add target to non-typebound operator list. */
12825 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12826 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12828 gfc_interface
*head
, *intr
;
12830 /* Preempt 'gfc_check_new_interface' for submodules, where the
12831 mechanism for handling module procedures winds up resolving
12832 operator interfaces twice and would otherwise cause an error. */
12833 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
12834 if (intr
->sym
== target_proc
12835 && target_proc
->attr
.used_in_submodule
)
12838 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
12839 target_proc
, p
->where
))
12841 head
= derived
->ns
->op
[op
];
12842 intr
= gfc_get_interface ();
12843 intr
->sym
= target_proc
;
12844 intr
->where
= p
->where
;
12846 derived
->ns
->op
[op
] = intr
;
12858 /* Resolve a type-bound user operator (tree-walker callback). */
12860 static gfc_symbol
* resolve_bindings_derived
;
12861 static bool resolve_bindings_result
;
12863 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12866 resolve_typebound_user_op (gfc_symtree
* stree
)
12868 gfc_symbol
* super_type
;
12869 gfc_tbp_generic
* target
;
12871 gcc_assert (stree
&& stree
->n
.tb
);
12873 if (stree
->n
.tb
->error
)
12876 /* Operators should always be GENERIC bindings. */
12877 gcc_assert (stree
->n
.tb
->is_generic
);
12879 /* Find overridden procedure, if any. */
12880 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12881 if (super_type
&& super_type
->f2k_derived
)
12883 gfc_symtree
* overridden
;
12884 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12885 stree
->name
, true, NULL
);
12887 if (overridden
&& overridden
->n
.tb
)
12888 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12891 stree
->n
.tb
->overridden
= NULL
;
12893 /* Resolve basically using worker function. */
12894 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12897 /* Check the targets to be functions of correct interface. */
12898 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12900 gfc_symbol
* target_proc
;
12902 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12906 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12913 resolve_bindings_result
= false;
12914 stree
->n
.tb
->error
= 1;
12918 /* Resolve the type-bound procedures for a derived type. */
12921 resolve_typebound_procedure (gfc_symtree
* stree
)
12925 gfc_symbol
* me_arg
;
12926 gfc_symbol
* super_type
;
12927 gfc_component
* comp
;
12929 gcc_assert (stree
);
12931 /* Undefined specific symbol from GENERIC target definition. */
12935 if (stree
->n
.tb
->error
)
12938 /* If this is a GENERIC binding, use that routine. */
12939 if (stree
->n
.tb
->is_generic
)
12941 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12946 /* Get the target-procedure to check it. */
12947 gcc_assert (!stree
->n
.tb
->is_generic
);
12948 gcc_assert (stree
->n
.tb
->u
.specific
);
12949 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12950 where
= stree
->n
.tb
->where
;
12952 /* Default access should already be resolved from the parser. */
12953 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12955 if (stree
->n
.tb
->deferred
)
12957 if (!check_proc_interface (proc
, &where
))
12962 /* Check for F08:C465. */
12963 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12964 || (proc
->attr
.proc
!= PROC_MODULE
12965 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12966 || proc
->attr
.abstract
)
12968 gfc_error ("%qs must be a module procedure or an external procedure with"
12969 " an explicit interface at %L", proc
->name
, &where
);
12974 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12975 stree
->n
.tb
->function
= proc
->attr
.function
;
12977 /* Find the super-type of the current derived type. We could do this once and
12978 store in a global if speed is needed, but as long as not I believe this is
12979 more readable and clearer. */
12980 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12982 /* If PASS, resolve and check arguments if not already resolved / loaded
12983 from a .mod file. */
12984 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12986 gfc_formal_arglist
*dummy_args
;
12988 dummy_args
= gfc_sym_get_dummy_args (proc
);
12989 if (stree
->n
.tb
->pass_arg
)
12991 gfc_formal_arglist
*i
;
12993 /* If an explicit passing argument name is given, walk the arg-list
12994 and look for it. */
12997 stree
->n
.tb
->pass_arg_num
= 1;
12998 for (i
= dummy_args
; i
; i
= i
->next
)
13000 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13005 ++stree
->n
.tb
->pass_arg_num
;
13010 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13012 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13013 stree
->n
.tb
->pass_arg
);
13019 /* Otherwise, take the first one; there should in fact be at least
13021 stree
->n
.tb
->pass_arg_num
= 1;
13024 gfc_error ("Procedure %qs with PASS at %L must have at"
13025 " least one argument", proc
->name
, &where
);
13028 me_arg
= dummy_args
->sym
;
13031 /* Now check that the argument-type matches and the passed-object
13032 dummy argument is generally fine. */
13034 gcc_assert (me_arg
);
13036 if (me_arg
->ts
.type
!= BT_CLASS
)
13038 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13039 " at %L", proc
->name
, &where
);
13043 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13044 != resolve_bindings_derived
)
13046 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13047 " the derived-type %qs", me_arg
->name
, proc
->name
,
13048 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13052 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13053 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13055 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13056 " scalar", proc
->name
, &where
);
13059 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13061 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13062 " be ALLOCATABLE", proc
->name
, &where
);
13065 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13067 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13068 " be POINTER", proc
->name
, &where
);
13073 /* If we are extending some type, check that we don't override a procedure
13074 flagged NON_OVERRIDABLE. */
13075 stree
->n
.tb
->overridden
= NULL
;
13078 gfc_symtree
* overridden
;
13079 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13080 stree
->name
, true, NULL
);
13084 if (overridden
->n
.tb
)
13085 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13087 if (!gfc_check_typebound_override (stree
, overridden
))
13092 /* See if there's a name collision with a component directly in this type. */
13093 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13094 if (!strcmp (comp
->name
, stree
->name
))
13096 gfc_error ("Procedure %qs at %L has the same name as a component of"
13098 stree
->name
, &where
, resolve_bindings_derived
->name
);
13102 /* Try to find a name collision with an inherited component. */
13103 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13106 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13107 " component of %qs",
13108 stree
->name
, &where
, resolve_bindings_derived
->name
);
13112 stree
->n
.tb
->error
= 0;
13116 resolve_bindings_result
= false;
13117 stree
->n
.tb
->error
= 1;
13122 resolve_typebound_procedures (gfc_symbol
* derived
)
13125 gfc_symbol
* super_type
;
13127 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13130 super_type
= gfc_get_derived_super_type (derived
);
13132 resolve_symbol (super_type
);
13134 resolve_bindings_derived
= derived
;
13135 resolve_bindings_result
= true;
13137 if (derived
->f2k_derived
->tb_sym_root
)
13138 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13139 &resolve_typebound_procedure
);
13141 if (derived
->f2k_derived
->tb_uop_root
)
13142 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13143 &resolve_typebound_user_op
);
13145 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13147 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13148 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13149 (gfc_intrinsic_op
)op
, p
))
13150 resolve_bindings_result
= false;
13153 return resolve_bindings_result
;
13157 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13158 to give all identical derived types the same backend_decl. */
13160 add_dt_to_dt_list (gfc_symbol
*derived
)
13162 gfc_dt_list
*dt_list
;
13164 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
13165 if (derived
== dt_list
->derived
)
13168 dt_list
= gfc_get_dt_list ();
13169 dt_list
->next
= gfc_derived_types
;
13170 dt_list
->derived
= derived
;
13171 gfc_derived_types
= dt_list
;
13175 /* Ensure that a derived-type is really not abstract, meaning that every
13176 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13179 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13184 if (!ensure_not_abstract_walker (sub
, st
->left
))
13186 if (!ensure_not_abstract_walker (sub
, st
->right
))
13189 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13191 gfc_symtree
* overriding
;
13192 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13195 gcc_assert (overriding
->n
.tb
);
13196 if (overriding
->n
.tb
->deferred
)
13198 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13199 " %qs is DEFERRED and not overridden",
13200 sub
->name
, &sub
->declared_at
, st
->name
);
13209 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13211 /* The algorithm used here is to recursively travel up the ancestry of sub
13212 and for each ancestor-type, check all bindings. If any of them is
13213 DEFERRED, look it up starting from sub and see if the found (overriding)
13214 binding is not DEFERRED.
13215 This is not the most efficient way to do this, but it should be ok and is
13216 clearer than something sophisticated. */
13218 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13220 if (!ancestor
->attr
.abstract
)
13223 /* Walk bindings of this ancestor. */
13224 if (ancestor
->f2k_derived
)
13227 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13232 /* Find next ancestor type and recurse on it. */
13233 ancestor
= gfc_get_derived_super_type (ancestor
);
13235 return ensure_not_abstract (sub
, ancestor
);
13241 /* This check for typebound defined assignments is done recursively
13242 since the order in which derived types are resolved is not always in
13243 order of the declarations. */
13246 check_defined_assignments (gfc_symbol
*derived
)
13250 for (c
= derived
->components
; c
; c
= c
->next
)
13252 if (!gfc_bt_struct (c
->ts
.type
)
13254 || c
->attr
.allocatable
13255 || c
->attr
.proc_pointer_comp
13256 || c
->attr
.class_pointer
13257 || c
->attr
.proc_pointer
)
13260 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13261 || (c
->ts
.u
.derived
->f2k_derived
13262 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13264 derived
->attr
.defined_assign_comp
= 1;
13268 check_defined_assignments (c
->ts
.u
.derived
);
13269 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13271 derived
->attr
.defined_assign_comp
= 1;
13278 /* Resolve a single component of a derived type or structure. */
13281 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13283 gfc_symbol
*super_type
;
13285 if (c
->attr
.artificial
)
13289 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13290 && c
->attr
.codimension
13291 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13293 gfc_error ("Coarray component %qs at %L must be allocatable with "
13294 "deferred shape", c
->name
, &c
->loc
);
13299 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13300 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13302 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13303 "shall not be a coarray", c
->name
, &c
->loc
);
13308 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13309 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13310 || c
->attr
.allocatable
))
13312 gfc_error ("Component %qs at %L with coarray component "
13313 "shall be a nonpointer, nonallocatable scalar",
13319 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13321 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13322 "is not an array pointer", c
->name
, &c
->loc
);
13326 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13328 gfc_symbol
*ifc
= c
->ts
.interface
;
13330 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13336 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13338 /* Resolve interface and copy attributes. */
13339 if (ifc
->formal
&& !ifc
->formal_ns
)
13340 resolve_symbol (ifc
);
13341 if (ifc
->attr
.intrinsic
)
13342 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13346 c
->ts
= ifc
->result
->ts
;
13347 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13348 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13349 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13350 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13351 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13356 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13357 c
->attr
.pointer
= ifc
->attr
.pointer
;
13358 c
->attr
.dimension
= ifc
->attr
.dimension
;
13359 c
->as
= gfc_copy_array_spec (ifc
->as
);
13360 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13362 c
->ts
.interface
= ifc
;
13363 c
->attr
.function
= ifc
->attr
.function
;
13364 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13366 c
->attr
.pure
= ifc
->attr
.pure
;
13367 c
->attr
.elemental
= ifc
->attr
.elemental
;
13368 c
->attr
.recursive
= ifc
->attr
.recursive
;
13369 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13370 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13371 /* Copy char length. */
13372 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13374 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13375 if (cl
->length
&& !cl
->resolved
13376 && !gfc_resolve_expr (cl
->length
))
13385 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13387 /* Since PPCs are not implicitly typed, a PPC without an explicit
13388 interface must be a subroutine. */
13389 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13392 /* Procedure pointer components: Check PASS arg. */
13393 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13394 && !sym
->attr
.vtype
)
13396 gfc_symbol
* me_arg
;
13398 if (c
->tb
->pass_arg
)
13400 gfc_formal_arglist
* i
;
13402 /* If an explicit passing argument name is given, walk the arg-list
13403 and look for it. */
13406 c
->tb
->pass_arg_num
= 1;
13407 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13409 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13414 c
->tb
->pass_arg_num
++;
13419 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13420 "at %L has no argument %qs", c
->name
,
13421 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13428 /* Otherwise, take the first one; there should in fact be at least
13430 c
->tb
->pass_arg_num
= 1;
13431 if (!c
->ts
.interface
->formal
)
13433 gfc_error ("Procedure pointer component %qs with PASS at %L "
13434 "must have at least one argument",
13439 me_arg
= c
->ts
.interface
->formal
->sym
;
13442 /* Now check that the argument-type matches. */
13443 gcc_assert (me_arg
);
13444 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13445 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13446 || (me_arg
->ts
.type
== BT_CLASS
13447 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13449 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13450 " the derived type %qs", me_arg
->name
, c
->name
,
13451 me_arg
->name
, &c
->loc
, sym
->name
);
13456 /* Check for C453. */
13457 if (me_arg
->attr
.dimension
)
13459 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13460 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13466 if (me_arg
->attr
.pointer
)
13468 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13469 "may not have the POINTER attribute", me_arg
->name
,
13470 c
->name
, me_arg
->name
, &c
->loc
);
13475 if (me_arg
->attr
.allocatable
)
13477 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13478 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13479 me_arg
->name
, &c
->loc
);
13484 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13486 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13487 " at %L", c
->name
, &c
->loc
);
13493 /* Check type-spec if this is not the parent-type component. */
13494 if (((sym
->attr
.is_class
13495 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13496 || c
!= sym
->components
->ts
.u
.derived
->components
))
13497 || (!sym
->attr
.is_class
13498 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13499 && !sym
->attr
.vtype
13500 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13503 super_type
= gfc_get_derived_super_type (sym
);
13505 /* If this type is an extension, set the accessibility of the parent
13508 && ((sym
->attr
.is_class
13509 && c
== sym
->components
->ts
.u
.derived
->components
)
13510 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13511 && strcmp (super_type
->name
, c
->name
) == 0)
13512 c
->attr
.access
= super_type
->attr
.access
;
13514 /* If this type is an extension, see if this component has the same name
13515 as an inherited type-bound procedure. */
13516 if (super_type
&& !sym
->attr
.is_class
13517 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13519 gfc_error ("Component %qs of %qs at %L has the same name as an"
13520 " inherited type-bound procedure",
13521 c
->name
, sym
->name
, &c
->loc
);
13525 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13526 && !c
->ts
.deferred
)
13528 if (c
->ts
.u
.cl
->length
== NULL
13529 || (!resolve_charlen(c
->ts
.u
.cl
))
13530 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13532 gfc_error ("Character length of component %qs needs to "
13533 "be a constant specification expression at %L",
13535 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13540 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13541 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13543 gfc_error ("Character component %qs of %qs at %L with deferred "
13544 "length must be a POINTER or ALLOCATABLE",
13545 c
->name
, sym
->name
, &c
->loc
);
13549 /* Add the hidden deferred length field. */
13550 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
13551 && !sym
->attr
.is_class
)
13553 char name
[GFC_MAX_SYMBOL_LEN
+9];
13554 gfc_component
*strlen
;
13555 sprintf (name
, "_%s_length", c
->name
);
13556 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
13557 if (strlen
== NULL
)
13559 if (!gfc_add_component (sym
, name
, &strlen
))
13561 strlen
->ts
.type
= BT_INTEGER
;
13562 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13563 strlen
->attr
.access
= ACCESS_PRIVATE
;
13564 strlen
->attr
.artificial
= 1;
13568 if (c
->ts
.type
== BT_DERIVED
13569 && sym
->component_access
!= ACCESS_PRIVATE
13570 && gfc_check_symbol_access (sym
)
13571 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13572 && !c
->ts
.u
.derived
->attr
.use_assoc
13573 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13574 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13575 "PRIVATE type and cannot be a component of "
13576 "%qs, which is PUBLIC at %L", c
->name
,
13577 sym
->name
, &sym
->declared_at
))
13580 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13582 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13583 "type %s", c
->name
, &c
->loc
, sym
->name
);
13587 if (sym
->attr
.sequence
)
13589 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13591 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13592 "not have the SEQUENCE attribute",
13593 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13598 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13599 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13600 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13601 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13602 CLASS_DATA (c
)->ts
.u
.derived
13603 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13605 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13606 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13607 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13609 gfc_error ("The pointer component %qs of %qs at %L is a type "
13610 "that has not been declared", c
->name
, sym
->name
,
13615 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13616 && CLASS_DATA (c
)->attr
.class_pointer
13617 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13618 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13619 && !UNLIMITED_POLY (c
))
13621 gfc_error ("The pointer component %qs of %qs at %L is a type "
13622 "that has not been declared", c
->name
, sym
->name
,
13627 /* If an allocatable component derived type is of the same type as
13628 the enclosing derived type, we need a vtable generating so that
13629 the __deallocate procedure is created. */
13630 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
13631 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
13632 gfc_find_vtab (&c
->ts
);
13634 /* Ensure that all the derived type components are put on the
13635 derived type list; even in formal namespaces, where derived type
13636 pointer components might not have been declared. */
13637 if (c
->ts
.type
== BT_DERIVED
13639 && c
->ts
.u
.derived
->components
13641 && sym
!= c
->ts
.u
.derived
)
13642 add_dt_to_dt_list (c
->ts
.u
.derived
);
13644 if (!gfc_resolve_array_spec (c
->as
,
13645 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13646 || c
->attr
.allocatable
)))
13649 if (c
->initializer
&& !sym
->attr
.vtype
13650 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13657 /* Be nice about the locus for a structure expression - show the locus of the
13658 first non-null sub-expression if we can. */
13661 cons_where (gfc_expr
*struct_expr
)
13663 gfc_constructor
*cons
;
13665 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
13667 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
13668 for (; cons
; cons
= gfc_constructor_next (cons
))
13670 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
13671 return &cons
->expr
->where
;
13674 return &struct_expr
->where
;
13677 /* Resolve the components of a structure type. Much less work than derived
13681 resolve_fl_struct (gfc_symbol
*sym
)
13684 gfc_expr
*init
= NULL
;
13687 /* Make sure UNIONs do not have overlapping initializers. */
13688 if (sym
->attr
.flavor
== FL_UNION
)
13690 for (c
= sym
->components
; c
; c
= c
->next
)
13692 if (init
&& c
->initializer
)
13694 gfc_error ("Conflicting initializers in union at %L and %L",
13695 cons_where (init
), cons_where (c
->initializer
));
13696 gfc_free_expr (c
->initializer
);
13697 c
->initializer
= NULL
;
13700 init
= c
->initializer
;
13705 for (c
= sym
->components
; c
; c
= c
->next
)
13706 if (!resolve_component (c
, sym
))
13712 if (sym
->components
)
13713 add_dt_to_dt_list (sym
);
13719 /* Resolve the components of a derived type. This does not have to wait until
13720 resolution stage, but can be done as soon as the dt declaration has been
13724 resolve_fl_derived0 (gfc_symbol
*sym
)
13726 gfc_symbol
* super_type
;
13730 if (sym
->attr
.unlimited_polymorphic
)
13733 super_type
= gfc_get_derived_super_type (sym
);
13736 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
13738 gfc_error ("As extending type %qs at %L has a coarray component, "
13739 "parent type %qs shall also have one", sym
->name
,
13740 &sym
->declared_at
, super_type
->name
);
13744 /* Ensure the extended type gets resolved before we do. */
13745 if (super_type
&& !resolve_fl_derived0 (super_type
))
13748 /* An ABSTRACT type must be extensible. */
13749 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
13751 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
13752 sym
->name
, &sym
->declared_at
);
13756 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
13760 for ( ; c
!= NULL
; c
= c
->next
)
13761 if (!resolve_component (c
, sym
))
13767 check_defined_assignments (sym
);
13769 if (!sym
->attr
.defined_assign_comp
&& super_type
)
13770 sym
->attr
.defined_assign_comp
13771 = super_type
->attr
.defined_assign_comp
;
13773 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13774 all DEFERRED bindings are overridden. */
13775 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
13776 && !sym
->attr
.is_class
13777 && !ensure_not_abstract (sym
, super_type
))
13780 /* Add derived type to the derived type list. */
13781 add_dt_to_dt_list (sym
);
13787 /* The following procedure does the full resolution of a derived type,
13788 including resolution of all type-bound procedures (if present). In contrast
13789 to 'resolve_fl_derived0' this can only be done after the module has been
13790 parsed completely. */
13793 resolve_fl_derived (gfc_symbol
*sym
)
13795 gfc_symbol
*gen_dt
= NULL
;
13797 if (sym
->attr
.unlimited_polymorphic
)
13800 if (!sym
->attr
.is_class
)
13801 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
13802 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
13803 && (!gen_dt
->generic
->sym
->attr
.use_assoc
13804 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
13805 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
13806 "%qs at %L being the same name as derived "
13807 "type at %L", sym
->name
,
13808 gen_dt
->generic
->sym
== sym
13809 ? gen_dt
->generic
->next
->sym
->name
13810 : gen_dt
->generic
->sym
->name
,
13811 gen_dt
->generic
->sym
== sym
13812 ? &gen_dt
->generic
->next
->sym
->declared_at
13813 : &gen_dt
->generic
->sym
->declared_at
,
13814 &sym
->declared_at
))
13817 /* Resolve the finalizer procedures. */
13818 if (!gfc_resolve_finalizers (sym
, NULL
))
13821 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
13823 /* Fix up incomplete CLASS symbols. */
13824 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
13825 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
13827 /* Nothing more to do for unlimited polymorphic entities. */
13828 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
13830 else if (vptr
->ts
.u
.derived
== NULL
)
13832 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
13834 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
13835 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
13840 if (!resolve_fl_derived0 (sym
))
13843 /* Resolve the type-bound procedures. */
13844 if (!resolve_typebound_procedures (sym
))
13852 resolve_fl_namelist (gfc_symbol
*sym
)
13857 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13859 /* Check again, the check in match only works if NAMELIST comes
13861 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
13863 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13864 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13868 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
13869 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13870 "with assumed shape in namelist %qs at %L",
13871 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13874 if (is_non_constant_shape_array (nl
->sym
)
13875 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13876 "with nonconstant shape in namelist %qs at %L",
13877 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13880 if (nl
->sym
->ts
.type
== BT_CHARACTER
13881 && (nl
->sym
->ts
.u
.cl
->length
== NULL
13882 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13883 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13884 "nonconstant character length in "
13885 "namelist %qs at %L", nl
->sym
->name
,
13886 sym
->name
, &sym
->declared_at
))
13891 /* Reject PRIVATE objects in a PUBLIC namelist. */
13892 if (gfc_check_symbol_access (sym
))
13894 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13896 if (!nl
->sym
->attr
.use_assoc
13897 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13898 && !gfc_check_symbol_access (nl
->sym
))
13900 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13901 "cannot be member of PUBLIC namelist %qs at %L",
13902 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13906 if (nl
->sym
->ts
.type
== BT_DERIVED
13907 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13908 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13910 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13911 "namelist %qs at %L with ALLOCATABLE "
13912 "or POINTER components", nl
->sym
->name
,
13913 sym
->name
, &sym
->declared_at
))
13918 /* Types with private components that came here by USE-association. */
13919 if (nl
->sym
->ts
.type
== BT_DERIVED
13920 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13922 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13923 "components and cannot be member of namelist %qs at %L",
13924 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13928 /* Types with private components that are defined in the same module. */
13929 if (nl
->sym
->ts
.type
== BT_DERIVED
13930 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13931 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13933 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13934 "cannot be a member of PUBLIC namelist %qs at %L",
13935 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13942 /* 14.1.2 A module or internal procedure represent local entities
13943 of the same type as a namelist member and so are not allowed. */
13944 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13946 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13949 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13950 if ((nl
->sym
== sym
->ns
->proc_name
)
13952 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13957 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13958 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13960 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13961 "attribute in %qs at %L", nlsym
->name
,
13962 &sym
->declared_at
);
13972 resolve_fl_parameter (gfc_symbol
*sym
)
13974 /* A parameter array's shape needs to be constant. */
13975 if (sym
->as
!= NULL
13976 && (sym
->as
->type
== AS_DEFERRED
13977 || is_non_constant_shape_array (sym
)))
13979 gfc_error ("Parameter array %qs at %L cannot be automatic "
13980 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13984 /* Constraints on deferred type parameter. */
13985 if (!deferred_requirements (sym
))
13988 /* Make sure a parameter that has been implicitly typed still
13989 matches the implicit type, since PARAMETER statements can precede
13990 IMPLICIT statements. */
13991 if (sym
->attr
.implicit_type
13992 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13995 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13996 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14000 /* Make sure the types of derived parameters are consistent. This
14001 type checking is deferred until resolution because the type may
14002 refer to a derived type from the host. */
14003 if (sym
->ts
.type
== BT_DERIVED
14004 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14006 gfc_error ("Incompatible derived type in PARAMETER at %L",
14007 &sym
->value
->where
);
14011 /* F03:C509,C514. */
14012 if (sym
->ts
.type
== BT_CLASS
)
14014 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14015 sym
->name
, &sym
->declared_at
);
14023 /* Do anything necessary to resolve a symbol. Right now, we just
14024 assume that an otherwise unknown symbol is a variable. This sort
14025 of thing commonly happens for symbols in module. */
14028 resolve_symbol (gfc_symbol
*sym
)
14030 int check_constant
, mp_flag
;
14031 gfc_symtree
*symtree
;
14032 gfc_symtree
*this_symtree
;
14035 symbol_attribute class_attr
;
14036 gfc_array_spec
*as
;
14037 bool saved_specification_expr
;
14043 /* No symbol will ever have union type; only components can be unions.
14044 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14045 (just like derived type declaration symbols have flavor FL_DERIVED). */
14046 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14048 /* Coarrayed polymorphic objects with allocatable or pointer components are
14049 yet unsupported for -fcoarray=lib. */
14050 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14051 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14052 && CLASS_DATA (sym
)->attr
.codimension
14053 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14054 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14056 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14057 "type coarrays at %L are unsupported", &sym
->declared_at
);
14061 if (sym
->attr
.artificial
)
14064 if (sym
->attr
.unlimited_polymorphic
)
14067 if (sym
->attr
.flavor
== FL_UNKNOWN
14068 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14069 && !sym
->attr
.generic
&& !sym
->attr
.external
14070 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14071 && sym
->ts
.type
== BT_UNKNOWN
))
14074 /* If we find that a flavorless symbol is an interface in one of the
14075 parent namespaces, find its symtree in this namespace, free the
14076 symbol and set the symtree to point to the interface symbol. */
14077 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14079 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14080 if (symtree
&& (symtree
->n
.sym
->generic
||
14081 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14082 && sym
->ns
->construct_entities
)))
14084 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14086 if (this_symtree
->n
.sym
== sym
)
14088 symtree
->n
.sym
->refs
++;
14089 gfc_release_symbol (sym
);
14090 this_symtree
->n
.sym
= symtree
->n
.sym
;
14096 /* Otherwise give it a flavor according to such attributes as
14098 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14099 && sym
->attr
.intrinsic
== 0)
14100 sym
->attr
.flavor
= FL_VARIABLE
;
14101 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14103 sym
->attr
.flavor
= FL_PROCEDURE
;
14104 if (sym
->attr
.dimension
)
14105 sym
->attr
.function
= 1;
14109 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14110 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14112 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14113 && !resolve_procedure_interface (sym
))
14116 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14117 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14119 if (sym
->attr
.external
)
14120 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14121 "at %L", &sym
->declared_at
);
14123 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14124 "at %L", &sym
->declared_at
);
14129 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14132 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14133 && !resolve_fl_struct (sym
))
14136 /* Symbols that are module procedures with results (functions) have
14137 the types and array specification copied for type checking in
14138 procedures that call them, as well as for saving to a module
14139 file. These symbols can't stand the scrutiny that their results
14141 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14143 /* Make sure that the intrinsic is consistent with its internal
14144 representation. This needs to be done before assigning a default
14145 type to avoid spurious warnings. */
14146 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14147 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14150 /* Resolve associate names. */
14152 resolve_assoc_var (sym
, true);
14154 /* Assign default type to symbols that need one and don't have one. */
14155 if (sym
->ts
.type
== BT_UNKNOWN
)
14157 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14159 gfc_set_default_type (sym
, 1, NULL
);
14162 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14163 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14164 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14165 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14167 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14169 /* The specific case of an external procedure should emit an error
14170 in the case that there is no implicit type. */
14173 if (!sym
->attr
.mixed_entry_master
)
14174 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14178 /* Result may be in another namespace. */
14179 resolve_symbol (sym
->result
);
14181 if (!sym
->result
->attr
.proc_pointer
)
14183 sym
->ts
= sym
->result
->ts
;
14184 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14185 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14186 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14187 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14188 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14193 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14195 bool saved_specification_expr
= specification_expr
;
14196 specification_expr
= true;
14197 gfc_resolve_array_spec (sym
->result
->as
, false);
14198 specification_expr
= saved_specification_expr
;
14201 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14203 as
= CLASS_DATA (sym
)->as
;
14204 class_attr
= CLASS_DATA (sym
)->attr
;
14205 class_attr
.pointer
= class_attr
.class_pointer
;
14209 class_attr
= sym
->attr
;
14214 if (sym
->attr
.contiguous
14215 && (!class_attr
.dimension
14216 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14217 && !class_attr
.pointer
)))
14219 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14220 "array pointer or an assumed-shape or assumed-rank array",
14221 sym
->name
, &sym
->declared_at
);
14225 /* Assumed size arrays and assumed shape arrays must be dummy
14226 arguments. Array-spec's of implied-shape should have been resolved to
14227 AS_EXPLICIT already. */
14231 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
14232 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14233 || as
->type
== AS_ASSUMED_SHAPE
)
14234 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14236 if (as
->type
== AS_ASSUMED_SIZE
)
14237 gfc_error ("Assumed size array at %L must be a dummy argument",
14238 &sym
->declared_at
);
14240 gfc_error ("Assumed shape array at %L must be a dummy argument",
14241 &sym
->declared_at
);
14244 /* TS 29113, C535a. */
14245 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14246 && !sym
->attr
.select_type_temporary
)
14248 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14249 &sym
->declared_at
);
14252 if (as
->type
== AS_ASSUMED_RANK
14253 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14255 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14256 "CODIMENSION attribute", &sym
->declared_at
);
14261 /* Make sure symbols with known intent or optional are really dummy
14262 variable. Because of ENTRY statement, this has to be deferred
14263 until resolution time. */
14265 if (!sym
->attr
.dummy
14266 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14268 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14272 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14274 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14275 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14279 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14281 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14282 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14284 gfc_error ("Character dummy variable %qs at %L with VALUE "
14285 "attribute must have constant length",
14286 sym
->name
, &sym
->declared_at
);
14290 if (sym
->ts
.is_c_interop
14291 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14293 gfc_error ("C interoperable character dummy variable %qs at %L "
14294 "with VALUE attribute must have length one",
14295 sym
->name
, &sym
->declared_at
);
14300 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14301 && sym
->ts
.u
.derived
->attr
.generic
)
14303 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14304 if (!sym
->ts
.u
.derived
)
14306 gfc_error ("The derived type %qs at %L is of type %qs, "
14307 "which has not been defined", sym
->name
,
14308 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14309 sym
->ts
.type
= BT_UNKNOWN
;
14314 /* Use the same constraints as TYPE(*), except for the type check
14315 and that only scalars and assumed-size arrays are permitted. */
14316 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14318 if (!sym
->attr
.dummy
)
14320 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14321 "a dummy argument", sym
->name
, &sym
->declared_at
);
14325 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14326 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14327 && sym
->ts
.type
!= BT_COMPLEX
)
14329 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14330 "of type TYPE(*) or of an numeric intrinsic type",
14331 sym
->name
, &sym
->declared_at
);
14335 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14336 || sym
->attr
.pointer
|| sym
->attr
.value
)
14338 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14339 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14340 "attribute", sym
->name
, &sym
->declared_at
);
14344 if (sym
->attr
.intent
== INTENT_OUT
)
14346 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14347 "have the INTENT(OUT) attribute",
14348 sym
->name
, &sym
->declared_at
);
14351 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14353 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14354 "either be a scalar or an assumed-size array",
14355 sym
->name
, &sym
->declared_at
);
14359 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14360 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14362 sym
->ts
.type
= BT_ASSUMED
;
14363 sym
->as
= gfc_get_array_spec ();
14364 sym
->as
->type
= AS_ASSUMED_SIZE
;
14366 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14368 else if (sym
->ts
.type
== BT_ASSUMED
)
14370 /* TS 29113, C407a. */
14371 if (!sym
->attr
.dummy
)
14373 gfc_error ("Assumed type of variable %s at %L is only permitted "
14374 "for dummy variables", sym
->name
, &sym
->declared_at
);
14377 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14378 || sym
->attr
.pointer
|| sym
->attr
.value
)
14380 gfc_error ("Assumed-type variable %s at %L may not have the "
14381 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14382 sym
->name
, &sym
->declared_at
);
14385 if (sym
->attr
.intent
== INTENT_OUT
)
14387 gfc_error ("Assumed-type variable %s at %L may not have the "
14388 "INTENT(OUT) attribute",
14389 sym
->name
, &sym
->declared_at
);
14392 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14394 gfc_error ("Assumed-type variable %s at %L shall not be an "
14395 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14400 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
14401 do this for something that was implicitly typed because that is handled
14402 in gfc_set_default_type. Handle dummy arguments and procedure
14403 definitions separately. Also, anything that is use associated is not
14404 handled here but instead is handled in the module it is declared in.
14405 Finally, derived type definitions are allowed to be BIND(C) since that
14406 only implies that they're interoperable, and they are checked fully for
14407 interoperability when a variable is declared of that type. */
14408 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
14409 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
14410 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
14414 /* First, make sure the variable is declared at the
14415 module-level scope (J3/04-007, Section 15.3). */
14416 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
14417 sym
->attr
.in_common
== 0)
14419 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14420 "is neither a COMMON block nor declared at the "
14421 "module level scope", sym
->name
, &(sym
->declared_at
));
14424 else if (sym
->common_head
!= NULL
)
14426 t
= verify_com_block_vars_c_interop (sym
->common_head
);
14430 /* If type() declaration, we need to verify that the components
14431 of the given type are all C interoperable, etc. */
14432 if (sym
->ts
.type
== BT_DERIVED
&&
14433 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
14435 /* Make sure the user marked the derived type as BIND(C). If
14436 not, call the verify routine. This could print an error
14437 for the derived type more than once if multiple variables
14438 of that type are declared. */
14439 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
14440 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
14444 /* Verify the variable itself as C interoperable if it
14445 is BIND(C). It is not possible for this to succeed if
14446 the verify_bind_c_derived_type failed, so don't have to handle
14447 any error returned by verify_bind_c_derived_type. */
14448 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
14449 sym
->common_block
);
14454 /* clear the is_bind_c flag to prevent reporting errors more than
14455 once if something failed. */
14456 sym
->attr
.is_bind_c
= 0;
14461 /* If a derived type symbol has reached this point, without its
14462 type being declared, we have an error. Notice that most
14463 conditions that produce undefined derived types have already
14464 been dealt with. However, the likes of:
14465 implicit type(t) (t) ..... call foo (t) will get us here if
14466 the type is not declared in the scope of the implicit
14467 statement. Change the type to BT_UNKNOWN, both because it is so
14468 and to prevent an ICE. */
14469 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14470 && sym
->ts
.u
.derived
->components
== NULL
14471 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14473 gfc_error ("The derived type %qs at %L is of type %qs, "
14474 "which has not been defined", sym
->name
,
14475 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14476 sym
->ts
.type
= BT_UNKNOWN
;
14480 /* Make sure that the derived type has been resolved and that the
14481 derived type is visible in the symbol's namespace, if it is a
14482 module function and is not PRIVATE. */
14483 if (sym
->ts
.type
== BT_DERIVED
14484 && sym
->ts
.u
.derived
->attr
.use_assoc
14485 && sym
->ns
->proc_name
14486 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14487 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14490 /* Unless the derived-type declaration is use associated, Fortran 95
14491 does not allow public entries of private derived types.
14492 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14493 161 in 95-006r3. */
14494 if (sym
->ts
.type
== BT_DERIVED
14495 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14496 && !sym
->ts
.u
.derived
->attr
.use_assoc
14497 && gfc_check_symbol_access (sym
)
14498 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14499 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14500 "derived type %qs",
14501 (sym
->attr
.flavor
== FL_PARAMETER
)
14502 ? "parameter" : "variable",
14503 sym
->name
, &sym
->declared_at
,
14504 sym
->ts
.u
.derived
->name
))
14507 /* F2008, C1302. */
14508 if (sym
->ts
.type
== BT_DERIVED
14509 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14510 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14511 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14512 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14514 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14515 "type LOCK_TYPE must be a coarray", sym
->name
,
14516 &sym
->declared_at
);
14520 /* TS18508, C702/C703. */
14521 if (sym
->ts
.type
== BT_DERIVED
14522 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14523 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14524 || sym
->ts
.u
.derived
->attr
.event_comp
)
14525 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14527 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14528 "type EVENT_TYPE must be a coarray", sym
->name
,
14529 &sym
->declared_at
);
14533 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14534 default initialization is defined (5.1.2.4.4). */
14535 if (sym
->ts
.type
== BT_DERIVED
14537 && sym
->attr
.intent
== INTENT_OUT
14539 && sym
->as
->type
== AS_ASSUMED_SIZE
)
14541 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
14543 if (c
->initializer
)
14545 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14546 "ASSUMED SIZE and so cannot have a default initializer",
14547 sym
->name
, &sym
->declared_at
);
14554 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14555 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
14557 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14558 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14563 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14564 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
14566 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14567 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14572 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14573 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14574 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14575 || class_attr
.codimension
)
14576 && (sym
->attr
.result
|| sym
->result
== sym
))
14578 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14579 "a coarray component", sym
->name
, &sym
->declared_at
);
14584 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
14585 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
14587 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14588 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
14593 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14594 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14595 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14596 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
14597 || class_attr
.allocatable
))
14599 gfc_error ("Variable %qs at %L with coarray component shall be a "
14600 "nonpointer, nonallocatable scalar, which is not a coarray",
14601 sym
->name
, &sym
->declared_at
);
14605 /* F2008, C526. The function-result case was handled above. */
14606 if (class_attr
.codimension
14607 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
14608 || sym
->attr
.select_type_temporary
14609 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14610 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14611 || sym
->ns
->proc_name
->attr
.is_main_program
14612 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
14614 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14615 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
14619 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
14620 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
14622 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
14623 "deferred shape", sym
->name
, &sym
->declared_at
);
14626 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
14627 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
14629 gfc_error ("Allocatable coarray variable %qs at %L must have "
14630 "deferred shape", sym
->name
, &sym
->declared_at
);
14635 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14636 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14637 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14638 || (class_attr
.codimension
&& class_attr
.allocatable
))
14639 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
14641 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
14642 "allocatable coarray or have coarray components",
14643 sym
->name
, &sym
->declared_at
);
14647 if (class_attr
.codimension
&& sym
->attr
.dummy
14648 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
14650 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
14651 "procedure %qs", sym
->name
, &sym
->declared_at
,
14652 sym
->ns
->proc_name
->name
);
14656 if (sym
->ts
.type
== BT_LOGICAL
14657 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
14658 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
14659 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
14662 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
14663 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
14665 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
14666 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
14667 "%L with non-C_Bool kind in BIND(C) procedure "
14668 "%qs", sym
->name
, &sym
->declared_at
,
14669 sym
->ns
->proc_name
->name
))
14671 else if (!gfc_logical_kinds
[i
].c_bool
14672 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
14673 "%qs at %L with non-C_Bool kind in "
14674 "BIND(C) procedure %qs", sym
->name
,
14676 sym
->attr
.function
? sym
->name
14677 : sym
->ns
->proc_name
->name
))
14681 switch (sym
->attr
.flavor
)
14684 if (!resolve_fl_variable (sym
, mp_flag
))
14689 if (sym
->formal
&& !sym
->formal_ns
)
14691 /* Check that none of the arguments are a namelist. */
14692 gfc_formal_arglist
*formal
= sym
->formal
;
14694 for (; formal
; formal
= formal
->next
)
14695 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
14697 gfc_error ("Namelist %qs can not be an argument to "
14698 "subroutine or function at %L",
14699 formal
->sym
->name
, &sym
->declared_at
);
14704 if (!resolve_fl_procedure (sym
, mp_flag
))
14709 if (!resolve_fl_namelist (sym
))
14714 if (!resolve_fl_parameter (sym
))
14722 /* Resolve array specifier. Check as well some constraints
14723 on COMMON blocks. */
14725 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
14727 /* Set the formal_arg_flag so that check_conflict will not throw
14728 an error for host associated variables in the specification
14729 expression for an array_valued function. */
14730 if (sym
->attr
.function
&& sym
->as
)
14731 formal_arg_flag
= true;
14733 saved_specification_expr
= specification_expr
;
14734 specification_expr
= true;
14735 gfc_resolve_array_spec (sym
->as
, check_constant
);
14736 specification_expr
= saved_specification_expr
;
14738 formal_arg_flag
= false;
14740 /* Resolve formal namespaces. */
14741 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
14742 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
14743 gfc_resolve (sym
->formal_ns
);
14745 /* Make sure the formal namespace is present. */
14746 if (sym
->formal
&& !sym
->formal_ns
)
14748 gfc_formal_arglist
*formal
= sym
->formal
;
14749 while (formal
&& !formal
->sym
)
14750 formal
= formal
->next
;
14754 sym
->formal_ns
= formal
->sym
->ns
;
14755 if (sym
->ns
!= formal
->sym
->ns
)
14756 sym
->formal_ns
->refs
++;
14760 /* Check threadprivate restrictions. */
14761 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
14762 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14763 && (!sym
->attr
.in_common
14764 && sym
->module
== NULL
14765 && (sym
->ns
->proc_name
== NULL
14766 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14767 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
14769 /* Check omp declare target restrictions. */
14770 if (sym
->attr
.omp_declare_target
14771 && sym
->attr
.flavor
== FL_VARIABLE
14773 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14774 && (!sym
->attr
.in_common
14775 && sym
->module
== NULL
14776 && (sym
->ns
->proc_name
== NULL
14777 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14778 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14779 sym
->name
, &sym
->declared_at
);
14781 /* If we have come this far we can apply default-initializers, as
14782 described in 14.7.5, to those variables that have not already
14783 been assigned one. */
14784 if (sym
->ts
.type
== BT_DERIVED
14786 && !sym
->attr
.allocatable
14787 && !sym
->attr
.alloc_comp
)
14789 symbol_attribute
*a
= &sym
->attr
;
14791 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
14792 && !a
->in_common
&& !a
->use_assoc
14793 && !a
->result
&& !a
->function
)
14794 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
14795 apply_default_init (sym
);
14796 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
14797 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14798 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14799 /* Mark the result symbol to be referenced, when it has allocatable
14801 sym
->result
->attr
.referenced
= 1;
14804 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
14805 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
14806 && !CLASS_DATA (sym
)->attr
.class_pointer
14807 && !CLASS_DATA (sym
)->attr
.allocatable
)
14808 apply_default_init (sym
);
14810 /* If this symbol has a type-spec, check it. */
14811 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
14812 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
14813 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
14818 /************* Resolve DATA statements *************/
14822 gfc_data_value
*vnode
;
14828 /* Advance the values structure to point to the next value in the data list. */
14831 next_data_value (void)
14833 while (mpz_cmp_ui (values
.left
, 0) == 0)
14836 if (values
.vnode
->next
== NULL
)
14839 values
.vnode
= values
.vnode
->next
;
14840 mpz_set (values
.left
, values
.vnode
->repeat
);
14848 check_data_variable (gfc_data_variable
*var
, locus
*where
)
14854 ar_type mark
= AR_UNKNOWN
;
14856 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
14862 if (!gfc_resolve_expr (var
->expr
))
14866 mpz_init_set_si (offset
, 0);
14869 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
14870 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
14871 e
= e
->value
.function
.actual
->expr
;
14873 if (e
->expr_type
!= EXPR_VARIABLE
)
14874 gfc_internal_error ("check_data_variable(): Bad expression");
14876 sym
= e
->symtree
->n
.sym
;
14878 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
14880 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
14881 sym
->name
, &sym
->declared_at
);
14884 if (e
->ref
== NULL
&& sym
->as
)
14886 gfc_error ("DATA array %qs at %L must be specified in a previous"
14887 " declaration", sym
->name
, where
);
14891 has_pointer
= sym
->attr
.pointer
;
14893 if (gfc_is_coindexed (e
))
14895 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
14900 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14902 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
14906 && ref
->type
== REF_ARRAY
14907 && ref
->u
.ar
.type
!= AR_FULL
)
14909 gfc_error ("DATA element %qs at %L is a pointer and so must "
14910 "be a full array", sym
->name
, where
);
14915 if (e
->rank
== 0 || has_pointer
)
14917 mpz_init_set_ui (size
, 1);
14924 /* Find the array section reference. */
14925 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14927 if (ref
->type
!= REF_ARRAY
)
14929 if (ref
->u
.ar
.type
== AR_ELEMENT
)
14935 /* Set marks according to the reference pattern. */
14936 switch (ref
->u
.ar
.type
)
14944 /* Get the start position of array section. */
14945 gfc_get_section_index (ar
, section_index
, &offset
);
14950 gcc_unreachable ();
14953 if (!gfc_array_size (e
, &size
))
14955 gfc_error ("Nonconstant array section at %L in DATA statement",
14957 mpz_clear (offset
);
14964 while (mpz_cmp_ui (size
, 0) > 0)
14966 if (!next_data_value ())
14968 gfc_error ("DATA statement at %L has more variables than values",
14974 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14978 /* If we have more than one element left in the repeat count,
14979 and we have more than one element left in the target variable,
14980 then create a range assignment. */
14981 /* FIXME: Only done for full arrays for now, since array sections
14983 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14984 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14988 if (mpz_cmp (size
, values
.left
) >= 0)
14990 mpz_init_set (range
, values
.left
);
14991 mpz_sub (size
, size
, values
.left
);
14992 mpz_set_ui (values
.left
, 0);
14996 mpz_init_set (range
, size
);
14997 mpz_sub (values
.left
, values
.left
, size
);
14998 mpz_set_ui (size
, 0);
15001 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15004 mpz_add (offset
, offset
, range
);
15011 /* Assign initial value to symbol. */
15014 mpz_sub_ui (values
.left
, values
.left
, 1);
15015 mpz_sub_ui (size
, size
, 1);
15017 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15022 if (mark
== AR_FULL
)
15023 mpz_add_ui (offset
, offset
, 1);
15025 /* Modify the array section indexes and recalculate the offset
15026 for next element. */
15027 else if (mark
== AR_SECTION
)
15028 gfc_advance_section (section_index
, ar
, &offset
);
15032 if (mark
== AR_SECTION
)
15034 for (i
= 0; i
< ar
->dimen
; i
++)
15035 mpz_clear (section_index
[i
]);
15039 mpz_clear (offset
);
15045 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15047 /* Iterate over a list of elements in a DATA statement. */
15050 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15053 iterator_stack frame
;
15054 gfc_expr
*e
, *start
, *end
, *step
;
15055 bool retval
= true;
15057 mpz_init (frame
.value
);
15060 start
= gfc_copy_expr (var
->iter
.start
);
15061 end
= gfc_copy_expr (var
->iter
.end
);
15062 step
= gfc_copy_expr (var
->iter
.step
);
15064 if (!gfc_simplify_expr (start
, 1)
15065 || start
->expr_type
!= EXPR_CONSTANT
)
15067 gfc_error ("start of implied-do loop at %L could not be "
15068 "simplified to a constant value", &start
->where
);
15072 if (!gfc_simplify_expr (end
, 1)
15073 || end
->expr_type
!= EXPR_CONSTANT
)
15075 gfc_error ("end of implied-do loop at %L could not be "
15076 "simplified to a constant value", &start
->where
);
15080 if (!gfc_simplify_expr (step
, 1)
15081 || step
->expr_type
!= EXPR_CONSTANT
)
15083 gfc_error ("step of implied-do loop at %L could not be "
15084 "simplified to a constant value", &start
->where
);
15089 mpz_set (trip
, end
->value
.integer
);
15090 mpz_sub (trip
, trip
, start
->value
.integer
);
15091 mpz_add (trip
, trip
, step
->value
.integer
);
15093 mpz_div (trip
, trip
, step
->value
.integer
);
15095 mpz_set (frame
.value
, start
->value
.integer
);
15097 frame
.prev
= iter_stack
;
15098 frame
.variable
= var
->iter
.var
->symtree
;
15099 iter_stack
= &frame
;
15101 while (mpz_cmp_ui (trip
, 0) > 0)
15103 if (!traverse_data_var (var
->list
, where
))
15109 e
= gfc_copy_expr (var
->expr
);
15110 if (!gfc_simplify_expr (e
, 1))
15117 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15119 mpz_sub_ui (trip
, trip
, 1);
15123 mpz_clear (frame
.value
);
15126 gfc_free_expr (start
);
15127 gfc_free_expr (end
);
15128 gfc_free_expr (step
);
15130 iter_stack
= frame
.prev
;
15135 /* Type resolve variables in the variable list of a DATA statement. */
15138 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15142 for (; var
; var
= var
->next
)
15144 if (var
->expr
== NULL
)
15145 t
= traverse_data_list (var
, where
);
15147 t
= check_data_variable (var
, where
);
15157 /* Resolve the expressions and iterators associated with a data statement.
15158 This is separate from the assignment checking because data lists should
15159 only be resolved once. */
15162 resolve_data_variables (gfc_data_variable
*d
)
15164 for (; d
; d
= d
->next
)
15166 if (d
->list
== NULL
)
15168 if (!gfc_resolve_expr (d
->expr
))
15173 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15176 if (!resolve_data_variables (d
->list
))
15185 /* Resolve a single DATA statement. We implement this by storing a pointer to
15186 the value list into static variables, and then recursively traversing the
15187 variables list, expanding iterators and such. */
15190 resolve_data (gfc_data
*d
)
15193 if (!resolve_data_variables (d
->var
))
15196 values
.vnode
= d
->value
;
15197 if (d
->value
== NULL
)
15198 mpz_set_ui (values
.left
, 0);
15200 mpz_set (values
.left
, d
->value
->repeat
);
15202 if (!traverse_data_var (d
->var
, &d
->where
))
15205 /* At this point, we better not have any values left. */
15207 if (next_data_value ())
15208 gfc_error ("DATA statement at %L has more values than variables",
15213 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15214 accessed by host or use association, is a dummy argument to a pure function,
15215 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15216 is storage associated with any such variable, shall not be used in the
15217 following contexts: (clients of this function). */
15219 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15220 procedure. Returns zero if assignment is OK, nonzero if there is a
15223 gfc_impure_variable (gfc_symbol
*sym
)
15228 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15231 /* Check if the symbol's ns is inside the pure procedure. */
15232 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15236 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15240 proc
= sym
->ns
->proc_name
;
15241 if (sym
->attr
.dummy
15242 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15243 || proc
->attr
.function
))
15246 /* TODO: Sort out what can be storage associated, if anything, and include
15247 it here. In principle equivalences should be scanned but it does not
15248 seem to be possible to storage associate an impure variable this way. */
15253 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15254 current namespace is inside a pure procedure. */
15257 gfc_pure (gfc_symbol
*sym
)
15259 symbol_attribute attr
;
15264 /* Check if the current namespace or one of its parents
15265 belongs to a pure procedure. */
15266 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15268 sym
= ns
->proc_name
;
15272 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15280 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15284 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15285 checks if the current namespace is implicitly pure. Note that this
15286 function returns false for a PURE procedure. */
15289 gfc_implicit_pure (gfc_symbol
*sym
)
15295 /* Check if the current procedure is implicit_pure. Walk up
15296 the procedure list until we find a procedure. */
15297 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15299 sym
= ns
->proc_name
;
15303 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15308 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15309 && !sym
->attr
.pure
;
15314 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15320 /* Check if the current procedure is implicit_pure. Walk up
15321 the procedure list until we find a procedure. */
15322 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15324 sym
= ns
->proc_name
;
15328 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15333 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15334 sym
->attr
.implicit_pure
= 0;
15336 sym
->attr
.pure
= 0;
15340 /* Test whether the current procedure is elemental or not. */
15343 gfc_elemental (gfc_symbol
*sym
)
15345 symbol_attribute attr
;
15348 sym
= gfc_current_ns
->proc_name
;
15353 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15357 /* Warn about unused labels. */
15360 warn_unused_fortran_label (gfc_st_label
*label
)
15365 warn_unused_fortran_label (label
->left
);
15367 if (label
->defined
== ST_LABEL_UNKNOWN
)
15370 switch (label
->referenced
)
15372 case ST_LABEL_UNKNOWN
:
15373 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
15374 label
->value
, &label
->where
);
15377 case ST_LABEL_BAD_TARGET
:
15378 gfc_warning (OPT_Wunused_label
,
15379 "Label %d at %L defined but cannot be used",
15380 label
->value
, &label
->where
);
15387 warn_unused_fortran_label (label
->right
);
15391 /* Returns the sequence type of a symbol or sequence. */
15394 sequence_type (gfc_typespec ts
)
15403 if (ts
.u
.derived
->components
== NULL
)
15404 return SEQ_NONDEFAULT
;
15406 result
= sequence_type (ts
.u
.derived
->components
->ts
);
15407 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
15408 if (sequence_type (c
->ts
) != result
)
15414 if (ts
.kind
!= gfc_default_character_kind
)
15415 return SEQ_NONDEFAULT
;
15417 return SEQ_CHARACTER
;
15420 if (ts
.kind
!= gfc_default_integer_kind
)
15421 return SEQ_NONDEFAULT
;
15423 return SEQ_NUMERIC
;
15426 if (!(ts
.kind
== gfc_default_real_kind
15427 || ts
.kind
== gfc_default_double_kind
))
15428 return SEQ_NONDEFAULT
;
15430 return SEQ_NUMERIC
;
15433 if (ts
.kind
!= gfc_default_complex_kind
)
15434 return SEQ_NONDEFAULT
;
15436 return SEQ_NUMERIC
;
15439 if (ts
.kind
!= gfc_default_logical_kind
)
15440 return SEQ_NONDEFAULT
;
15442 return SEQ_NUMERIC
;
15445 return SEQ_NONDEFAULT
;
15450 /* Resolve derived type EQUIVALENCE object. */
15453 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
15455 gfc_component
*c
= derived
->components
;
15460 /* Shall not be an object of nonsequence derived type. */
15461 if (!derived
->attr
.sequence
)
15463 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15464 "attribute to be an EQUIVALENCE object", sym
->name
,
15469 /* Shall not have allocatable components. */
15470 if (derived
->attr
.alloc_comp
)
15472 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15473 "components to be an EQUIVALENCE object",sym
->name
,
15478 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
15480 gfc_error ("Derived type variable %qs at %L with default "
15481 "initialization cannot be in EQUIVALENCE with a variable "
15482 "in COMMON", sym
->name
, &e
->where
);
15486 for (; c
; c
= c
->next
)
15488 if (gfc_bt_struct (c
->ts
.type
)
15489 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15492 /* Shall not be an object of sequence derived type containing a pointer
15493 in the structure. */
15494 if (c
->attr
.pointer
)
15496 gfc_error ("Derived type variable %qs at %L with pointer "
15497 "component(s) cannot be an EQUIVALENCE object",
15498 sym
->name
, &e
->where
);
15506 /* Resolve equivalence object.
15507 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15508 an allocatable array, an object of nonsequence derived type, an object of
15509 sequence derived type containing a pointer at any level of component
15510 selection, an automatic object, a function name, an entry name, a result
15511 name, a named constant, a structure component, or a subobject of any of
15512 the preceding objects. A substring shall not have length zero. A
15513 derived type shall not have components with default initialization nor
15514 shall two objects of an equivalence group be initialized.
15515 Either all or none of the objects shall have an protected attribute.
15516 The simple constraints are done in symbol.c(check_conflict) and the rest
15517 are implemented here. */
15520 resolve_equivalence (gfc_equiv
*eq
)
15523 gfc_symbol
*first_sym
;
15526 locus
*last_where
= NULL
;
15527 seq_type eq_type
, last_eq_type
;
15528 gfc_typespec
*last_ts
;
15529 int object
, cnt_protected
;
15532 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
15534 first_sym
= eq
->expr
->symtree
->n
.sym
;
15538 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
15542 e
->ts
= e
->symtree
->n
.sym
->ts
;
15543 /* match_varspec might not know yet if it is seeing
15544 array reference or substring reference, as it doesn't
15546 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
15548 gfc_ref
*ref
= e
->ref
;
15549 sym
= e
->symtree
->n
.sym
;
15551 if (sym
->attr
.dimension
)
15553 ref
->u
.ar
.as
= sym
->as
;
15557 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15558 if (e
->ts
.type
== BT_CHARACTER
15560 && ref
->type
== REF_ARRAY
15561 && ref
->u
.ar
.dimen
== 1
15562 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
15563 && ref
->u
.ar
.stride
[0] == NULL
)
15565 gfc_expr
*start
= ref
->u
.ar
.start
[0];
15566 gfc_expr
*end
= ref
->u
.ar
.end
[0];
15569 /* Optimize away the (:) reference. */
15570 if (start
== NULL
&& end
== NULL
)
15573 e
->ref
= ref
->next
;
15575 e
->ref
->next
= ref
->next
;
15580 ref
->type
= REF_SUBSTRING
;
15582 start
= gfc_get_int_expr (gfc_default_integer_kind
,
15584 ref
->u
.ss
.start
= start
;
15585 if (end
== NULL
&& e
->ts
.u
.cl
)
15586 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
15587 ref
->u
.ss
.end
= end
;
15588 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
15595 /* Any further ref is an error. */
15598 gcc_assert (ref
->type
== REF_ARRAY
);
15599 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15605 if (!gfc_resolve_expr (e
))
15608 sym
= e
->symtree
->n
.sym
;
15610 if (sym
->attr
.is_protected
)
15612 if (cnt_protected
> 0 && cnt_protected
!= object
)
15614 gfc_error ("Either all or none of the objects in the "
15615 "EQUIVALENCE set at %L shall have the "
15616 "PROTECTED attribute",
15621 /* Shall not equivalence common block variables in a PURE procedure. */
15622 if (sym
->ns
->proc_name
15623 && sym
->ns
->proc_name
->attr
.pure
15624 && sym
->attr
.in_common
)
15626 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
15627 "object in the pure procedure %qs",
15628 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
15632 /* Shall not be a named constant. */
15633 if (e
->expr_type
== EXPR_CONSTANT
)
15635 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
15636 "object", sym
->name
, &e
->where
);
15640 if (e
->ts
.type
== BT_DERIVED
15641 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
15644 /* Check that the types correspond correctly:
15646 A numeric sequence structure may be equivalenced to another sequence
15647 structure, an object of default integer type, default real type, double
15648 precision real type, default logical type such that components of the
15649 structure ultimately only become associated to objects of the same
15650 kind. A character sequence structure may be equivalenced to an object
15651 of default character kind or another character sequence structure.
15652 Other objects may be equivalenced only to objects of the same type and
15653 kind parameters. */
15655 /* Identical types are unconditionally OK. */
15656 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
15657 goto identical_types
;
15659 last_eq_type
= sequence_type (*last_ts
);
15660 eq_type
= sequence_type (sym
->ts
);
15662 /* Since the pair of objects is not of the same type, mixed or
15663 non-default sequences can be rejected. */
15665 msg
= "Sequence %s with mixed components in EQUIVALENCE "
15666 "statement at %L with different type objects";
15668 && last_eq_type
== SEQ_MIXED
15669 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15670 || (eq_type
== SEQ_MIXED
15671 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15674 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
15675 "statement at %L with objects of different type";
15677 && last_eq_type
== SEQ_NONDEFAULT
15678 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15679 || (eq_type
== SEQ_NONDEFAULT
15680 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15683 msg
="Non-CHARACTER object %qs in default CHARACTER "
15684 "EQUIVALENCE statement at %L";
15685 if (last_eq_type
== SEQ_CHARACTER
15686 && eq_type
!= SEQ_CHARACTER
15687 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15690 msg
="Non-NUMERIC object %qs in default NUMERIC "
15691 "EQUIVALENCE statement at %L";
15692 if (last_eq_type
== SEQ_NUMERIC
15693 && eq_type
!= SEQ_NUMERIC
15694 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15699 last_where
= &e
->where
;
15704 /* Shall not be an automatic array. */
15705 if (e
->ref
->type
== REF_ARRAY
15706 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
15708 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15709 "an EQUIVALENCE object", sym
->name
, &e
->where
);
15716 /* Shall not be a structure component. */
15717 if (r
->type
== REF_COMPONENT
)
15719 gfc_error ("Structure component %qs at %L cannot be an "
15720 "EQUIVALENCE object",
15721 r
->u
.c
.component
->name
, &e
->where
);
15725 /* A substring shall not have length zero. */
15726 if (r
->type
== REF_SUBSTRING
)
15728 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
15730 gfc_error ("Substring at %L has length zero",
15731 &r
->u
.ss
.start
->where
);
15741 /* Function called by resolve_fntype to flag other symbol used in the
15742 length type parameter specification of function resuls. */
15745 flag_fn_result_spec (gfc_expr
*expr
,
15746 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
15747 int *f ATTRIBUTE_UNUSED
)
15752 if (expr
->expr_type
== EXPR_VARIABLE
)
15754 s
= expr
->symtree
->n
.sym
;
15755 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
15759 if (!s
->fn_result_spec
15760 && s
->attr
.flavor
== FL_PARAMETER
)
15762 /* Function contained in a module.... */
15763 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
15766 s
->fn_result_spec
= 1;
15767 /* Make sure that this symbol is translated as a module
15769 st
= gfc_get_unique_symtree (ns
);
15773 /* ... which is use associated and called. */
15774 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
15776 /* External function matched with an interface. */
15779 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
15780 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15781 && s
->ns
->proc_name
->attr
.function
))
15782 s
->fn_result_spec
= 1;
15789 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15792 resolve_fntype (gfc_namespace
*ns
)
15794 gfc_entry_list
*el
;
15797 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
15800 /* If there are any entries, ns->proc_name is the entry master
15801 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15803 sym
= ns
->entries
->sym
;
15805 sym
= ns
->proc_name
;
15806 if (sym
->result
== sym
15807 && sym
->ts
.type
== BT_UNKNOWN
15808 && !gfc_set_default_type (sym
, 0, NULL
)
15809 && !sym
->attr
.untyped
)
15811 gfc_error ("Function %qs at %L has no IMPLICIT type",
15812 sym
->name
, &sym
->declared_at
);
15813 sym
->attr
.untyped
= 1;
15816 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
15817 && !sym
->attr
.contained
15818 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15819 && gfc_check_symbol_access (sym
))
15821 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
15822 "%L of PRIVATE type %qs", sym
->name
,
15823 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15827 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
15829 if (el
->sym
->result
== el
->sym
15830 && el
->sym
->ts
.type
== BT_UNKNOWN
15831 && !gfc_set_default_type (el
->sym
, 0, NULL
)
15832 && !el
->sym
->attr
.untyped
)
15834 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
15835 el
->sym
->name
, &el
->sym
->declared_at
);
15836 el
->sym
->attr
.untyped
= 1;
15840 if (sym
->ts
.type
== BT_CHARACTER
)
15841 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, NULL
, flag_fn_result_spec
, 0);
15845 /* 12.3.2.1.1 Defined operators. */
15848 check_uop_procedure (gfc_symbol
*sym
, locus where
)
15850 gfc_formal_arglist
*formal
;
15852 if (!sym
->attr
.function
)
15854 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
15855 sym
->name
, &where
);
15859 if (sym
->ts
.type
== BT_CHARACTER
15860 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
15861 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
15862 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
15864 gfc_error ("User operator procedure %qs at %L cannot be assumed "
15865 "character length", sym
->name
, &where
);
15869 formal
= gfc_sym_get_dummy_args (sym
);
15870 if (!formal
|| !formal
->sym
)
15872 gfc_error ("User operator procedure %qs at %L must have at least "
15873 "one argument", sym
->name
, &where
);
15877 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15879 gfc_error ("First argument of operator interface at %L must be "
15880 "INTENT(IN)", &where
);
15884 if (formal
->sym
->attr
.optional
)
15886 gfc_error ("First argument of operator interface at %L cannot be "
15887 "optional", &where
);
15891 formal
= formal
->next
;
15892 if (!formal
|| !formal
->sym
)
15895 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15897 gfc_error ("Second argument of operator interface at %L must be "
15898 "INTENT(IN)", &where
);
15902 if (formal
->sym
->attr
.optional
)
15904 gfc_error ("Second argument of operator interface at %L cannot be "
15905 "optional", &where
);
15911 gfc_error ("Operator interface at %L must have, at most, two "
15912 "arguments", &where
);
15920 gfc_resolve_uops (gfc_symtree
*symtree
)
15922 gfc_interface
*itr
;
15924 if (symtree
== NULL
)
15927 gfc_resolve_uops (symtree
->left
);
15928 gfc_resolve_uops (symtree
->right
);
15930 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
15931 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
15935 /* Examine all of the expressions associated with a program unit,
15936 assign types to all intermediate expressions, make sure that all
15937 assignments are to compatible types and figure out which names
15938 refer to which functions or subroutines. It doesn't check code
15939 block, which is handled by gfc_resolve_code. */
15942 resolve_types (gfc_namespace
*ns
)
15948 gfc_namespace
* old_ns
= gfc_current_ns
;
15950 if (ns
->types_resolved
)
15953 /* Check that all IMPLICIT types are ok. */
15954 if (!ns
->seen_implicit_none
)
15957 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
15958 if (ns
->set_flag
[letter
]
15959 && !resolve_typespec_used (&ns
->default_type
[letter
],
15960 &ns
->implicit_loc
[letter
], NULL
))
15964 gfc_current_ns
= ns
;
15966 resolve_entries (ns
);
15968 resolve_common_vars (&ns
->blank_common
, false);
15969 resolve_common_blocks (ns
->common_root
);
15971 resolve_contained_functions (ns
);
15973 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
15974 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15975 resolve_formal_arglist (ns
->proc_name
);
15977 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
15979 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
15980 resolve_charlen (cl
);
15982 gfc_traverse_ns (ns
, resolve_symbol
);
15984 resolve_fntype (ns
);
15986 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15988 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
15989 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
15990 "also be PURE", n
->proc_name
->name
,
15991 &n
->proc_name
->declared_at
);
15997 gfc_do_concurrent_flag
= 0;
15998 gfc_check_interfaces (ns
);
16000 gfc_traverse_ns (ns
, resolve_values
);
16006 for (d
= ns
->data
; d
; d
= d
->next
)
16010 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16012 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16014 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16015 resolve_equivalence (eq
);
16017 /* Warn about unused labels. */
16018 if (warn_unused_label
)
16019 warn_unused_fortran_label (ns
->st_labels
);
16021 gfc_resolve_uops (ns
->uop_root
);
16023 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16025 gfc_resolve_omp_declare_simd (ns
);
16027 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16029 ns
->types_resolved
= 1;
16031 gfc_current_ns
= old_ns
;
16035 /* Call gfc_resolve_code recursively. */
16038 resolve_codes (gfc_namespace
*ns
)
16041 bitmap_obstack old_obstack
;
16043 if (ns
->resolved
== 1)
16046 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16049 gfc_current_ns
= ns
;
16051 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16052 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16055 /* Set to an out of range value. */
16056 current_entry_id
= -1;
16058 old_obstack
= labels_obstack
;
16059 bitmap_obstack_initialize (&labels_obstack
);
16061 gfc_resolve_oacc_declare (ns
);
16062 gfc_resolve_code (ns
->code
, ns
);
16064 bitmap_obstack_release (&labels_obstack
);
16065 labels_obstack
= old_obstack
;
16069 /* This function is called after a complete program unit has been compiled.
16070 Its purpose is to examine all of the expressions associated with a program
16071 unit, assign types to all intermediate expressions, make sure that all
16072 assignments are to compatible types and figure out which names refer to
16073 which functions or subroutines. */
16076 gfc_resolve (gfc_namespace
*ns
)
16078 gfc_namespace
*old_ns
;
16079 code_stack
*old_cs_base
;
16080 struct gfc_omp_saved_state old_omp_state
;
16086 old_ns
= gfc_current_ns
;
16087 old_cs_base
= cs_base
;
16089 /* As gfc_resolve can be called during resolution of an OpenMP construct
16090 body, we should clear any state associated to it, so that say NS's
16091 DO loops are not interpreted as OpenMP loops. */
16092 if (!ns
->construct_entities
)
16093 gfc_omp_save_and_clear_state (&old_omp_state
);
16095 resolve_types (ns
);
16096 component_assignment_level
= 0;
16097 resolve_codes (ns
);
16099 gfc_current_ns
= old_ns
;
16100 cs_base
= old_cs_base
;
16103 gfc_run_passes (ns
);
16105 if (!ns
->construct_entities
)
16106 gfc_omp_restore_state (&old_omp_state
);