1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2018 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 %qs 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
);
1134 /* A Parameterized Derived Type constructor must contain values for
1135 the PDT KIND parameters or they must have a default initializer.
1136 Go through the constructor picking out the KIND expressions,
1137 storing them in 'param_list' and then call gfc_get_pdt_instance
1138 to obtain the PDT instance. */
1140 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1143 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1145 param
= gfc_get_actual_arglist ();
1147 param_list
= param_tail
= param
;
1150 param_tail
->next
= param
;
1151 param_tail
= param_tail
->next
;
1154 param_tail
->name
= c
->name
;
1156 param_tail
->expr
= gfc_copy_expr (expr
);
1157 else if (c
->initializer
)
1158 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1161 param_tail
->spec_type
= SPEC_ASSUMED
;
1162 if (c
->attr
.pdt_kind
)
1164 gfc_error ("The KIND parameter %qs in the PDT constructor "
1165 "at %C has no value", param
->name
);
1174 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1175 gfc_symbol
*derived
)
1177 gfc_constructor
*cons
= NULL
;
1178 gfc_component
*comp
;
1181 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1182 cons
= gfc_constructor_first (expr
->value
.constructor
);
1187 comp
= derived
->components
;
1189 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1192 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1193 && comp
->ts
.type
== BT_DERIVED
)
1195 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1199 else if (comp
->ts
.type
== BT_DERIVED
)
1201 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1205 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1206 && derived
->attr
.pdt_template
)
1208 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1217 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1218 static bool resolve_fl_struct (gfc_symbol
*sym
);
1221 /* Resolve all of the elements of a structure constructor and make sure that
1222 the types are correct. The 'init' flag indicates that the given
1223 constructor is an initializer. */
1226 resolve_structure_cons (gfc_expr
*expr
, int init
)
1228 gfc_constructor
*cons
;
1229 gfc_component
*comp
;
1235 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1237 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1238 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1240 resolve_fl_struct (expr
->ts
.u
.derived
);
1242 /* If this is a Parameterized Derived Type template, find the
1243 instance corresponding to the PDT kind parameters. */
1244 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1247 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1250 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1252 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1255 gfc_free_actual_arglist (param_list
);
1257 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1262 cons
= gfc_constructor_first (expr
->value
.constructor
);
1264 /* A constructor may have references if it is the result of substituting a
1265 parameter variable. In this case we just pull out the component we
1268 comp
= expr
->ref
->u
.c
.sym
->components
;
1270 comp
= expr
->ts
.u
.derived
->components
;
1272 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1279 /* Unions use an EXPR_NULL contrived expression to tell the translation
1280 phase to generate an initializer of the appropriate length.
1282 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1285 if (!gfc_resolve_expr (cons
->expr
))
1291 rank
= comp
->as
? comp
->as
->rank
: 0;
1292 if (comp
->ts
.type
== BT_CLASS
1293 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1294 && CLASS_DATA (comp
)->as
)
1295 rank
= CLASS_DATA (comp
)->as
->rank
;
1297 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1298 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1300 gfc_error ("The rank of the element in the structure "
1301 "constructor at %L does not match that of the "
1302 "component (%d/%d)", &cons
->expr
->where
,
1303 cons
->expr
->rank
, rank
);
1307 /* If we don't have the right type, try to convert it. */
1309 if (!comp
->attr
.proc_pointer
&&
1310 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1312 if (strcmp (comp
->name
, "_extends") == 0)
1314 /* Can afford to be brutal with the _extends initializer.
1315 The derived type can get lost because it is PRIVATE
1316 but it is not usage constrained by the standard. */
1317 cons
->expr
->ts
= comp
->ts
;
1319 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1321 gfc_error ("The element in the structure constructor at %L, "
1322 "for pointer component %qs, is %s but should be %s",
1323 &cons
->expr
->where
, comp
->name
,
1324 gfc_basic_typename (cons
->expr
->ts
.type
),
1325 gfc_basic_typename (comp
->ts
.type
));
1330 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1336 /* For strings, the length of the constructor should be the same as
1337 the one of the structure, ensure this if the lengths are known at
1338 compile time and when we are dealing with PARAMETER or structure
1340 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1341 && comp
->ts
.u
.cl
->length
1342 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1343 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1344 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1345 && cons
->expr
->rank
!= 0
1346 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1347 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1349 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1350 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1352 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1353 to make use of the gfc_resolve_character_array_constructor
1354 machinery. The expression is later simplified away to
1355 an array of string literals. */
1356 gfc_expr
*para
= cons
->expr
;
1357 cons
->expr
= gfc_get_expr ();
1358 cons
->expr
->ts
= para
->ts
;
1359 cons
->expr
->where
= para
->where
;
1360 cons
->expr
->expr_type
= EXPR_ARRAY
;
1361 cons
->expr
->rank
= para
->rank
;
1362 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1363 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1364 para
, &cons
->expr
->where
);
1367 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1369 /* Rely on the cleanup of the namespace to deal correctly with
1370 the old charlen. (There was a block here that attempted to
1371 remove the charlen but broke the chain in so doing.) */
1372 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1373 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1374 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1375 gfc_resolve_character_array_constructor (cons
->expr
);
1379 if (cons
->expr
->expr_type
== EXPR_NULL
1380 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1381 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1382 || (comp
->ts
.type
== BT_CLASS
1383 && (CLASS_DATA (comp
)->attr
.class_pointer
1384 || CLASS_DATA (comp
)->attr
.allocatable
))))
1387 gfc_error ("The NULL in the structure constructor at %L is "
1388 "being applied to component %qs, which is neither "
1389 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1393 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1395 /* Check procedure pointer interface. */
1396 gfc_symbol
*s2
= NULL
;
1401 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1404 s2
= c2
->ts
.interface
;
1407 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1409 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1410 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1412 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1414 s2
= cons
->expr
->symtree
->n
.sym
;
1415 name
= cons
->expr
->symtree
->n
.sym
->name
;
1418 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1419 err
, sizeof (err
), NULL
, NULL
))
1421 gfc_error_opt (OPT_Wargument_mismatch
,
1422 "Interface mismatch for procedure-pointer "
1423 "component %qs in structure constructor at %L:"
1424 " %s", comp
->name
, &cons
->expr
->where
, err
);
1429 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1430 || cons
->expr
->expr_type
== EXPR_NULL
)
1433 a
= gfc_expr_attr (cons
->expr
);
1435 if (!a
.pointer
&& !a
.target
)
1438 gfc_error ("The element in the structure constructor at %L, "
1439 "for pointer component %qs should be a POINTER or "
1440 "a TARGET", &cons
->expr
->where
, comp
->name
);
1445 /* F08:C461. Additional checks for pointer initialization. */
1449 gfc_error ("Pointer initialization target at %L "
1450 "must not be ALLOCATABLE", &cons
->expr
->where
);
1455 gfc_error ("Pointer initialization target at %L "
1456 "must have the SAVE attribute", &cons
->expr
->where
);
1460 /* F2003, C1272 (3). */
1461 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1462 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1463 || gfc_is_coindexed (cons
->expr
));
1464 if (impure
&& gfc_pure (NULL
))
1467 gfc_error ("Invalid expression in the structure constructor for "
1468 "pointer component %qs at %L in PURE procedure",
1469 comp
->name
, &cons
->expr
->where
);
1473 gfc_unset_implicit_pure (NULL
);
1480 /****************** Expression name resolution ******************/
1482 /* Returns 0 if a symbol was not declared with a type or
1483 attribute declaration statement, nonzero otherwise. */
1486 was_declared (gfc_symbol
*sym
)
1492 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1495 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1496 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1497 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1498 || a
.asynchronous
|| a
.codimension
)
1505 /* Determine if a symbol is generic or not. */
1508 generic_sym (gfc_symbol
*sym
)
1512 if (sym
->attr
.generic
||
1513 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1516 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1519 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1526 return generic_sym (s
);
1533 /* Determine if a symbol is specific or not. */
1536 specific_sym (gfc_symbol
*sym
)
1540 if (sym
->attr
.if_source
== IFSRC_IFBODY
1541 || sym
->attr
.proc
== PROC_MODULE
1542 || sym
->attr
.proc
== PROC_INTERNAL
1543 || sym
->attr
.proc
== PROC_ST_FUNCTION
1544 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1545 || sym
->attr
.external
)
1548 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1551 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1553 return (s
== NULL
) ? 0 : specific_sym (s
);
1557 /* Figure out if the procedure is specific, generic or unknown. */
1560 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1563 procedure_kind (gfc_symbol
*sym
)
1565 if (generic_sym (sym
))
1566 return PTYPE_GENERIC
;
1568 if (specific_sym (sym
))
1569 return PTYPE_SPECIFIC
;
1571 return PTYPE_UNKNOWN
;
1574 /* Check references to assumed size arrays. The flag need_full_assumed_size
1575 is nonzero when matching actual arguments. */
1577 static int need_full_assumed_size
= 0;
1580 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1582 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1585 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1586 What should it be? */
1587 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1588 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1589 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1591 gfc_error ("The upper bound in the last dimension must "
1592 "appear in the reference to the assumed size "
1593 "array %qs at %L", sym
->name
, &e
->where
);
1600 /* Look for bad assumed size array references in argument expressions
1601 of elemental and array valued intrinsic procedures. Since this is
1602 called from procedure resolution functions, it only recurses at
1606 resolve_assumed_size_actual (gfc_expr
*e
)
1611 switch (e
->expr_type
)
1614 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1619 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1620 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1631 /* Check a generic procedure, passed as an actual argument, to see if
1632 there is a matching specific name. If none, it is an error, and if
1633 more than one, the reference is ambiguous. */
1635 count_specific_procs (gfc_expr
*e
)
1642 sym
= e
->symtree
->n
.sym
;
1644 for (p
= sym
->generic
; p
; p
= p
->next
)
1645 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1647 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1653 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1657 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1658 "argument at %L", sym
->name
, &e
->where
);
1664 /* See if a call to sym could possibly be a not allowed RECURSION because of
1665 a missing RECURSIVE declaration. This means that either sym is the current
1666 context itself, or sym is the parent of a contained procedure calling its
1667 non-RECURSIVE containing procedure.
1668 This also works if sym is an ENTRY. */
1671 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1673 gfc_symbol
* proc_sym
;
1674 gfc_symbol
* context_proc
;
1675 gfc_namespace
* real_context
;
1677 if (sym
->attr
.flavor
== FL_PROGRAM
1678 || gfc_fl_struct (sym
->attr
.flavor
))
1681 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1683 /* If we've got an ENTRY, find real procedure. */
1684 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1685 proc_sym
= sym
->ns
->entries
->sym
;
1689 /* If sym is RECURSIVE, all is well of course. */
1690 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1693 /* Find the context procedure's "real" symbol if it has entries.
1694 We look for a procedure symbol, so recurse on the parents if we don't
1695 find one (like in case of a BLOCK construct). */
1696 for (real_context
= context
; ; real_context
= real_context
->parent
)
1698 /* We should find something, eventually! */
1699 gcc_assert (real_context
);
1701 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1702 : real_context
->proc_name
);
1704 /* In some special cases, there may not be a proc_name, like for this
1706 real(bad_kind()) function foo () ...
1707 when checking the call to bad_kind ().
1708 In these cases, we simply return here and assume that the
1713 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1717 /* A call from sym's body to itself is recursion, of course. */
1718 if (context_proc
== proc_sym
)
1721 /* The same is true if context is a contained procedure and sym the
1723 if (context_proc
->attr
.contained
)
1725 gfc_symbol
* parent_proc
;
1727 gcc_assert (context
->parent
);
1728 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1729 : context
->parent
->proc_name
);
1731 if (parent_proc
== proc_sym
)
1739 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1740 its typespec and formal argument list. */
1743 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1745 gfc_intrinsic_sym
* isym
= NULL
;
1751 /* Already resolved. */
1752 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1755 /* We already know this one is an intrinsic, so we don't call
1756 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1757 gfc_find_subroutine directly to check whether it is a function or
1760 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1762 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1763 isym
= gfc_intrinsic_subroutine_by_id (id
);
1765 else if (sym
->intmod_sym_id
)
1767 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1768 isym
= gfc_intrinsic_function_by_id (id
);
1770 else if (!sym
->attr
.subroutine
)
1771 isym
= gfc_find_function (sym
->name
);
1773 if (isym
&& !sym
->attr
.subroutine
)
1775 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1776 && !sym
->attr
.implicit_type
)
1777 gfc_warning (OPT_Wsurprising
,
1778 "Type specified for intrinsic function %qs at %L is"
1779 " ignored", sym
->name
, &sym
->declared_at
);
1781 if (!sym
->attr
.function
&&
1782 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1787 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1789 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1791 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1792 " specifier", sym
->name
, &sym
->declared_at
);
1796 if (!sym
->attr
.subroutine
&&
1797 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1802 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1807 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1809 sym
->attr
.pure
= isym
->pure
;
1810 sym
->attr
.elemental
= isym
->elemental
;
1812 /* Check it is actually available in the standard settings. */
1813 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1815 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1816 "available in the current standard settings but %s. Use "
1817 "an appropriate %<-std=*%> option or enable "
1818 "%<-fall-intrinsics%> in order to use it.",
1819 sym
->name
, &sym
->declared_at
, symstd
);
1827 /* Resolve a procedure expression, like passing it to a called procedure or as
1828 RHS for a procedure pointer assignment. */
1831 resolve_procedure_expression (gfc_expr
* expr
)
1835 if (expr
->expr_type
!= EXPR_VARIABLE
)
1837 gcc_assert (expr
->symtree
);
1839 sym
= expr
->symtree
->n
.sym
;
1841 if (sym
->attr
.intrinsic
)
1842 gfc_resolve_intrinsic (sym
, &expr
->where
);
1844 if (sym
->attr
.flavor
!= FL_PROCEDURE
1845 || (sym
->attr
.function
&& sym
->result
== sym
))
1848 /* A non-RECURSIVE procedure that is used as procedure expression within its
1849 own body is in danger of being called recursively. */
1850 if (is_illegal_recursion (sym
, gfc_current_ns
))
1851 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1852 " itself recursively. Declare it RECURSIVE or use"
1853 " %<-frecursive%>", sym
->name
, &expr
->where
);
1859 /* Resolve an actual argument list. Most of the time, this is just
1860 resolving the expressions in the list.
1861 The exception is that we sometimes have to decide whether arguments
1862 that look like procedure arguments are really simple variable
1866 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1867 bool no_formal_args
)
1870 gfc_symtree
*parent_st
;
1872 gfc_component
*comp
;
1873 int save_need_full_assumed_size
;
1874 bool return_value
= false;
1875 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1878 first_actual_arg
= true;
1880 for (; arg
; arg
= arg
->next
)
1885 /* Check the label is a valid branching target. */
1888 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1890 gfc_error ("Label %d referenced at %L is never defined",
1891 arg
->label
->value
, &arg
->label
->where
);
1895 first_actual_arg
= false;
1899 if (e
->expr_type
== EXPR_VARIABLE
1900 && e
->symtree
->n
.sym
->attr
.generic
1902 && count_specific_procs (e
) != 1)
1905 if (e
->ts
.type
!= BT_PROCEDURE
)
1907 save_need_full_assumed_size
= need_full_assumed_size
;
1908 if (e
->expr_type
!= EXPR_VARIABLE
)
1909 need_full_assumed_size
= 0;
1910 if (!gfc_resolve_expr (e
))
1912 need_full_assumed_size
= save_need_full_assumed_size
;
1916 /* See if the expression node should really be a variable reference. */
1918 sym
= e
->symtree
->n
.sym
;
1920 if (sym
->attr
.flavor
== FL_PROCEDURE
1921 || sym
->attr
.intrinsic
1922 || sym
->attr
.external
)
1926 /* If a procedure is not already determined to be something else
1927 check if it is intrinsic. */
1928 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1929 sym
->attr
.intrinsic
= 1;
1931 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1933 gfc_error ("Statement function %qs at %L is not allowed as an "
1934 "actual argument", sym
->name
, &e
->where
);
1937 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1938 sym
->attr
.subroutine
);
1939 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1941 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1942 "actual argument", sym
->name
, &e
->where
);
1945 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1946 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1948 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1949 " used as actual argument at %L",
1950 sym
->name
, &e
->where
))
1954 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1956 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1957 "allowed as an actual argument at %L", sym
->name
,
1961 /* Check if a generic interface has a specific procedure
1962 with the same name before emitting an error. */
1963 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1966 /* Just in case a specific was found for the expression. */
1967 sym
= e
->symtree
->n
.sym
;
1969 /* If the symbol is the function that names the current (or
1970 parent) scope, then we really have a variable reference. */
1972 if (gfc_is_function_return_value (sym
, sym
->ns
))
1975 /* If all else fails, see if we have a specific intrinsic. */
1976 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1978 gfc_intrinsic_sym
*isym
;
1980 isym
= gfc_find_function (sym
->name
);
1981 if (isym
== NULL
|| !isym
->specific
)
1983 gfc_error ("Unable to find a specific INTRINSIC procedure "
1984 "for the reference %qs at %L", sym
->name
,
1989 sym
->attr
.intrinsic
= 1;
1990 sym
->attr
.function
= 1;
1993 if (!gfc_resolve_expr (e
))
1998 /* See if the name is a module procedure in a parent unit. */
2000 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2003 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2005 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2009 if (parent_st
== NULL
)
2012 sym
= parent_st
->n
.sym
;
2013 e
->symtree
= parent_st
; /* Point to the right thing. */
2015 if (sym
->attr
.flavor
== FL_PROCEDURE
2016 || sym
->attr
.intrinsic
2017 || sym
->attr
.external
)
2019 if (!gfc_resolve_expr (e
))
2025 e
->expr_type
= EXPR_VARIABLE
;
2027 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2028 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2029 && CLASS_DATA (sym
)->as
))
2031 e
->rank
= sym
->ts
.type
== BT_CLASS
2032 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2033 e
->ref
= gfc_get_ref ();
2034 e
->ref
->type
= REF_ARRAY
;
2035 e
->ref
->u
.ar
.type
= AR_FULL
;
2036 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2037 ? CLASS_DATA (sym
)->as
: sym
->as
;
2040 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2041 primary.c (match_actual_arg). If above code determines that it
2042 is a variable instead, it needs to be resolved as it was not
2043 done at the beginning of this function. */
2044 save_need_full_assumed_size
= need_full_assumed_size
;
2045 if (e
->expr_type
!= EXPR_VARIABLE
)
2046 need_full_assumed_size
= 0;
2047 if (!gfc_resolve_expr (e
))
2049 need_full_assumed_size
= save_need_full_assumed_size
;
2052 /* Check argument list functions %VAL, %LOC and %REF. There is
2053 nothing to do for %REF. */
2054 if (arg
->name
&& arg
->name
[0] == '%')
2056 if (strncmp ("%VAL", arg
->name
, 4) == 0)
2058 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2060 gfc_error ("By-value argument at %L is not of numeric "
2067 gfc_error ("By-value argument at %L cannot be an array or "
2068 "an array section", &e
->where
);
2072 /* Intrinsics are still PROC_UNKNOWN here. However,
2073 since same file external procedures are not resolvable
2074 in gfortran, it is a good deal easier to leave them to
2076 if (ptype
!= PROC_UNKNOWN
2077 && ptype
!= PROC_DUMMY
2078 && ptype
!= PROC_EXTERNAL
2079 && ptype
!= PROC_MODULE
)
2081 gfc_error ("By-value argument at %L is not allowed "
2082 "in this context", &e
->where
);
2087 /* Statement functions have already been excluded above. */
2088 else if (strncmp ("%LOC", arg
->name
, 4) == 0
2089 && e
->ts
.type
== BT_PROCEDURE
)
2091 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2093 gfc_error ("Passing internal procedure at %L by location "
2094 "not allowed", &e
->where
);
2100 comp
= gfc_get_proc_ptr_comp(e
);
2101 if (e
->expr_type
== EXPR_VARIABLE
2102 && comp
&& comp
->attr
.elemental
)
2104 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2105 "allowed as an actual argument at %L", comp
->name
,
2109 /* Fortran 2008, C1237. */
2110 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2111 && gfc_has_ultimate_pointer (e
))
2113 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2114 "component", &e
->where
);
2118 first_actual_arg
= false;
2121 return_value
= true;
2124 actual_arg
= actual_arg_sav
;
2125 first_actual_arg
= first_actual_arg_sav
;
2127 return return_value
;
2131 /* Do the checks of the actual argument list that are specific to elemental
2132 procedures. If called with c == NULL, we have a function, otherwise if
2133 expr == NULL, we have a subroutine. */
2136 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2138 gfc_actual_arglist
*arg0
;
2139 gfc_actual_arglist
*arg
;
2140 gfc_symbol
*esym
= NULL
;
2141 gfc_intrinsic_sym
*isym
= NULL
;
2143 gfc_intrinsic_arg
*iformal
= NULL
;
2144 gfc_formal_arglist
*eformal
= NULL
;
2145 bool formal_optional
= false;
2146 bool set_by_optional
= false;
2150 /* Is this an elemental procedure? */
2151 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2153 if (expr
->value
.function
.esym
!= NULL
2154 && expr
->value
.function
.esym
->attr
.elemental
)
2156 arg0
= expr
->value
.function
.actual
;
2157 esym
= expr
->value
.function
.esym
;
2159 else if (expr
->value
.function
.isym
!= NULL
2160 && expr
->value
.function
.isym
->elemental
)
2162 arg0
= expr
->value
.function
.actual
;
2163 isym
= expr
->value
.function
.isym
;
2168 else if (c
&& c
->ext
.actual
!= NULL
)
2170 arg0
= c
->ext
.actual
;
2172 if (c
->resolved_sym
)
2173 esym
= c
->resolved_sym
;
2175 esym
= c
->symtree
->n
.sym
;
2178 if (!esym
->attr
.elemental
)
2184 /* The rank of an elemental is the rank of its array argument(s). */
2185 for (arg
= arg0
; arg
; arg
= arg
->next
)
2187 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2189 rank
= arg
->expr
->rank
;
2190 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2191 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2192 set_by_optional
= true;
2194 /* Function specific; set the result rank and shape. */
2198 if (!expr
->shape
&& arg
->expr
->shape
)
2200 expr
->shape
= gfc_get_shape (rank
);
2201 for (i
= 0; i
< rank
; i
++)
2202 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2209 /* If it is an array, it shall not be supplied as an actual argument
2210 to an elemental procedure unless an array of the same rank is supplied
2211 as an actual argument corresponding to a nonoptional dummy argument of
2212 that elemental procedure(12.4.1.5). */
2213 formal_optional
= false;
2215 iformal
= isym
->formal
;
2217 eformal
= esym
->formal
;
2219 for (arg
= arg0
; arg
; arg
= arg
->next
)
2223 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2224 formal_optional
= true;
2225 eformal
= eformal
->next
;
2227 else if (isym
&& iformal
)
2229 if (iformal
->optional
)
2230 formal_optional
= true;
2231 iformal
= iformal
->next
;
2234 formal_optional
= true;
2236 if (pedantic
&& arg
->expr
!= NULL
2237 && arg
->expr
->expr_type
== EXPR_VARIABLE
2238 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2241 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2242 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2244 gfc_warning (OPT_Wpedantic
,
2245 "%qs at %L is an array and OPTIONAL; IF IT IS "
2246 "MISSING, it cannot be the actual argument of an "
2247 "ELEMENTAL procedure unless there is a non-optional "
2248 "argument with the same rank (12.4.1.5)",
2249 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2253 for (arg
= arg0
; arg
; arg
= arg
->next
)
2255 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2258 /* Being elemental, the last upper bound of an assumed size array
2259 argument must be present. */
2260 if (resolve_assumed_size_actual (arg
->expr
))
2263 /* Elemental procedure's array actual arguments must conform. */
2266 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2273 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2274 is an array, the intent inout/out variable needs to be also an array. */
2275 if (rank
> 0 && esym
&& expr
== NULL
)
2276 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2277 arg
= arg
->next
, eformal
= eformal
->next
)
2278 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2279 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2280 && arg
->expr
&& arg
->expr
->rank
== 0)
2282 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2283 "ELEMENTAL subroutine %qs is a scalar, but another "
2284 "actual argument is an array", &arg
->expr
->where
,
2285 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2286 : "INOUT", eformal
->sym
->name
, esym
->name
);
2293 /* This function does the checking of references to global procedures
2294 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2295 77 and 95 standards. It checks for a gsymbol for the name, making
2296 one if it does not already exist. If it already exists, then the
2297 reference being resolved must correspond to the type of gsymbol.
2298 Otherwise, the new symbol is equipped with the attributes of the
2299 reference. The corresponding code that is called in creating
2300 global entities is parse.c.
2302 In addition, for all but -std=legacy, the gsymbols are used to
2303 check the interfaces of external procedures from the same file.
2304 The namespace of the gsymbol is resolved and then, once this is
2305 done the interface is checked. */
2309 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2311 if (!gsym_ns
->proc_name
->attr
.recursive
)
2314 if (sym
->ns
== gsym_ns
)
2317 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2324 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2326 if (gsym_ns
->entries
)
2328 gfc_entry_list
*entry
= gsym_ns
->entries
;
2330 for (; entry
; entry
= entry
->next
)
2332 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2334 if (strcmp (gsym_ns
->proc_name
->name
,
2335 sym
->ns
->proc_name
->name
) == 0)
2339 && strcmp (gsym_ns
->proc_name
->name
,
2340 sym
->ns
->parent
->proc_name
->name
) == 0)
2349 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2352 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2354 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2356 for ( ; arg
; arg
= arg
->next
)
2361 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2363 strncpy (errmsg
, _("allocatable argument"), err_len
);
2366 else if (arg
->sym
->attr
.asynchronous
)
2368 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2371 else if (arg
->sym
->attr
.optional
)
2373 strncpy (errmsg
, _("optional argument"), err_len
);
2376 else if (arg
->sym
->attr
.pointer
)
2378 strncpy (errmsg
, _("pointer argument"), err_len
);
2381 else if (arg
->sym
->attr
.target
)
2383 strncpy (errmsg
, _("target argument"), err_len
);
2386 else if (arg
->sym
->attr
.value
)
2388 strncpy (errmsg
, _("value argument"), err_len
);
2391 else if (arg
->sym
->attr
.volatile_
)
2393 strncpy (errmsg
, _("volatile argument"), err_len
);
2396 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2398 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2401 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2403 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2406 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2408 strncpy (errmsg
, _("coarray argument"), err_len
);
2411 else if (false) /* (2d) TODO: parametrized derived type */
2413 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2416 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2418 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2421 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2423 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2426 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2428 /* As assumed-type is unlimited polymorphic (cf. above).
2429 See also TS 29113, Note 6.1. */
2430 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2435 if (sym
->attr
.function
)
2437 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2439 if (res
->attr
.dimension
) /* (3a) */
2441 strncpy (errmsg
, _("array result"), err_len
);
2444 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2446 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2449 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2450 && res
->ts
.u
.cl
->length
2451 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2453 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2458 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2460 strncpy (errmsg
, _("elemental procedure"), err_len
);
2463 else if (sym
->attr
.is_bind_c
) /* (5) */
2465 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2474 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2475 gfc_actual_arglist
**actual
, int sub
)
2479 enum gfc_symbol_type type
;
2482 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2484 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2486 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2487 gfc_global_used (gsym
, where
);
2489 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2490 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2491 && gsym
->type
!= GSYM_UNKNOWN
2492 && !gsym
->binding_label
2494 && gsym
->ns
->resolved
!= -1
2495 && gsym
->ns
->proc_name
2496 && not_in_recursive (sym
, gsym
->ns
)
2497 && not_entry_self_reference (sym
, gsym
->ns
))
2499 gfc_symbol
*def_sym
;
2501 /* Resolve the gsymbol namespace if needed. */
2502 if (!gsym
->ns
->resolved
)
2504 gfc_dt_list
*old_dt_list
;
2506 /* Stash away derived types so that the backend_decls do not
2508 old_dt_list
= gfc_derived_types
;
2509 gfc_derived_types
= NULL
;
2511 gfc_resolve (gsym
->ns
);
2513 /* Store the new derived types with the global namespace. */
2514 if (gfc_derived_types
)
2515 gsym
->ns
->derived_types
= gfc_derived_types
;
2517 /* Restore the derived types of this namespace. */
2518 gfc_derived_types
= old_dt_list
;
2521 /* Make sure that translation for the gsymbol occurs before
2522 the procedure currently being resolved. */
2523 ns
= gfc_global_ns_list
;
2524 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2526 if (ns
->sibling
== gsym
->ns
)
2528 ns
->sibling
= gsym
->ns
->sibling
;
2529 gsym
->ns
->sibling
= gfc_global_ns_list
;
2530 gfc_global_ns_list
= gsym
->ns
;
2535 def_sym
= gsym
->ns
->proc_name
;
2537 /* This can happen if a binding name has been specified. */
2538 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2539 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2541 if (def_sym
->attr
.entry_master
)
2543 gfc_entry_list
*entry
;
2544 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2545 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2547 def_sym
= entry
->sym
;
2552 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2554 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2555 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2556 gfc_typename (&def_sym
->ts
));
2560 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2561 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2563 gfc_error ("Explicit interface required for %qs at %L: %s",
2564 sym
->name
, &sym
->declared_at
, reason
);
2568 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2569 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2570 gfc_errors_to_warnings (true);
2572 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2573 reason
, sizeof(reason
), NULL
, NULL
))
2575 gfc_error_opt (OPT_Wargument_mismatch
,
2576 "Interface mismatch in global procedure %qs at %L:"
2577 " %s", sym
->name
, &sym
->declared_at
, reason
);
2582 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2583 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2584 gfc_errors_to_warnings (true);
2586 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2587 gfc_procedure_use (def_sym
, actual
, where
);
2591 gfc_errors_to_warnings (false);
2593 if (gsym
->type
== GSYM_UNKNOWN
)
2596 gsym
->where
= *where
;
2603 /************* Function resolution *************/
2605 /* Resolve a function call known to be generic.
2606 Section 14.1.2.4.1. */
2609 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2613 if (sym
->attr
.generic
)
2615 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2618 expr
->value
.function
.name
= s
->name
;
2619 expr
->value
.function
.esym
= s
;
2621 if (s
->ts
.type
!= BT_UNKNOWN
)
2623 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2624 expr
->ts
= s
->result
->ts
;
2627 expr
->rank
= s
->as
->rank
;
2628 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2629 expr
->rank
= s
->result
->as
->rank
;
2631 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2636 /* TODO: Need to search for elemental references in generic
2640 if (sym
->attr
.intrinsic
)
2641 return gfc_intrinsic_func_interface (expr
, 0);
2648 resolve_generic_f (gfc_expr
*expr
)
2652 gfc_interface
*intr
= NULL
;
2654 sym
= expr
->symtree
->n
.sym
;
2658 m
= resolve_generic_f0 (expr
, sym
);
2661 else if (m
== MATCH_ERROR
)
2666 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2667 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2670 if (sym
->ns
->parent
== NULL
)
2672 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2676 if (!generic_sym (sym
))
2680 /* Last ditch attempt. See if the reference is to an intrinsic
2681 that possesses a matching interface. 14.1.2.4 */
2682 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2684 if (gfc_init_expr_flag
)
2685 gfc_error ("Function %qs in initialization expression at %L "
2686 "must be an intrinsic function",
2687 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2689 gfc_error ("There is no specific function for the generic %qs "
2690 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2696 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2699 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2701 return resolve_structure_cons (expr
, 0);
2704 m
= gfc_intrinsic_func_interface (expr
, 0);
2709 gfc_error ("Generic function %qs at %L is not consistent with a "
2710 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2717 /* Resolve a function call known to be specific. */
2720 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2724 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2726 if (sym
->attr
.dummy
)
2728 sym
->attr
.proc
= PROC_DUMMY
;
2732 sym
->attr
.proc
= PROC_EXTERNAL
;
2736 if (sym
->attr
.proc
== PROC_MODULE
2737 || sym
->attr
.proc
== PROC_ST_FUNCTION
2738 || sym
->attr
.proc
== PROC_INTERNAL
)
2741 if (sym
->attr
.intrinsic
)
2743 m
= gfc_intrinsic_func_interface (expr
, 1);
2747 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2748 "with an intrinsic", sym
->name
, &expr
->where
);
2756 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2759 expr
->ts
= sym
->result
->ts
;
2762 expr
->value
.function
.name
= sym
->name
;
2763 expr
->value
.function
.esym
= sym
;
2764 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2766 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2768 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2769 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2770 else if (sym
->as
!= NULL
)
2771 expr
->rank
= sym
->as
->rank
;
2778 resolve_specific_f (gfc_expr
*expr
)
2783 sym
= expr
->symtree
->n
.sym
;
2787 m
= resolve_specific_f0 (sym
, expr
);
2790 if (m
== MATCH_ERROR
)
2793 if (sym
->ns
->parent
== NULL
)
2796 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2802 gfc_error ("Unable to resolve the specific function %qs at %L",
2803 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2808 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2809 candidates in CANDIDATES_LEN. */
2812 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2814 size_t &candidates_len
)
2820 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2821 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2822 vec_push (candidates
, candidates_len
, sym
->name
);
2826 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2830 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2834 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2837 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2839 char **candidates
= NULL
;
2840 size_t candidates_len
= 0;
2841 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2842 return gfc_closest_fuzzy_match (fn
, candidates
);
2846 /* Resolve a procedure call not known to be generic nor specific. */
2849 resolve_unknown_f (gfc_expr
*expr
)
2854 sym
= expr
->symtree
->n
.sym
;
2856 if (sym
->attr
.dummy
)
2858 sym
->attr
.proc
= PROC_DUMMY
;
2859 expr
->value
.function
.name
= sym
->name
;
2863 /* See if we have an intrinsic function reference. */
2865 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2867 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2872 /* The reference is to an external name. */
2874 sym
->attr
.proc
= PROC_EXTERNAL
;
2875 expr
->value
.function
.name
= sym
->name
;
2876 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2878 if (sym
->as
!= NULL
)
2879 expr
->rank
= sym
->as
->rank
;
2881 /* Type of the expression is either the type of the symbol or the
2882 default type of the symbol. */
2885 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2887 if (sym
->ts
.type
!= BT_UNKNOWN
)
2891 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2893 if (ts
->type
== BT_UNKNOWN
)
2896 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2898 gfc_error ("Function %qs at %L has no IMPLICIT type"
2899 "; did you mean %qs?",
2900 sym
->name
, &expr
->where
, guessed
);
2902 gfc_error ("Function %qs at %L has no IMPLICIT type",
2903 sym
->name
, &expr
->where
);
2914 /* Return true, if the symbol is an external procedure. */
2916 is_external_proc (gfc_symbol
*sym
)
2918 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2919 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2920 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2921 && !sym
->attr
.proc_pointer
2922 && !sym
->attr
.use_assoc
2930 /* Figure out if a function reference is pure or not. Also set the name
2931 of the function for a potential error message. Return nonzero if the
2932 function is PURE, zero if not. */
2934 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2937 pure_function (gfc_expr
*e
, const char **name
)
2940 gfc_component
*comp
;
2944 if (e
->symtree
!= NULL
2945 && e
->symtree
->n
.sym
!= NULL
2946 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2947 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2949 comp
= gfc_get_proc_ptr_comp (e
);
2952 pure
= gfc_pure (comp
->ts
.interface
);
2955 else if (e
->value
.function
.esym
)
2957 pure
= gfc_pure (e
->value
.function
.esym
);
2958 *name
= e
->value
.function
.esym
->name
;
2960 else if (e
->value
.function
.isym
)
2962 pure
= e
->value
.function
.isym
->pure
2963 || e
->value
.function
.isym
->elemental
;
2964 *name
= e
->value
.function
.isym
->name
;
2968 /* Implicit functions are not pure. */
2970 *name
= e
->value
.function
.name
;
2978 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2979 int *f ATTRIBUTE_UNUSED
)
2983 /* Don't bother recursing into other statement functions
2984 since they will be checked individually for purity. */
2985 if (e
->expr_type
!= EXPR_FUNCTION
2987 || e
->symtree
->n
.sym
== sym
2988 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2991 return pure_function (e
, &name
) ? false : true;
2996 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2998 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3002 /* Check if an impure function is allowed in the current context. */
3004 static bool check_pure_function (gfc_expr
*e
)
3006 const char *name
= NULL
;
3007 if (!pure_function (e
, &name
) && name
)
3011 gfc_error ("Reference to impure function %qs at %L inside a "
3012 "FORALL %s", name
, &e
->where
,
3013 forall_flag
== 2 ? "mask" : "block");
3016 else if (gfc_do_concurrent_flag
)
3018 gfc_error ("Reference to impure function %qs at %L inside a "
3019 "DO CONCURRENT %s", name
, &e
->where
,
3020 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3023 else if (gfc_pure (NULL
))
3025 gfc_error ("Reference to impure function %qs at %L "
3026 "within a PURE procedure", name
, &e
->where
);
3029 gfc_unset_implicit_pure (NULL
);
3035 /* Update current procedure's array_outer_dependency flag, considering
3036 a call to procedure SYM. */
3039 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3041 /* Check to see if this is a sibling function that has not yet
3043 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3044 for (; sibling
; sibling
= sibling
->sibling
)
3046 if (sibling
->proc_name
== sym
)
3048 gfc_resolve (sibling
);
3053 /* If SYM has references to outer arrays, so has the procedure calling
3054 SYM. If SYM is a procedure pointer, we can assume the worst. */
3055 if (sym
->attr
.array_outer_dependency
3056 || sym
->attr
.proc_pointer
)
3057 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3061 /* Resolve a function call, which means resolving the arguments, then figuring
3062 out which entity the name refers to. */
3065 resolve_function (gfc_expr
*expr
)
3067 gfc_actual_arglist
*arg
;
3071 procedure_type p
= PROC_INTRINSIC
;
3072 bool no_formal_args
;
3076 sym
= expr
->symtree
->n
.sym
;
3078 /* If this is a procedure pointer component, it has already been resolved. */
3079 if (gfc_is_proc_ptr_comp (expr
))
3082 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3084 if (sym
&& sym
->attr
.intrinsic
3085 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3086 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3089 if (sym
&& sym
->attr
.intrinsic
3090 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3093 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3095 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3099 /* If this ia a deferred TBP with an abstract interface (which may
3100 of course be referenced), expr->value.function.esym will be set. */
3101 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3103 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3104 sym
->name
, &expr
->where
);
3108 /* Switch off assumed size checking and do this again for certain kinds
3109 of procedure, once the procedure itself is resolved. */
3110 need_full_assumed_size
++;
3112 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3113 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3115 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3116 inquiry_argument
= true;
3117 no_formal_args
= sym
&& is_external_proc (sym
)
3118 && gfc_sym_get_dummy_args (sym
) == NULL
;
3120 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3123 inquiry_argument
= false;
3127 inquiry_argument
= false;
3129 /* Resume assumed_size checking. */
3130 need_full_assumed_size
--;
3132 /* If the procedure is external, check for usage. */
3133 if (sym
&& is_external_proc (sym
))
3134 resolve_global_procedure (sym
, &expr
->where
,
3135 &expr
->value
.function
.actual
, 0);
3137 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3139 && sym
->ts
.u
.cl
->length
== NULL
3141 && !sym
->ts
.deferred
3142 && expr
->value
.function
.esym
== NULL
3143 && !sym
->attr
.contained
)
3145 /* Internal procedures are taken care of in resolve_contained_fntype. */
3146 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3147 "be used at %L since it is not a dummy argument",
3148 sym
->name
, &expr
->where
);
3152 /* See if function is already resolved. */
3154 if (expr
->value
.function
.name
!= NULL
3155 || expr
->value
.function
.isym
!= NULL
)
3157 if (expr
->ts
.type
== BT_UNKNOWN
)
3163 /* Apply the rules of section 14.1.2. */
3165 switch (procedure_kind (sym
))
3168 t
= resolve_generic_f (expr
);
3171 case PTYPE_SPECIFIC
:
3172 t
= resolve_specific_f (expr
);
3176 t
= resolve_unknown_f (expr
);
3180 gfc_internal_error ("resolve_function(): bad function type");
3184 /* If the expression is still a function (it might have simplified),
3185 then we check to see if we are calling an elemental function. */
3187 if (expr
->expr_type
!= EXPR_FUNCTION
)
3190 temp
= need_full_assumed_size
;
3191 need_full_assumed_size
= 0;
3193 if (!resolve_elemental_actual (expr
, NULL
))
3196 if (omp_workshare_flag
3197 && expr
->value
.function
.esym
3198 && ! gfc_elemental (expr
->value
.function
.esym
))
3200 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3201 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3206 #define GENERIC_ID expr->value.function.isym->id
3207 else if (expr
->value
.function
.actual
!= NULL
3208 && expr
->value
.function
.isym
!= NULL
3209 && GENERIC_ID
!= GFC_ISYM_LBOUND
3210 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3211 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3212 && GENERIC_ID
!= GFC_ISYM_LEN
3213 && GENERIC_ID
!= GFC_ISYM_LOC
3214 && GENERIC_ID
!= GFC_ISYM_C_LOC
3215 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3217 /* Array intrinsics must also have the last upper bound of an
3218 assumed size array argument. UBOUND and SIZE have to be
3219 excluded from the check if the second argument is anything
3222 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3224 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3225 && arg
== expr
->value
.function
.actual
3226 && arg
->next
!= NULL
&& arg
->next
->expr
)
3228 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3231 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3234 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3239 if (arg
->expr
!= NULL
3240 && arg
->expr
->rank
> 0
3241 && resolve_assumed_size_actual (arg
->expr
))
3247 need_full_assumed_size
= temp
;
3249 if (!check_pure_function(expr
))
3252 /* Functions without the RECURSIVE attribution are not allowed to
3253 * call themselves. */
3254 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3257 esym
= expr
->value
.function
.esym
;
3259 if (is_illegal_recursion (esym
, gfc_current_ns
))
3261 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3262 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3263 " function %qs is not RECURSIVE",
3264 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3266 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3267 " is not RECURSIVE", esym
->name
, &expr
->where
);
3273 /* Character lengths of use associated functions may contains references to
3274 symbols not referenced from the current program unit otherwise. Make sure
3275 those symbols are marked as referenced. */
3277 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3278 && expr
->value
.function
.esym
->attr
.use_assoc
)
3280 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3283 /* Make sure that the expression has a typespec that works. */
3284 if (expr
->ts
.type
== BT_UNKNOWN
)
3286 if (expr
->symtree
->n
.sym
->result
3287 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3288 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3289 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3292 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3294 if (expr
->value
.function
.esym
)
3295 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3297 update_current_proc_array_outer_dependency (sym
);
3300 /* typebound procedure: Assume the worst. */
3301 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3307 /************* Subroutine resolution *************/
3310 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3317 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3321 else if (gfc_do_concurrent_flag
)
3323 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3327 else if (gfc_pure (NULL
))
3329 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3333 gfc_unset_implicit_pure (NULL
);
3339 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3343 if (sym
->attr
.generic
)
3345 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3348 c
->resolved_sym
= s
;
3349 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3354 /* TODO: Need to search for elemental references in generic interface. */
3357 if (sym
->attr
.intrinsic
)
3358 return gfc_intrinsic_sub_interface (c
, 0);
3365 resolve_generic_s (gfc_code
*c
)
3370 sym
= c
->symtree
->n
.sym
;
3374 m
= resolve_generic_s0 (c
, sym
);
3377 else if (m
== MATCH_ERROR
)
3381 if (sym
->ns
->parent
== NULL
)
3383 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3387 if (!generic_sym (sym
))
3391 /* Last ditch attempt. See if the reference is to an intrinsic
3392 that possesses a matching interface. 14.1.2.4 */
3393 sym
= c
->symtree
->n
.sym
;
3395 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3397 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3398 sym
->name
, &c
->loc
);
3402 m
= gfc_intrinsic_sub_interface (c
, 0);
3406 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3407 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3413 /* Resolve a subroutine call known to be specific. */
3416 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3420 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3422 if (sym
->attr
.dummy
)
3424 sym
->attr
.proc
= PROC_DUMMY
;
3428 sym
->attr
.proc
= PROC_EXTERNAL
;
3432 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3435 if (sym
->attr
.intrinsic
)
3437 m
= gfc_intrinsic_sub_interface (c
, 1);
3441 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3442 "with an intrinsic", sym
->name
, &c
->loc
);
3450 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3452 c
->resolved_sym
= sym
;
3453 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3461 resolve_specific_s (gfc_code
*c
)
3466 sym
= c
->symtree
->n
.sym
;
3470 m
= resolve_specific_s0 (c
, sym
);
3473 if (m
== MATCH_ERROR
)
3476 if (sym
->ns
->parent
== NULL
)
3479 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3485 sym
= c
->symtree
->n
.sym
;
3486 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3487 sym
->name
, &c
->loc
);
3493 /* Resolve a subroutine call not known to be generic nor specific. */
3496 resolve_unknown_s (gfc_code
*c
)
3500 sym
= c
->symtree
->n
.sym
;
3502 if (sym
->attr
.dummy
)
3504 sym
->attr
.proc
= PROC_DUMMY
;
3508 /* See if we have an intrinsic function reference. */
3510 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3512 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3517 /* The reference is to an external name. */
3520 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3522 c
->resolved_sym
= sym
;
3524 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3528 /* Resolve a subroutine call. Although it was tempting to use the same code
3529 for functions, subroutines and functions are stored differently and this
3530 makes things awkward. */
3533 resolve_call (gfc_code
*c
)
3536 procedure_type ptype
= PROC_INTRINSIC
;
3537 gfc_symbol
*csym
, *sym
;
3538 bool no_formal_args
;
3540 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3542 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3544 gfc_error ("%qs at %L has a type, which is not consistent with "
3545 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3549 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3552 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3553 sym
= st
? st
->n
.sym
: NULL
;
3554 if (sym
&& csym
!= sym
3555 && sym
->ns
== gfc_current_ns
3556 && sym
->attr
.flavor
== FL_PROCEDURE
3557 && sym
->attr
.contained
)
3560 if (csym
->attr
.generic
)
3561 c
->symtree
->n
.sym
= sym
;
3564 csym
= c
->symtree
->n
.sym
;
3568 /* If this ia a deferred TBP, c->expr1 will be set. */
3569 if (!c
->expr1
&& csym
)
3571 if (csym
->attr
.abstract
)
3573 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3574 csym
->name
, &c
->loc
);
3578 /* Subroutines without the RECURSIVE attribution are not allowed to
3580 if (is_illegal_recursion (csym
, gfc_current_ns
))
3582 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3583 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3584 "as subroutine %qs is not RECURSIVE",
3585 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3587 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3588 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3594 /* Switch off assumed size checking and do this again for certain kinds
3595 of procedure, once the procedure itself is resolved. */
3596 need_full_assumed_size
++;
3599 ptype
= csym
->attr
.proc
;
3601 no_formal_args
= csym
&& is_external_proc (csym
)
3602 && gfc_sym_get_dummy_args (csym
) == NULL
;
3603 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3606 /* Resume assumed_size checking. */
3607 need_full_assumed_size
--;
3609 /* If external, check for usage. */
3610 if (csym
&& is_external_proc (csym
))
3611 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3614 if (c
->resolved_sym
== NULL
)
3616 c
->resolved_isym
= NULL
;
3617 switch (procedure_kind (csym
))
3620 t
= resolve_generic_s (c
);
3623 case PTYPE_SPECIFIC
:
3624 t
= resolve_specific_s (c
);
3628 t
= resolve_unknown_s (c
);
3632 gfc_internal_error ("resolve_subroutine(): bad function type");
3636 /* Some checks of elemental subroutine actual arguments. */
3637 if (!resolve_elemental_actual (NULL
, c
))
3641 update_current_proc_array_outer_dependency (csym
);
3643 /* Typebound procedure: Assume the worst. */
3644 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3650 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3651 op1->shape and op2->shape are non-NULL return true if their shapes
3652 match. If both op1->shape and op2->shape are non-NULL return false
3653 if their shapes do not match. If either op1->shape or op2->shape is
3654 NULL, return true. */
3657 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3664 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3666 for (i
= 0; i
< op1
->rank
; i
++)
3668 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3670 gfc_error ("Shapes for operands at %L and %L are not conformable",
3671 &op1
->where
, &op2
->where
);
3681 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3682 For example A .AND. B becomes IAND(A, B). */
3684 logical_to_bitwise (gfc_expr
*e
)
3686 gfc_expr
*tmp
, *op1
, *op2
;
3688 gfc_actual_arglist
*args
= NULL
;
3690 gcc_assert (e
->expr_type
== EXPR_OP
);
3692 isym
= GFC_ISYM_NONE
;
3693 op1
= e
->value
.op
.op1
;
3694 op2
= e
->value
.op
.op2
;
3696 switch (e
->value
.op
.op
)
3699 isym
= GFC_ISYM_NOT
;
3702 isym
= GFC_ISYM_IAND
;
3705 isym
= GFC_ISYM_IOR
;
3707 case INTRINSIC_NEQV
:
3708 isym
= GFC_ISYM_IEOR
;
3711 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3712 Change the old expression to NEQV, which will get replaced by IEOR,
3713 and wrap it in NOT. */
3714 tmp
= gfc_copy_expr (e
);
3715 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3716 tmp
= logical_to_bitwise (tmp
);
3717 isym
= GFC_ISYM_NOT
;
3722 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3725 /* Inherit the original operation's operands as arguments. */
3726 args
= gfc_get_actual_arglist ();
3730 args
->next
= gfc_get_actual_arglist ();
3731 args
->next
->expr
= op2
;
3734 /* Convert the expression to a function call. */
3735 e
->expr_type
= EXPR_FUNCTION
;
3736 e
->value
.function
.actual
= args
;
3737 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3738 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3739 e
->value
.function
.esym
= NULL
;
3741 /* Make up a pre-resolved function call symtree if we need to. */
3742 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3745 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3746 sym
= e
->symtree
->n
.sym
;
3748 sym
->attr
.flavor
= FL_PROCEDURE
;
3749 sym
->attr
.function
= 1;
3750 sym
->attr
.elemental
= 1;
3752 sym
->attr
.referenced
= 1;
3753 gfc_intrinsic_symbol (sym
);
3754 gfc_commit_symbol (sym
);
3757 args
->name
= e
->value
.function
.isym
->formal
->name
;
3758 if (e
->value
.function
.isym
->formal
->next
)
3759 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3764 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3765 candidates in CANDIDATES_LEN. */
3767 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3769 size_t &candidates_len
)
3776 /* Not sure how to properly filter here. Use all for a start.
3777 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3778 these as i suppose they don't make terribly sense. */
3780 if (uop
->n
.uop
->op
!= NULL
)
3781 vec_push (candidates
, candidates_len
, uop
->name
);
3785 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3789 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3792 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3795 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3797 char **candidates
= NULL
;
3798 size_t candidates_len
= 0;
3799 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3800 return gfc_closest_fuzzy_match (op
, candidates
);
3804 /* Resolve an operator expression node. This can involve replacing the
3805 operation with a user defined function call. */
3808 resolve_operator (gfc_expr
*e
)
3810 gfc_expr
*op1
, *op2
;
3812 bool dual_locus_error
;
3815 /* Resolve all subnodes-- give them types. */
3817 switch (e
->value
.op
.op
)
3820 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3826 case INTRINSIC_UPLUS
:
3827 case INTRINSIC_UMINUS
:
3828 case INTRINSIC_PARENTHESES
:
3829 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3834 /* Typecheck the new node. */
3836 op1
= e
->value
.op
.op1
;
3837 op2
= e
->value
.op
.op2
;
3838 dual_locus_error
= false;
3840 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3841 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3843 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3847 switch (e
->value
.op
.op
)
3849 case INTRINSIC_UPLUS
:
3850 case INTRINSIC_UMINUS
:
3851 if (op1
->ts
.type
== BT_INTEGER
3852 || op1
->ts
.type
== BT_REAL
3853 || op1
->ts
.type
== BT_COMPLEX
)
3859 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3860 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3863 case INTRINSIC_PLUS
:
3864 case INTRINSIC_MINUS
:
3865 case INTRINSIC_TIMES
:
3866 case INTRINSIC_DIVIDE
:
3867 case INTRINSIC_POWER
:
3868 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3870 gfc_type_convert_binary (e
, 1);
3875 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3876 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3877 gfc_typename (&op2
->ts
));
3880 case INTRINSIC_CONCAT
:
3881 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3882 && op1
->ts
.kind
== op2
->ts
.kind
)
3884 e
->ts
.type
= BT_CHARACTER
;
3885 e
->ts
.kind
= op1
->ts
.kind
;
3890 _("Operands of string concatenation operator at %%L are %s/%s"),
3891 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3897 case INTRINSIC_NEQV
:
3898 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3900 e
->ts
.type
= BT_LOGICAL
;
3901 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3902 if (op1
->ts
.kind
< e
->ts
.kind
)
3903 gfc_convert_type (op1
, &e
->ts
, 2);
3904 else if (op2
->ts
.kind
< e
->ts
.kind
)
3905 gfc_convert_type (op2
, &e
->ts
, 2);
3909 /* Logical ops on integers become bitwise ops with -fdec. */
3911 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
3913 e
->ts
.type
= BT_INTEGER
;
3914 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3915 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
3916 gfc_convert_type (op1
, &e
->ts
, 1);
3917 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
3918 gfc_convert_type (op2
, &e
->ts
, 1);
3919 e
= logical_to_bitwise (e
);
3920 return resolve_function (e
);
3923 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3924 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3925 gfc_typename (&op2
->ts
));
3930 /* Logical ops on integers become bitwise ops with -fdec. */
3931 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
3933 e
->ts
.type
= BT_INTEGER
;
3934 e
->ts
.kind
= op1
->ts
.kind
;
3935 e
= logical_to_bitwise (e
);
3936 return resolve_function (e
);
3939 if (op1
->ts
.type
== BT_LOGICAL
)
3941 e
->ts
.type
= BT_LOGICAL
;
3942 e
->ts
.kind
= op1
->ts
.kind
;
3946 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3947 gfc_typename (&op1
->ts
));
3951 case INTRINSIC_GT_OS
:
3953 case INTRINSIC_GE_OS
:
3955 case INTRINSIC_LT_OS
:
3957 case INTRINSIC_LE_OS
:
3958 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3960 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3967 case INTRINSIC_EQ_OS
:
3969 case INTRINSIC_NE_OS
:
3970 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3971 && op1
->ts
.kind
== op2
->ts
.kind
)
3973 e
->ts
.type
= BT_LOGICAL
;
3974 e
->ts
.kind
= gfc_default_logical_kind
;
3978 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3980 gfc_type_convert_binary (e
, 1);
3982 e
->ts
.type
= BT_LOGICAL
;
3983 e
->ts
.kind
= gfc_default_logical_kind
;
3985 if (warn_compare_reals
)
3987 gfc_intrinsic_op op
= e
->value
.op
.op
;
3989 /* Type conversion has made sure that the types of op1 and op2
3990 agree, so it is only necessary to check the first one. */
3991 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3992 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3993 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3997 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3998 msg
= "Equality comparison for %s at %L";
4000 msg
= "Inequality comparison for %s at %L";
4002 gfc_warning (OPT_Wcompare_reals
, msg
,
4003 gfc_typename (&op1
->ts
), &op1
->where
);
4010 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4012 _("Logicals at %%L must be compared with %s instead of %s"),
4013 (e
->value
.op
.op
== INTRINSIC_EQ
4014 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4015 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4018 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4019 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4020 gfc_typename (&op2
->ts
));
4024 case INTRINSIC_USER
:
4025 if (e
->value
.op
.uop
->op
== NULL
)
4027 const char *name
= e
->value
.op
.uop
->name
;
4028 const char *guessed
;
4029 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4031 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4034 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4036 else if (op2
== NULL
)
4037 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4038 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4041 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4042 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4043 gfc_typename (&op2
->ts
));
4044 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4049 case INTRINSIC_PARENTHESES
:
4051 if (e
->ts
.type
== BT_CHARACTER
)
4052 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4056 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4059 /* Deal with arrayness of an operand through an operator. */
4063 switch (e
->value
.op
.op
)
4065 case INTRINSIC_PLUS
:
4066 case INTRINSIC_MINUS
:
4067 case INTRINSIC_TIMES
:
4068 case INTRINSIC_DIVIDE
:
4069 case INTRINSIC_POWER
:
4070 case INTRINSIC_CONCAT
:
4074 case INTRINSIC_NEQV
:
4076 case INTRINSIC_EQ_OS
:
4078 case INTRINSIC_NE_OS
:
4080 case INTRINSIC_GT_OS
:
4082 case INTRINSIC_GE_OS
:
4084 case INTRINSIC_LT_OS
:
4086 case INTRINSIC_LE_OS
:
4088 if (op1
->rank
== 0 && op2
->rank
== 0)
4091 if (op1
->rank
== 0 && op2
->rank
!= 0)
4093 e
->rank
= op2
->rank
;
4095 if (e
->shape
== NULL
)
4096 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4099 if (op1
->rank
!= 0 && op2
->rank
== 0)
4101 e
->rank
= op1
->rank
;
4103 if (e
->shape
== NULL
)
4104 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4107 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4109 if (op1
->rank
== op2
->rank
)
4111 e
->rank
= op1
->rank
;
4112 if (e
->shape
== NULL
)
4114 t
= compare_shapes (op1
, op2
);
4118 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4123 /* Allow higher level expressions to work. */
4126 /* Try user-defined operators, and otherwise throw an error. */
4127 dual_locus_error
= true;
4129 _("Inconsistent ranks for operator at %%L and %%L"));
4136 case INTRINSIC_PARENTHESES
:
4138 case INTRINSIC_UPLUS
:
4139 case INTRINSIC_UMINUS
:
4140 /* Simply copy arrayness attribute */
4141 e
->rank
= op1
->rank
;
4143 if (e
->shape
== NULL
)
4144 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4152 /* Attempt to simplify the expression. */
4155 t
= gfc_simplify_expr (e
, 0);
4156 /* Some calls do not succeed in simplification and return false
4157 even though there is no error; e.g. variable references to
4158 PARAMETER arrays. */
4159 if (!gfc_is_constant_expr (e
))
4167 match m
= gfc_extend_expr (e
);
4170 if (m
== MATCH_ERROR
)
4174 if (dual_locus_error
)
4175 gfc_error (msg
, &op1
->where
, &op2
->where
);
4177 gfc_error (msg
, &e
->where
);
4183 /************** Array resolution subroutines **************/
4186 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4188 /* Compare two integer expressions. */
4190 static compare_result
4191 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4195 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4196 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4199 /* If either of the types isn't INTEGER, we must have
4200 raised an error earlier. */
4202 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4205 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4215 /* Compare an integer expression with an integer. */
4217 static compare_result
4218 compare_bound_int (gfc_expr
*a
, int b
)
4222 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4225 if (a
->ts
.type
!= BT_INTEGER
)
4226 gfc_internal_error ("compare_bound_int(): Bad expression");
4228 i
= mpz_cmp_si (a
->value
.integer
, b
);
4238 /* Compare an integer expression with a mpz_t. */
4240 static compare_result
4241 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4245 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4248 if (a
->ts
.type
!= BT_INTEGER
)
4249 gfc_internal_error ("compare_bound_int(): Bad expression");
4251 i
= mpz_cmp (a
->value
.integer
, b
);
4261 /* Compute the last value of a sequence given by a triplet.
4262 Return 0 if it wasn't able to compute the last value, or if the
4263 sequence if empty, and 1 otherwise. */
4266 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4267 gfc_expr
*stride
, mpz_t last
)
4271 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4272 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4273 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4276 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4277 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4280 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4282 if (compare_bound (start
, end
) == CMP_GT
)
4284 mpz_set (last
, end
->value
.integer
);
4288 if (compare_bound_int (stride
, 0) == CMP_GT
)
4290 /* Stride is positive */
4291 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4296 /* Stride is negative */
4297 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4302 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4303 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4304 mpz_sub (last
, end
->value
.integer
, rem
);
4311 /* Compare a single dimension of an array reference to the array
4315 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4319 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4321 gcc_assert (ar
->stride
[i
] == NULL
);
4322 /* This implies [*] as [*:] and [*:3] are not possible. */
4323 if (ar
->start
[i
] == NULL
)
4325 gcc_assert (ar
->end
[i
] == NULL
);
4330 /* Given start, end and stride values, calculate the minimum and
4331 maximum referenced indexes. */
4333 switch (ar
->dimen_type
[i
])
4336 case DIMEN_THIS_IMAGE
:
4341 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4344 gfc_warning (0, "Array reference at %L is out of bounds "
4345 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4346 mpz_get_si (ar
->start
[i
]->value
.integer
),
4347 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4349 gfc_warning (0, "Array reference at %L is out of bounds "
4350 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4351 mpz_get_si (ar
->start
[i
]->value
.integer
),
4352 mpz_get_si (as
->lower
[i
]->value
.integer
),
4356 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4359 gfc_warning (0, "Array reference at %L is out of bounds "
4360 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4361 mpz_get_si (ar
->start
[i
]->value
.integer
),
4362 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4364 gfc_warning (0, "Array reference at %L is out of bounds "
4365 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4366 mpz_get_si (ar
->start
[i
]->value
.integer
),
4367 mpz_get_si (as
->upper
[i
]->value
.integer
),
4376 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4377 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4379 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4381 /* Check for zero stride, which is not allowed. */
4382 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4384 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4388 /* if start == len || (stride > 0 && start < len)
4389 || (stride < 0 && start > len),
4390 then the array section contains at least one element. In this
4391 case, there is an out-of-bounds access if
4392 (start < lower || start > upper). */
4393 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4394 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4395 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4396 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4397 && comp_start_end
== CMP_GT
))
4399 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4401 gfc_warning (0, "Lower array reference at %L is out of bounds "
4402 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4403 mpz_get_si (AR_START
->value
.integer
),
4404 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4407 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4409 gfc_warning (0, "Lower array reference at %L is out of bounds "
4410 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4411 mpz_get_si (AR_START
->value
.integer
),
4412 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4417 /* If we can compute the highest index of the array section,
4418 then it also has to be between lower and upper. */
4419 mpz_init (last_value
);
4420 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4423 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4425 gfc_warning (0, "Upper array reference at %L is out of bounds "
4426 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4427 mpz_get_si (last_value
),
4428 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4429 mpz_clear (last_value
);
4432 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4434 gfc_warning (0, "Upper array reference at %L is out of bounds "
4435 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4436 mpz_get_si (last_value
),
4437 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4438 mpz_clear (last_value
);
4442 mpz_clear (last_value
);
4450 gfc_internal_error ("check_dimension(): Bad array reference");
4457 /* Compare an array reference with an array specification. */
4460 compare_spec_to_ref (gfc_array_ref
*ar
)
4467 /* TODO: Full array sections are only allowed as actual parameters. */
4468 if (as
->type
== AS_ASSUMED_SIZE
4469 && (/*ar->type == AR_FULL
4470 ||*/ (ar
->type
== AR_SECTION
4471 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4473 gfc_error ("Rightmost upper bound of assumed size array section "
4474 "not specified at %L", &ar
->where
);
4478 if (ar
->type
== AR_FULL
)
4481 if (as
->rank
!= ar
->dimen
)
4483 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4484 &ar
->where
, ar
->dimen
, as
->rank
);
4488 /* ar->codimen == 0 is a local array. */
4489 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4491 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4492 &ar
->where
, ar
->codimen
, as
->corank
);
4496 for (i
= 0; i
< as
->rank
; i
++)
4497 if (!check_dimension (i
, ar
, as
))
4500 /* Local access has no coarray spec. */
4501 if (ar
->codimen
!= 0)
4502 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4504 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4505 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4507 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4508 i
+ 1 - as
->rank
, &ar
->where
);
4511 if (!check_dimension (i
, ar
, as
))
4519 /* Resolve one part of an array index. */
4522 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4523 int force_index_integer_kind
)
4530 if (!gfc_resolve_expr (index
))
4533 if (check_scalar
&& index
->rank
!= 0)
4535 gfc_error ("Array index at %L must be scalar", &index
->where
);
4539 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4541 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4542 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4546 if (index
->ts
.type
== BT_REAL
)
4547 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4551 if ((index
->ts
.kind
!= gfc_index_integer_kind
4552 && force_index_integer_kind
)
4553 || index
->ts
.type
!= BT_INTEGER
)
4556 ts
.type
= BT_INTEGER
;
4557 ts
.kind
= gfc_index_integer_kind
;
4559 gfc_convert_type_warn (index
, &ts
, 2, 0);
4565 /* Resolve one part of an array index. */
4568 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4570 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4573 /* Resolve a dim argument to an intrinsic function. */
4576 gfc_resolve_dim_arg (gfc_expr
*dim
)
4581 if (!gfc_resolve_expr (dim
))
4586 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4591 if (dim
->ts
.type
!= BT_INTEGER
)
4593 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4597 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4602 ts
.type
= BT_INTEGER
;
4603 ts
.kind
= gfc_index_integer_kind
;
4605 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4611 /* Given an expression that contains array references, update those array
4612 references to point to the right array specifications. While this is
4613 filled in during matching, this information is difficult to save and load
4614 in a module, so we take care of it here.
4616 The idea here is that the original array reference comes from the
4617 base symbol. We traverse the list of reference structures, setting
4618 the stored reference to references. Component references can
4619 provide an additional array specification. */
4622 find_array_spec (gfc_expr
*e
)
4628 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4629 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4631 as
= e
->symtree
->n
.sym
->as
;
4633 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4638 gfc_internal_error ("find_array_spec(): Missing spec");
4645 c
= ref
->u
.c
.component
;
4646 if (c
->attr
.dimension
)
4649 gfc_internal_error ("find_array_spec(): unused as(1)");
4660 gfc_internal_error ("find_array_spec(): unused as(2)");
4664 /* Resolve an array reference. */
4667 resolve_array_ref (gfc_array_ref
*ar
)
4669 int i
, check_scalar
;
4672 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4674 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4676 /* Do not force gfc_index_integer_kind for the start. We can
4677 do fine with any integer kind. This avoids temporary arrays
4678 created for indexing with a vector. */
4679 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4681 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4683 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4688 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4692 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4696 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4697 if (e
->expr_type
== EXPR_VARIABLE
4698 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4699 ar
->start
[i
] = gfc_get_parentheses (e
);
4703 gfc_error ("Array index at %L is an array of rank %d",
4704 &ar
->c_where
[i
], e
->rank
);
4708 /* Fill in the upper bound, which may be lower than the
4709 specified one for something like a(2:10:5), which is
4710 identical to a(2:7:5). Only relevant for strides not equal
4711 to one. Don't try a division by zero. */
4712 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4713 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4714 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4715 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4719 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4721 if (ar
->end
[i
] == NULL
)
4724 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4726 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4728 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4729 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4731 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4742 if (ar
->type
== AR_FULL
)
4744 if (ar
->as
->rank
== 0)
4745 ar
->type
= AR_ELEMENT
;
4747 /* Make sure array is the same as array(:,:), this way
4748 we don't need to special case all the time. */
4749 ar
->dimen
= ar
->as
->rank
;
4750 for (i
= 0; i
< ar
->dimen
; i
++)
4752 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4754 gcc_assert (ar
->start
[i
] == NULL
);
4755 gcc_assert (ar
->end
[i
] == NULL
);
4756 gcc_assert (ar
->stride
[i
] == NULL
);
4760 /* If the reference type is unknown, figure out what kind it is. */
4762 if (ar
->type
== AR_UNKNOWN
)
4764 ar
->type
= AR_ELEMENT
;
4765 for (i
= 0; i
< ar
->dimen
; i
++)
4766 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4767 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4769 ar
->type
= AR_SECTION
;
4774 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4777 if (ar
->as
->corank
&& ar
->codimen
== 0)
4780 ar
->codimen
= ar
->as
->corank
;
4781 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4782 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4790 resolve_substring (gfc_ref
*ref
)
4792 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4794 if (ref
->u
.ss
.start
!= NULL
)
4796 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4799 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4801 gfc_error ("Substring start index at %L must be of type INTEGER",
4802 &ref
->u
.ss
.start
->where
);
4806 if (ref
->u
.ss
.start
->rank
!= 0)
4808 gfc_error ("Substring start index at %L must be scalar",
4809 &ref
->u
.ss
.start
->where
);
4813 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4814 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4815 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4817 gfc_error ("Substring start index at %L is less than one",
4818 &ref
->u
.ss
.start
->where
);
4823 if (ref
->u
.ss
.end
!= NULL
)
4825 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4828 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4830 gfc_error ("Substring end index at %L must be of type INTEGER",
4831 &ref
->u
.ss
.end
->where
);
4835 if (ref
->u
.ss
.end
->rank
!= 0)
4837 gfc_error ("Substring end index at %L must be scalar",
4838 &ref
->u
.ss
.end
->where
);
4842 if (ref
->u
.ss
.length
!= NULL
4843 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4844 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4845 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4847 gfc_error ("Substring end index at %L exceeds the string length",
4848 &ref
->u
.ss
.start
->where
);
4852 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4853 gfc_integer_kinds
[k
].huge
) == CMP_GT
4854 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4855 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4857 gfc_error ("Substring end index at %L is too large",
4858 &ref
->u
.ss
.end
->where
);
4867 /* This function supplies missing substring charlens. */
4870 gfc_resolve_substring_charlen (gfc_expr
*e
)
4873 gfc_expr
*start
, *end
;
4874 gfc_typespec
*ts
= NULL
;
4876 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4878 if (char_ref
->type
== REF_SUBSTRING
)
4880 if (char_ref
->type
== REF_COMPONENT
)
4881 ts
= &char_ref
->u
.c
.component
->ts
;
4887 gcc_assert (char_ref
->next
== NULL
);
4891 if (e
->ts
.u
.cl
->length
)
4892 gfc_free_expr (e
->ts
.u
.cl
->length
);
4893 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4897 e
->ts
.type
= BT_CHARACTER
;
4898 e
->ts
.kind
= gfc_default_character_kind
;
4901 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4903 if (char_ref
->u
.ss
.start
)
4904 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4906 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
4908 if (char_ref
->u
.ss
.end
)
4909 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4910 else if (e
->expr_type
== EXPR_VARIABLE
)
4913 ts
= &e
->symtree
->n
.sym
->ts
;
4914 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4921 gfc_free_expr (start
);
4922 gfc_free_expr (end
);
4926 /* Length = (end - start + 1). */
4927 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4928 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4929 gfc_get_int_expr (gfc_charlen_int_kind
,
4932 /* F2008, 6.4.1: Both the starting point and the ending point shall
4933 be within the range 1, 2, ..., n unless the starting point exceeds
4934 the ending point, in which case the substring has length zero. */
4936 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4937 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4939 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4940 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4942 /* Make sure that the length is simplified. */
4943 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4944 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4948 /* Resolve subtype references. */
4951 resolve_ref (gfc_expr
*expr
)
4953 int current_part_dimension
, n_components
, seen_part_dimension
;
4956 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4957 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4959 find_array_spec (expr
);
4963 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4967 if (!resolve_array_ref (&ref
->u
.ar
))
4975 if (!resolve_substring (ref
))
4980 /* Check constraints on part references. */
4982 current_part_dimension
= 0;
4983 seen_part_dimension
= 0;
4986 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4991 switch (ref
->u
.ar
.type
)
4994 /* Coarray scalar. */
4995 if (ref
->u
.ar
.as
->rank
== 0)
4997 current_part_dimension
= 0;
5002 current_part_dimension
= 1;
5006 current_part_dimension
= 0;
5010 gfc_internal_error ("resolve_ref(): Bad array reference");
5016 if (current_part_dimension
|| seen_part_dimension
)
5019 if (ref
->u
.c
.component
->attr
.pointer
5020 || ref
->u
.c
.component
->attr
.proc_pointer
5021 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5022 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5024 gfc_error ("Component to the right of a part reference "
5025 "with nonzero rank must not have the POINTER "
5026 "attribute at %L", &expr
->where
);
5029 else if (ref
->u
.c
.component
->attr
.allocatable
5030 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5031 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5034 gfc_error ("Component to the right of a part reference "
5035 "with nonzero rank must not have the ALLOCATABLE "
5036 "attribute at %L", &expr
->where
);
5048 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5049 || ref
->next
== NULL
)
5050 && current_part_dimension
5051 && seen_part_dimension
)
5053 gfc_error ("Two or more part references with nonzero rank must "
5054 "not be specified at %L", &expr
->where
);
5058 if (ref
->type
== REF_COMPONENT
)
5060 if (current_part_dimension
)
5061 seen_part_dimension
= 1;
5063 /* reset to make sure */
5064 current_part_dimension
= 0;
5072 /* Given an expression, determine its shape. This is easier than it sounds.
5073 Leaves the shape array NULL if it is not possible to determine the shape. */
5076 expression_shape (gfc_expr
*e
)
5078 mpz_t array
[GFC_MAX_DIMENSIONS
];
5081 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5084 for (i
= 0; i
< e
->rank
; i
++)
5085 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5088 e
->shape
= gfc_get_shape (e
->rank
);
5090 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5095 for (i
--; i
>= 0; i
--)
5096 mpz_clear (array
[i
]);
5100 /* Given a variable expression node, compute the rank of the expression by
5101 examining the base symbol and any reference structures it may have. */
5104 expression_rank (gfc_expr
*e
)
5109 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5110 could lead to serious confusion... */
5111 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5115 if (e
->expr_type
== EXPR_ARRAY
)
5117 /* Constructors can have a rank different from one via RESHAPE(). */
5119 if (e
->symtree
== NULL
)
5125 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5126 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5132 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5134 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5135 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5136 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5138 if (ref
->type
!= REF_ARRAY
)
5141 if (ref
->u
.ar
.type
== AR_FULL
)
5143 rank
= ref
->u
.ar
.as
->rank
;
5147 if (ref
->u
.ar
.type
== AR_SECTION
)
5149 /* Figure out the rank of the section. */
5151 gfc_internal_error ("expression_rank(): Two array specs");
5153 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5154 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5155 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5165 expression_shape (e
);
5170 add_caf_get_intrinsic (gfc_expr
*e
)
5172 gfc_expr
*wrapper
, *tmp_expr
;
5176 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5177 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5182 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5183 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5186 tmp_expr
= XCNEW (gfc_expr
);
5188 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5189 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5190 wrapper
->ts
= e
->ts
;
5191 wrapper
->rank
= e
->rank
;
5193 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5200 remove_caf_get_intrinsic (gfc_expr
*e
)
5202 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5203 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5204 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5205 e
->value
.function
.actual
->expr
= NULL
;
5206 gfc_free_actual_arglist (e
->value
.function
.actual
);
5207 gfc_free_shape (&e
->shape
, e
->rank
);
5213 /* Resolve a variable expression. */
5216 resolve_variable (gfc_expr
*e
)
5223 if (e
->symtree
== NULL
)
5225 sym
= e
->symtree
->n
.sym
;
5227 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5228 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5229 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5231 if (!actual_arg
|| inquiry_argument
)
5233 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5234 "be used as actual argument", sym
->name
, &e
->where
);
5238 /* TS 29113, 407b. */
5239 else if (e
->ts
.type
== BT_ASSUMED
)
5243 gfc_error ("Assumed-type variable %s at %L may only be used "
5244 "as actual argument", sym
->name
, &e
->where
);
5247 else if (inquiry_argument
&& !first_actual_arg
)
5249 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5250 for all inquiry functions in resolve_function; the reason is
5251 that the function-name resolution happens too late in that
5253 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5254 "an inquiry function shall be the first argument",
5255 sym
->name
, &e
->where
);
5259 /* TS 29113, C535b. */
5260 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5261 && CLASS_DATA (sym
)->as
5262 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5263 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5264 && sym
->as
->type
== AS_ASSUMED_RANK
))
5268 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5269 "actual argument", sym
->name
, &e
->where
);
5272 else if (inquiry_argument
&& !first_actual_arg
)
5274 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5275 for all inquiry functions in resolve_function; the reason is
5276 that the function-name resolution happens too late in that
5278 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5279 "to an inquiry function shall be the first argument",
5280 sym
->name
, &e
->where
);
5285 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5286 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5287 && e
->ref
->next
== NULL
))
5289 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5290 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5293 /* TS 29113, 407b. */
5294 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5295 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5296 && e
->ref
->next
== NULL
))
5298 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5299 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5303 /* TS 29113, C535b. */
5304 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5305 && CLASS_DATA (sym
)->as
5306 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5307 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5308 && sym
->as
->type
== AS_ASSUMED_RANK
))
5310 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5311 && e
->ref
->next
== NULL
))
5313 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5314 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5318 /* For variables that are used in an associate (target => object) where
5319 the object's basetype is array valued while the target is scalar,
5320 the ts' type of the component refs is still array valued, which
5321 can't be translated that way. */
5322 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5323 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5324 && CLASS_DATA (sym
->assoc
->target
)->as
)
5326 gfc_ref
*ref
= e
->ref
;
5332 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5333 /* Stop the loop. */
5343 /* If this is an associate-name, it may be parsed with an array reference
5344 in error even though the target is scalar. Fail directly in this case.
5345 TODO Understand why class scalar expressions must be excluded. */
5346 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5348 if (sym
->ts
.type
== BT_CLASS
)
5349 gfc_fix_class_refs (e
);
5350 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5354 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5355 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5357 /* On the other hand, the parser may not have known this is an array;
5358 in this case, we have to add a FULL reference. */
5359 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5361 e
->ref
= gfc_get_ref ();
5362 e
->ref
->type
= REF_ARRAY
;
5363 e
->ref
->u
.ar
.type
= AR_FULL
;
5364 e
->ref
->u
.ar
.dimen
= 0;
5367 /* Like above, but for class types, where the checking whether an array
5368 ref is present is more complicated. Furthermore make sure not to add
5369 the full array ref to _vptr or _len refs. */
5370 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5371 && CLASS_DATA (sym
)->attr
.dimension
5372 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5374 gfc_ref
*ref
, *newref
;
5376 newref
= gfc_get_ref ();
5377 newref
->type
= REF_ARRAY
;
5378 newref
->u
.ar
.type
= AR_FULL
;
5379 newref
->u
.ar
.dimen
= 0;
5380 /* Because this is an associate var and the first ref either is a ref to
5381 the _data component or not, no traversal of the ref chain is
5382 needed. The array ref needs to be inserted after the _data ref,
5383 or when that is not present, which may happend for polymorphic
5384 types, then at the first position. */
5388 else if (ref
->type
== REF_COMPONENT
5389 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5391 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5393 newref
->next
= ref
->next
;
5397 /* Array ref present already. */
5398 gfc_free_ref_list (newref
);
5400 else if (ref
->type
== REF_ARRAY
)
5401 /* Array ref present already. */
5402 gfc_free_ref_list (newref
);
5410 if (e
->ref
&& !resolve_ref (e
))
5413 if (sym
->attr
.flavor
== FL_PROCEDURE
5414 && (!sym
->attr
.function
5415 || (sym
->attr
.function
&& sym
->result
5416 && sym
->result
->attr
.proc_pointer
5417 && !sym
->result
->attr
.function
)))
5419 e
->ts
.type
= BT_PROCEDURE
;
5420 goto resolve_procedure
;
5423 if (sym
->ts
.type
!= BT_UNKNOWN
)
5424 gfc_variable_attr (e
, &e
->ts
);
5425 else if (sym
->attr
.flavor
== FL_PROCEDURE
5426 && sym
->attr
.function
&& sym
->result
5427 && sym
->result
->ts
.type
!= BT_UNKNOWN
5428 && sym
->result
->attr
.proc_pointer
)
5429 e
->ts
= sym
->result
->ts
;
5432 /* Must be a simple variable reference. */
5433 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5438 if (check_assumed_size_reference (sym
, e
))
5441 /* Deal with forward references to entries during gfc_resolve_code, to
5442 satisfy, at least partially, 12.5.2.5. */
5443 if (gfc_current_ns
->entries
5444 && current_entry_id
== sym
->entry_id
5447 && cs_base
->current
->op
!= EXEC_ENTRY
)
5449 gfc_entry_list
*entry
;
5450 gfc_formal_arglist
*formal
;
5452 bool seen
, saved_specification_expr
;
5454 /* If the symbol is a dummy... */
5455 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5457 entry
= gfc_current_ns
->entries
;
5460 /* ...test if the symbol is a parameter of previous entries. */
5461 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5462 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5464 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5471 /* If it has not been seen as a dummy, this is an error. */
5474 if (specification_expr
)
5475 gfc_error ("Variable %qs, used in a specification expression"
5476 ", is referenced at %L before the ENTRY statement "
5477 "in which it is a parameter",
5478 sym
->name
, &cs_base
->current
->loc
);
5480 gfc_error ("Variable %qs is used at %L before the ENTRY "
5481 "statement in which it is a parameter",
5482 sym
->name
, &cs_base
->current
->loc
);
5487 /* Now do the same check on the specification expressions. */
5488 saved_specification_expr
= specification_expr
;
5489 specification_expr
= true;
5490 if (sym
->ts
.type
== BT_CHARACTER
5491 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5495 for (n
= 0; n
< sym
->as
->rank
; n
++)
5497 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5499 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5502 specification_expr
= saved_specification_expr
;
5505 /* Update the symbol's entry level. */
5506 sym
->entry_id
= current_entry_id
+ 1;
5509 /* If a symbol has been host_associated mark it. This is used latter,
5510 to identify if aliasing is possible via host association. */
5511 if (sym
->attr
.flavor
== FL_VARIABLE
5512 && gfc_current_ns
->parent
5513 && (gfc_current_ns
->parent
== sym
->ns
5514 || (gfc_current_ns
->parent
->parent
5515 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5516 sym
->attr
.host_assoc
= 1;
5518 if (gfc_current_ns
->proc_name
5519 && sym
->attr
.dimension
5520 && (sym
->ns
!= gfc_current_ns
5521 || sym
->attr
.use_assoc
5522 || sym
->attr
.in_common
))
5523 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5526 if (t
&& !resolve_procedure_expression (e
))
5529 /* F2008, C617 and C1229. */
5530 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5531 && gfc_is_coindexed (e
))
5533 gfc_ref
*ref
, *ref2
= NULL
;
5535 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5537 if (ref
->type
== REF_COMPONENT
)
5539 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5543 for ( ; ref
; ref
= ref
->next
)
5544 if (ref
->type
== REF_COMPONENT
)
5547 /* Expression itself is not coindexed object. */
5548 if (ref
&& e
->ts
.type
== BT_CLASS
)
5550 gfc_error ("Polymorphic subobject of coindexed object at %L",
5555 /* Expression itself is coindexed object. */
5559 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5560 for ( ; c
; c
= c
->next
)
5561 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5563 gfc_error ("Coindexed object with polymorphic allocatable "
5564 "subcomponent at %L", &e
->where
);
5572 expression_rank (e
);
5574 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5575 add_caf_get_intrinsic (e
);
5581 /* Checks to see that the correct symbol has been host associated.
5582 The only situation where this arises is that in which a twice
5583 contained function is parsed after the host association is made.
5584 Therefore, on detecting this, change the symbol in the expression
5585 and convert the array reference into an actual arglist if the old
5586 symbol is a variable. */
5588 check_host_association (gfc_expr
*e
)
5590 gfc_symbol
*sym
, *old_sym
;
5594 gfc_actual_arglist
*arg
, *tail
= NULL
;
5595 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5597 /* If the expression is the result of substitution in
5598 interface.c(gfc_extend_expr) because there is no way in
5599 which the host association can be wrong. */
5600 if (e
->symtree
== NULL
5601 || e
->symtree
->n
.sym
== NULL
5602 || e
->user_operator
)
5605 old_sym
= e
->symtree
->n
.sym
;
5607 if (gfc_current_ns
->parent
5608 && old_sym
->ns
!= gfc_current_ns
)
5610 /* Use the 'USE' name so that renamed module symbols are
5611 correctly handled. */
5612 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5614 if (sym
&& old_sym
!= sym
5615 && sym
->ts
.type
== old_sym
->ts
.type
5616 && sym
->attr
.flavor
== FL_PROCEDURE
5617 && sym
->attr
.contained
)
5619 /* Clear the shape, since it might not be valid. */
5620 gfc_free_shape (&e
->shape
, e
->rank
);
5622 /* Give the expression the right symtree! */
5623 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5624 gcc_assert (st
!= NULL
);
5626 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5627 || e
->expr_type
== EXPR_FUNCTION
)
5629 /* Original was function so point to the new symbol, since
5630 the actual argument list is already attached to the
5632 e
->value
.function
.esym
= NULL
;
5637 /* Original was variable so convert array references into
5638 an actual arglist. This does not need any checking now
5639 since resolve_function will take care of it. */
5640 e
->value
.function
.actual
= NULL
;
5641 e
->expr_type
= EXPR_FUNCTION
;
5644 /* Ambiguity will not arise if the array reference is not
5645 the last reference. */
5646 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5647 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5650 gcc_assert (ref
->type
== REF_ARRAY
);
5652 /* Grab the start expressions from the array ref and
5653 copy them into actual arguments. */
5654 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5656 arg
= gfc_get_actual_arglist ();
5657 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5658 if (e
->value
.function
.actual
== NULL
)
5659 tail
= e
->value
.function
.actual
= arg
;
5667 /* Dump the reference list and set the rank. */
5668 gfc_free_ref_list (e
->ref
);
5670 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5673 gfc_resolve_expr (e
);
5677 /* This might have changed! */
5678 return e
->expr_type
== EXPR_FUNCTION
;
5683 gfc_resolve_character_operator (gfc_expr
*e
)
5685 gfc_expr
*op1
= e
->value
.op
.op1
;
5686 gfc_expr
*op2
= e
->value
.op
.op2
;
5687 gfc_expr
*e1
= NULL
;
5688 gfc_expr
*e2
= NULL
;
5690 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5692 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5693 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5694 else if (op1
->expr_type
== EXPR_CONSTANT
)
5695 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5696 op1
->value
.character
.length
);
5698 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5699 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5700 else if (op2
->expr_type
== EXPR_CONSTANT
)
5701 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5702 op2
->value
.character
.length
);
5704 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5714 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5715 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5716 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5717 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5718 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5724 /* Ensure that an character expression has a charlen and, if possible, a
5725 length expression. */
5728 fixup_charlen (gfc_expr
*e
)
5730 /* The cases fall through so that changes in expression type and the need
5731 for multiple fixes are picked up. In all circumstances, a charlen should
5732 be available for the middle end to hang a backend_decl on. */
5733 switch (e
->expr_type
)
5736 gfc_resolve_character_operator (e
);
5740 if (e
->expr_type
== EXPR_ARRAY
)
5741 gfc_resolve_character_array_constructor (e
);
5744 case EXPR_SUBSTRING
:
5745 if (!e
->ts
.u
.cl
&& e
->ref
)
5746 gfc_resolve_substring_charlen (e
);
5751 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5758 /* Update an actual argument to include the passed-object for type-bound
5759 procedures at the right position. */
5761 static gfc_actual_arglist
*
5762 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5765 gcc_assert (argpos
> 0);
5769 gfc_actual_arglist
* result
;
5771 result
= gfc_get_actual_arglist ();
5775 result
->name
= name
;
5781 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5783 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5788 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5791 extract_compcall_passed_object (gfc_expr
* e
)
5795 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5797 if (e
->value
.compcall
.base_object
)
5798 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5801 po
= gfc_get_expr ();
5802 po
->expr_type
= EXPR_VARIABLE
;
5803 po
->symtree
= e
->symtree
;
5804 po
->ref
= gfc_copy_ref (e
->ref
);
5805 po
->where
= e
->where
;
5808 if (!gfc_resolve_expr (po
))
5815 /* Update the arglist of an EXPR_COMPCALL expression to include the
5819 update_compcall_arglist (gfc_expr
* e
)
5822 gfc_typebound_proc
* tbp
;
5824 tbp
= e
->value
.compcall
.tbp
;
5829 po
= extract_compcall_passed_object (e
);
5833 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5839 if (tbp
->pass_arg_num
<= 0)
5842 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5850 /* Extract the passed object from a PPC call (a copy of it). */
5853 extract_ppc_passed_object (gfc_expr
*e
)
5858 po
= gfc_get_expr ();
5859 po
->expr_type
= EXPR_VARIABLE
;
5860 po
->symtree
= e
->symtree
;
5861 po
->ref
= gfc_copy_ref (e
->ref
);
5862 po
->where
= e
->where
;
5864 /* Remove PPC reference. */
5866 while ((*ref
)->next
)
5867 ref
= &(*ref
)->next
;
5868 gfc_free_ref_list (*ref
);
5871 if (!gfc_resolve_expr (po
))
5878 /* Update the actual arglist of a procedure pointer component to include the
5882 update_ppc_arglist (gfc_expr
* e
)
5886 gfc_typebound_proc
* tb
;
5888 ppc
= gfc_get_proc_ptr_comp (e
);
5896 else if (tb
->nopass
)
5899 po
= extract_ppc_passed_object (e
);
5906 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5911 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5913 gfc_error ("Base object for procedure-pointer component call at %L is of"
5914 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5918 gcc_assert (tb
->pass_arg_num
> 0);
5919 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5927 /* Check that the object a TBP is called on is valid, i.e. it must not be
5928 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5931 check_typebound_baseobject (gfc_expr
* e
)
5934 bool return_value
= false;
5936 base
= extract_compcall_passed_object (e
);
5940 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5942 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5946 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5948 gfc_error ("Base object for type-bound procedure call at %L is of"
5949 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5953 /* F08:C1230. If the procedure called is NOPASS,
5954 the base object must be scalar. */
5955 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5957 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5958 " be scalar", &e
->where
);
5962 return_value
= true;
5965 gfc_free_expr (base
);
5966 return return_value
;
5970 /* Resolve a call to a type-bound procedure, either function or subroutine,
5971 statically from the data in an EXPR_COMPCALL expression. The adapted
5972 arglist and the target-procedure symtree are returned. */
5975 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5976 gfc_actual_arglist
** actual
)
5978 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5979 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5981 /* Update the actual arglist for PASS. */
5982 if (!update_compcall_arglist (e
))
5985 *actual
= e
->value
.compcall
.actual
;
5986 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5988 gfc_free_ref_list (e
->ref
);
5990 e
->value
.compcall
.actual
= NULL
;
5992 /* If we find a deferred typebound procedure, check for derived types
5993 that an overriding typebound procedure has not been missed. */
5994 if (e
->value
.compcall
.name
5995 && !e
->value
.compcall
.tbp
->non_overridable
5996 && e
->value
.compcall
.base_object
5997 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6000 gfc_symbol
*derived
;
6002 /* Use the derived type of the base_object. */
6003 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6006 /* If necessary, go through the inheritance chain. */
6007 while (!st
&& derived
)
6009 /* Look for the typebound procedure 'name'. */
6010 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6011 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6012 e
->value
.compcall
.name
);
6014 derived
= gfc_get_derived_super_type (derived
);
6017 /* Now find the specific name in the derived type namespace. */
6018 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6019 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6020 derived
->ns
, 1, &st
);
6028 /* Get the ultimate declared type from an expression. In addition,
6029 return the last class/derived type reference and the copy of the
6030 reference list. If check_types is set true, derived types are
6031 identified as well as class references. */
6033 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6034 gfc_expr
*e
, bool check_types
)
6036 gfc_symbol
*declared
;
6043 *new_ref
= gfc_copy_ref (e
->ref
);
6045 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6047 if (ref
->type
!= REF_COMPONENT
)
6050 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6051 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6052 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6054 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6060 if (declared
== NULL
)
6061 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6067 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6068 which of the specific bindings (if any) matches the arglist and transform
6069 the expression into a call of that binding. */
6072 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6074 gfc_typebound_proc
* genproc
;
6075 const char* genname
;
6077 gfc_symbol
*derived
;
6079 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6080 genname
= e
->value
.compcall
.name
;
6081 genproc
= e
->value
.compcall
.tbp
;
6083 if (!genproc
->is_generic
)
6086 /* Try the bindings on this type and in the inheritance hierarchy. */
6087 for (; genproc
; genproc
= genproc
->overridden
)
6091 gcc_assert (genproc
->is_generic
);
6092 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6095 gfc_actual_arglist
* args
;
6098 gcc_assert (g
->specific
);
6100 if (g
->specific
->error
)
6103 target
= g
->specific
->u
.specific
->n
.sym
;
6105 /* Get the right arglist by handling PASS/NOPASS. */
6106 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6107 if (!g
->specific
->nopass
)
6110 po
= extract_compcall_passed_object (e
);
6113 gfc_free_actual_arglist (args
);
6117 gcc_assert (g
->specific
->pass_arg_num
> 0);
6118 gcc_assert (!g
->specific
->error
);
6119 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6120 g
->specific
->pass_arg
);
6122 resolve_actual_arglist (args
, target
->attr
.proc
,
6123 is_external_proc (target
)
6124 && gfc_sym_get_dummy_args (target
) == NULL
);
6126 /* Check if this arglist matches the formal. */
6127 matches
= gfc_arglist_matches_symbol (&args
, target
);
6129 /* Clean up and break out of the loop if we've found it. */
6130 gfc_free_actual_arglist (args
);
6133 e
->value
.compcall
.tbp
= g
->specific
;
6134 genname
= g
->specific_st
->name
;
6135 /* Pass along the name for CLASS methods, where the vtab
6136 procedure pointer component has to be referenced. */
6144 /* Nothing matching found! */
6145 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6146 " %qs at %L", genname
, &e
->where
);
6150 /* Make sure that we have the right specific instance for the name. */
6151 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6153 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6155 e
->value
.compcall
.tbp
= st
->n
.tb
;
6161 /* Resolve a call to a type-bound subroutine. */
6164 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6166 gfc_actual_arglist
* newactual
;
6167 gfc_symtree
* target
;
6169 /* Check that's really a SUBROUTINE. */
6170 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6172 gfc_error ("%qs at %L should be a SUBROUTINE",
6173 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6177 if (!check_typebound_baseobject (c
->expr1
))
6180 /* Pass along the name for CLASS methods, where the vtab
6181 procedure pointer component has to be referenced. */
6183 *name
= c
->expr1
->value
.compcall
.name
;
6185 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6188 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6190 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6192 /* Transform into an ordinary EXEC_CALL for now. */
6194 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6197 c
->ext
.actual
= newactual
;
6198 c
->symtree
= target
;
6199 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6201 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6203 gfc_free_expr (c
->expr1
);
6204 c
->expr1
= gfc_get_expr ();
6205 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6206 c
->expr1
->symtree
= target
;
6207 c
->expr1
->where
= c
->loc
;
6209 return resolve_call (c
);
6213 /* Resolve a component-call expression. */
6215 resolve_compcall (gfc_expr
* e
, const char **name
)
6217 gfc_actual_arglist
* newactual
;
6218 gfc_symtree
* target
;
6220 /* Check that's really a FUNCTION. */
6221 if (!e
->value
.compcall
.tbp
->function
)
6223 gfc_error ("%qs at %L should be a FUNCTION",
6224 e
->value
.compcall
.name
, &e
->where
);
6228 /* These must not be assign-calls! */
6229 gcc_assert (!e
->value
.compcall
.assign
);
6231 if (!check_typebound_baseobject (e
))
6234 /* Pass along the name for CLASS methods, where the vtab
6235 procedure pointer component has to be referenced. */
6237 *name
= e
->value
.compcall
.name
;
6239 if (!resolve_typebound_generic_call (e
, name
))
6241 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6243 /* Take the rank from the function's symbol. */
6244 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6245 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6247 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6248 arglist to the TBP's binding target. */
6250 if (!resolve_typebound_static (e
, &target
, &newactual
))
6253 e
->value
.function
.actual
= newactual
;
6254 e
->value
.function
.name
= NULL
;
6255 e
->value
.function
.esym
= target
->n
.sym
;
6256 e
->value
.function
.isym
= NULL
;
6257 e
->symtree
= target
;
6258 e
->ts
= target
->n
.sym
->ts
;
6259 e
->expr_type
= EXPR_FUNCTION
;
6261 /* Resolution is not necessary if this is a class subroutine; this
6262 function only has to identify the specific proc. Resolution of
6263 the call will be done next in resolve_typebound_call. */
6264 return gfc_resolve_expr (e
);
6268 static bool resolve_fl_derived (gfc_symbol
*sym
);
6271 /* Resolve a typebound function, or 'method'. First separate all
6272 the non-CLASS references by calling resolve_compcall directly. */
6275 resolve_typebound_function (gfc_expr
* e
)
6277 gfc_symbol
*declared
;
6289 /* Deal with typebound operators for CLASS objects. */
6290 expr
= e
->value
.compcall
.base_object
;
6291 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6292 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6294 /* If the base_object is not a variable, the corresponding actual
6295 argument expression must be stored in e->base_expression so
6296 that the corresponding tree temporary can be used as the base
6297 object in gfc_conv_procedure_call. */
6298 if (expr
->expr_type
!= EXPR_VARIABLE
)
6300 gfc_actual_arglist
*args
;
6302 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6304 if (expr
== args
->expr
)
6309 /* Since the typebound operators are generic, we have to ensure
6310 that any delays in resolution are corrected and that the vtab
6313 declared
= ts
.u
.derived
;
6314 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6315 if (c
->ts
.u
.derived
== NULL
)
6316 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6318 if (!resolve_compcall (e
, &name
))
6321 /* Use the generic name if it is there. */
6322 name
= name
? name
: e
->value
.function
.esym
->name
;
6323 e
->symtree
= expr
->symtree
;
6324 e
->ref
= gfc_copy_ref (expr
->ref
);
6325 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6327 /* Trim away the extraneous references that emerge from nested
6328 use of interface.c (extend_expr). */
6329 if (class_ref
&& class_ref
->next
)
6331 gfc_free_ref_list (class_ref
->next
);
6332 class_ref
->next
= NULL
;
6334 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6336 gfc_free_ref_list (e
->ref
);
6340 gfc_add_vptr_component (e
);
6341 gfc_add_component_ref (e
, name
);
6342 e
->value
.function
.esym
= NULL
;
6343 if (expr
->expr_type
!= EXPR_VARIABLE
)
6344 e
->base_expr
= expr
;
6349 return resolve_compcall (e
, NULL
);
6351 if (!resolve_ref (e
))
6354 /* Get the CLASS declared type. */
6355 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6357 if (!resolve_fl_derived (declared
))
6360 /* Weed out cases of the ultimate component being a derived type. */
6361 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6362 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6364 gfc_free_ref_list (new_ref
);
6365 return resolve_compcall (e
, NULL
);
6368 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6369 declared
= c
->ts
.u
.derived
;
6371 /* Treat the call as if it is a typebound procedure, in order to roll
6372 out the correct name for the specific function. */
6373 if (!resolve_compcall (e
, &name
))
6375 gfc_free_ref_list (new_ref
);
6382 /* Convert the expression to a procedure pointer component call. */
6383 e
->value
.function
.esym
= NULL
;
6389 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6390 gfc_add_vptr_component (e
);
6391 gfc_add_component_ref (e
, name
);
6393 /* Recover the typespec for the expression. This is really only
6394 necessary for generic procedures, where the additional call
6395 to gfc_add_component_ref seems to throw the collection of the
6396 correct typespec. */
6400 gfc_free_ref_list (new_ref
);
6405 /* Resolve a typebound subroutine, or 'method'. First separate all
6406 the non-CLASS references by calling resolve_typebound_call
6410 resolve_typebound_subroutine (gfc_code
*code
)
6412 gfc_symbol
*declared
;
6422 st
= code
->expr1
->symtree
;
6424 /* Deal with typebound operators for CLASS objects. */
6425 expr
= code
->expr1
->value
.compcall
.base_object
;
6426 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6427 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6429 /* If the base_object is not a variable, the corresponding actual
6430 argument expression must be stored in e->base_expression so
6431 that the corresponding tree temporary can be used as the base
6432 object in gfc_conv_procedure_call. */
6433 if (expr
->expr_type
!= EXPR_VARIABLE
)
6435 gfc_actual_arglist
*args
;
6437 args
= code
->expr1
->value
.function
.actual
;
6438 for (; args
; args
= args
->next
)
6439 if (expr
== args
->expr
)
6443 /* Since the typebound operators are generic, we have to ensure
6444 that any delays in resolution are corrected and that the vtab
6446 declared
= expr
->ts
.u
.derived
;
6447 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6448 if (c
->ts
.u
.derived
== NULL
)
6449 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6451 if (!resolve_typebound_call (code
, &name
, NULL
))
6454 /* Use the generic name if it is there. */
6455 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6456 code
->expr1
->symtree
= expr
->symtree
;
6457 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6459 /* Trim away the extraneous references that emerge from nested
6460 use of interface.c (extend_expr). */
6461 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6462 if (class_ref
&& class_ref
->next
)
6464 gfc_free_ref_list (class_ref
->next
);
6465 class_ref
->next
= NULL
;
6467 else if (code
->expr1
->ref
&& !class_ref
)
6469 gfc_free_ref_list (code
->expr1
->ref
);
6470 code
->expr1
->ref
= NULL
;
6473 /* Now use the procedure in the vtable. */
6474 gfc_add_vptr_component (code
->expr1
);
6475 gfc_add_component_ref (code
->expr1
, name
);
6476 code
->expr1
->value
.function
.esym
= NULL
;
6477 if (expr
->expr_type
!= EXPR_VARIABLE
)
6478 code
->expr1
->base_expr
= expr
;
6483 return resolve_typebound_call (code
, NULL
, NULL
);
6485 if (!resolve_ref (code
->expr1
))
6488 /* Get the CLASS declared type. */
6489 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6491 /* Weed out cases of the ultimate component being a derived type. */
6492 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6493 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6495 gfc_free_ref_list (new_ref
);
6496 return resolve_typebound_call (code
, NULL
, NULL
);
6499 if (!resolve_typebound_call (code
, &name
, &overridable
))
6501 gfc_free_ref_list (new_ref
);
6504 ts
= code
->expr1
->ts
;
6508 /* Convert the expression to a procedure pointer component call. */
6509 code
->expr1
->value
.function
.esym
= NULL
;
6510 code
->expr1
->symtree
= st
;
6513 code
->expr1
->ref
= new_ref
;
6515 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6516 gfc_add_vptr_component (code
->expr1
);
6517 gfc_add_component_ref (code
->expr1
, name
);
6519 /* Recover the typespec for the expression. This is really only
6520 necessary for generic procedures, where the additional call
6521 to gfc_add_component_ref seems to throw the collection of the
6522 correct typespec. */
6523 code
->expr1
->ts
= ts
;
6526 gfc_free_ref_list (new_ref
);
6532 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6535 resolve_ppc_call (gfc_code
* c
)
6537 gfc_component
*comp
;
6539 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6540 gcc_assert (comp
!= NULL
);
6542 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6543 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6545 if (!comp
->attr
.subroutine
)
6546 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6548 if (!resolve_ref (c
->expr1
))
6551 if (!update_ppc_arglist (c
->expr1
))
6554 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6556 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6557 !(comp
->ts
.interface
6558 && comp
->ts
.interface
->formal
)))
6561 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6564 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6570 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6573 resolve_expr_ppc (gfc_expr
* e
)
6575 gfc_component
*comp
;
6577 comp
= gfc_get_proc_ptr_comp (e
);
6578 gcc_assert (comp
!= NULL
);
6580 /* Convert to EXPR_FUNCTION. */
6581 e
->expr_type
= EXPR_FUNCTION
;
6582 e
->value
.function
.isym
= NULL
;
6583 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6585 if (comp
->as
!= NULL
)
6586 e
->rank
= comp
->as
->rank
;
6588 if (!comp
->attr
.function
)
6589 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6591 if (!resolve_ref (e
))
6594 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6595 !(comp
->ts
.interface
6596 && comp
->ts
.interface
->formal
)))
6599 if (!update_ppc_arglist (e
))
6602 if (!check_pure_function(e
))
6605 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6612 gfc_is_expandable_expr (gfc_expr
*e
)
6614 gfc_constructor
*con
;
6616 if (e
->expr_type
== EXPR_ARRAY
)
6618 /* Traverse the constructor looking for variables that are flavor
6619 parameter. Parameters must be expanded since they are fully used at
6621 con
= gfc_constructor_first (e
->value
.constructor
);
6622 for (; con
; con
= gfc_constructor_next (con
))
6624 if (con
->expr
->expr_type
== EXPR_VARIABLE
6625 && con
->expr
->symtree
6626 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6627 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6629 if (con
->expr
->expr_type
== EXPR_ARRAY
6630 && gfc_is_expandable_expr (con
->expr
))
6639 /* Sometimes variables in specification expressions of the result
6640 of module procedures in submodules wind up not being the 'real'
6641 dummy. Find this, if possible, in the namespace of the first
6645 fixup_unique_dummy (gfc_expr
*e
)
6647 gfc_symtree
*st
= NULL
;
6648 gfc_symbol
*s
= NULL
;
6650 if (e
->symtree
->n
.sym
->ns
->proc_name
6651 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6652 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6655 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6658 && st
->n
.sym
!= NULL
6659 && st
->n
.sym
->attr
.dummy
)
6663 /* Resolve an expression. That is, make sure that types of operands agree
6664 with their operators, intrinsic operators are converted to function calls
6665 for overloaded types and unresolved function references are resolved. */
6668 gfc_resolve_expr (gfc_expr
*e
)
6671 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6676 /* inquiry_argument only applies to variables. */
6677 inquiry_save
= inquiry_argument
;
6678 actual_arg_save
= actual_arg
;
6679 first_actual_arg_save
= first_actual_arg
;
6681 if (e
->expr_type
!= EXPR_VARIABLE
)
6683 inquiry_argument
= false;
6685 first_actual_arg
= false;
6687 else if (e
->symtree
!= NULL
6688 && *e
->symtree
->name
== '@'
6689 && e
->symtree
->n
.sym
->attr
.dummy
)
6691 /* Deal with submodule specification expressions that are not
6692 found to be referenced in module.c(read_cleanup). */
6693 fixup_unique_dummy (e
);
6696 switch (e
->expr_type
)
6699 t
= resolve_operator (e
);
6705 if (check_host_association (e
))
6706 t
= resolve_function (e
);
6708 t
= resolve_variable (e
);
6710 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6711 && e
->ref
->type
!= REF_SUBSTRING
)
6712 gfc_resolve_substring_charlen (e
);
6717 t
= resolve_typebound_function (e
);
6720 case EXPR_SUBSTRING
:
6721 t
= resolve_ref (e
);
6730 t
= resolve_expr_ppc (e
);
6735 if (!resolve_ref (e
))
6738 t
= gfc_resolve_array_constructor (e
);
6739 /* Also try to expand a constructor. */
6742 expression_rank (e
);
6743 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6744 gfc_expand_constructor (e
, false);
6747 /* This provides the opportunity for the length of constructors with
6748 character valued function elements to propagate the string length
6749 to the expression. */
6750 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6752 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6753 here rather then add a duplicate test for it above. */
6754 gfc_expand_constructor (e
, false);
6755 t
= gfc_resolve_character_array_constructor (e
);
6760 case EXPR_STRUCTURE
:
6761 t
= resolve_ref (e
);
6765 t
= resolve_structure_cons (e
, 0);
6769 t
= gfc_simplify_expr (e
, 0);
6773 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6776 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6779 inquiry_argument
= inquiry_save
;
6780 actual_arg
= actual_arg_save
;
6781 first_actual_arg
= first_actual_arg_save
;
6787 /* Resolve an expression from an iterator. They must be scalar and have
6788 INTEGER or (optionally) REAL type. */
6791 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6792 const char *name_msgid
)
6794 if (!gfc_resolve_expr (expr
))
6797 if (expr
->rank
!= 0)
6799 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6803 if (expr
->ts
.type
!= BT_INTEGER
)
6805 if (expr
->ts
.type
== BT_REAL
)
6808 return gfc_notify_std (GFC_STD_F95_DEL
,
6809 "%s at %L must be integer",
6810 _(name_msgid
), &expr
->where
);
6813 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6820 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6828 /* Resolve the expressions in an iterator structure. If REAL_OK is
6829 false allow only INTEGER type iterators, otherwise allow REAL types.
6830 Set own_scope to true for ac-implied-do and data-implied-do as those
6831 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6834 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6836 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6839 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6840 _("iterator variable")))
6843 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6844 "Start expression in DO loop"))
6847 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6848 "End expression in DO loop"))
6851 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6852 "Step expression in DO loop"))
6855 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6857 if ((iter
->step
->ts
.type
== BT_INTEGER
6858 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6859 || (iter
->step
->ts
.type
== BT_REAL
6860 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6862 gfc_error ("Step expression in DO loop at %L cannot be zero",
6863 &iter
->step
->where
);
6868 /* Convert start, end, and step to the same type as var. */
6869 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6870 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6871 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6873 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6874 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6875 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6877 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6878 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6879 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
6881 if (iter
->start
->expr_type
== EXPR_CONSTANT
6882 && iter
->end
->expr_type
== EXPR_CONSTANT
6883 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6886 if (iter
->start
->ts
.type
== BT_INTEGER
)
6888 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6889 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6893 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6894 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6896 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6897 gfc_warning (OPT_Wzerotrip
,
6898 "DO loop at %L will be executed zero times",
6899 &iter
->step
->where
);
6902 if (iter
->end
->expr_type
== EXPR_CONSTANT
6903 && iter
->end
->ts
.type
== BT_INTEGER
6904 && iter
->step
->expr_type
== EXPR_CONSTANT
6905 && iter
->step
->ts
.type
== BT_INTEGER
6906 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
6907 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
6909 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
6910 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
6912 if (is_step_positive
6913 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
6914 gfc_warning (OPT_Wundefined_do_loop
,
6915 "DO loop at %L is undefined as it overflows",
6916 &iter
->step
->where
);
6917 else if (!is_step_positive
6918 && mpz_cmp (iter
->end
->value
.integer
,
6919 gfc_integer_kinds
[k
].min_int
) == 0)
6920 gfc_warning (OPT_Wundefined_do_loop
,
6921 "DO loop at %L is undefined as it underflows",
6922 &iter
->step
->where
);
6929 /* Traversal function for find_forall_index. f == 2 signals that
6930 that variable itself is not to be checked - only the references. */
6933 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6935 if (expr
->expr_type
!= EXPR_VARIABLE
)
6938 /* A scalar assignment */
6939 if (!expr
->ref
|| *f
== 1)
6941 if (expr
->symtree
->n
.sym
== sym
)
6953 /* Check whether the FORALL index appears in the expression or not.
6954 Returns true if SYM is found in EXPR. */
6957 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6959 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6966 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6967 to be a scalar INTEGER variable. The subscripts and stride are scalar
6968 INTEGERs, and if stride is a constant it must be nonzero.
6969 Furthermore "A subscript or stride in a forall-triplet-spec shall
6970 not contain a reference to any index-name in the
6971 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6974 resolve_forall_iterators (gfc_forall_iterator
*it
)
6976 gfc_forall_iterator
*iter
, *iter2
;
6978 for (iter
= it
; iter
; iter
= iter
->next
)
6980 if (gfc_resolve_expr (iter
->var
)
6981 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6982 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6985 if (gfc_resolve_expr (iter
->start
)
6986 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6987 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6988 &iter
->start
->where
);
6989 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6990 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6992 if (gfc_resolve_expr (iter
->end
)
6993 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6994 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6996 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6997 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6999 if (gfc_resolve_expr (iter
->stride
))
7001 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7002 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7003 &iter
->stride
->where
, "INTEGER");
7005 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7006 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7007 gfc_error ("FORALL stride expression at %L cannot be zero",
7008 &iter
->stride
->where
);
7010 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7011 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7014 for (iter
= it
; iter
; iter
= iter
->next
)
7015 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7017 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7018 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7019 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7020 gfc_error ("FORALL index %qs may not appear in triplet "
7021 "specification at %L", iter
->var
->symtree
->name
,
7022 &iter2
->start
->where
);
7027 /* Given a pointer to a symbol that is a derived type, see if it's
7028 inaccessible, i.e. if it's defined in another module and the components are
7029 PRIVATE. The search is recursive if necessary. Returns zero if no
7030 inaccessible components are found, nonzero otherwise. */
7033 derived_inaccessible (gfc_symbol
*sym
)
7037 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7040 for (c
= sym
->components
; c
; c
= c
->next
)
7042 /* Prevent an infinite loop through this function. */
7043 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7044 && sym
== c
->ts
.u
.derived
)
7047 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7055 /* Resolve the argument of a deallocate expression. The expression must be
7056 a pointer or a full array. */
7059 resolve_deallocate_expr (gfc_expr
*e
)
7061 symbol_attribute attr
;
7062 int allocatable
, pointer
;
7068 if (!gfc_resolve_expr (e
))
7071 if (e
->expr_type
!= EXPR_VARIABLE
)
7074 sym
= e
->symtree
->n
.sym
;
7075 unlimited
= UNLIMITED_POLY(sym
);
7077 if (sym
->ts
.type
== BT_CLASS
)
7079 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7080 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7084 allocatable
= sym
->attr
.allocatable
;
7085 pointer
= sym
->attr
.pointer
;
7087 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7092 if (ref
->u
.ar
.type
!= AR_FULL
7093 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7094 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7099 c
= ref
->u
.c
.component
;
7100 if (c
->ts
.type
== BT_CLASS
)
7102 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7103 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7107 allocatable
= c
->attr
.allocatable
;
7108 pointer
= c
->attr
.pointer
;
7118 attr
= gfc_expr_attr (e
);
7120 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7123 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7129 if (gfc_is_coindexed (e
))
7131 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7136 && !gfc_check_vardef_context (e
, true, true, false,
7137 _("DEALLOCATE object")))
7139 if (!gfc_check_vardef_context (e
, false, true, false,
7140 _("DEALLOCATE object")))
7147 /* Returns true if the expression e contains a reference to the symbol sym. */
7149 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7151 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7158 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7160 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7164 /* Given the expression node e for an allocatable/pointer of derived type to be
7165 allocated, get the expression node to be initialized afterwards (needed for
7166 derived types with default initializers, and derived types with allocatable
7167 components that need nullification.) */
7170 gfc_expr_to_initialize (gfc_expr
*e
)
7176 result
= gfc_copy_expr (e
);
7178 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7179 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7180 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7182 ref
->u
.ar
.type
= AR_FULL
;
7184 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7185 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7190 gfc_free_shape (&result
->shape
, result
->rank
);
7192 /* Recalculate rank, shape, etc. */
7193 gfc_resolve_expr (result
);
7198 /* If the last ref of an expression is an array ref, return a copy of the
7199 expression with that one removed. Otherwise, a copy of the original
7200 expression. This is used for allocate-expressions and pointer assignment
7201 LHS, where there may be an array specification that needs to be stripped
7202 off when using gfc_check_vardef_context. */
7205 remove_last_array_ref (gfc_expr
* e
)
7210 e2
= gfc_copy_expr (e
);
7211 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7212 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7214 gfc_free_ref_list (*r
);
7223 /* Used in resolve_allocate_expr to check that a allocation-object and
7224 a source-expr are conformable. This does not catch all possible
7225 cases; in particular a runtime checking is needed. */
7228 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7231 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7233 /* First compare rank. */
7234 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7235 || (!tail
&& e1
->rank
!= e2
->rank
))
7237 gfc_error ("Source-expr at %L must be scalar or have the "
7238 "same rank as the allocate-object at %L",
7239 &e1
->where
, &e2
->where
);
7250 for (i
= 0; i
< e1
->rank
; i
++)
7252 if (tail
->u
.ar
.start
[i
] == NULL
)
7255 if (tail
->u
.ar
.end
[i
])
7257 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7258 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7259 mpz_add_ui (s
, s
, 1);
7263 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7266 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7268 gfc_error ("Source-expr at %L and allocate-object at %L must "
7269 "have the same shape", &e1
->where
, &e2
->where
);
7282 /* Resolve the expression in an ALLOCATE statement, doing the additional
7283 checks to see whether the expression is OK or not. The expression must
7284 have a trailing array reference that gives the size of the array. */
7287 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7289 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7293 symbol_attribute attr
;
7294 gfc_ref
*ref
, *ref2
;
7297 gfc_symbol
*sym
= NULL
;
7302 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7303 checking of coarrays. */
7304 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7305 if (ref
->next
== NULL
)
7308 if (ref
&& ref
->type
== REF_ARRAY
)
7309 ref
->u
.ar
.in_allocate
= true;
7311 if (!gfc_resolve_expr (e
))
7314 /* Make sure the expression is allocatable or a pointer. If it is
7315 pointer, the next-to-last reference must be a pointer. */
7319 sym
= e
->symtree
->n
.sym
;
7321 /* Check whether ultimate component is abstract and CLASS. */
7324 /* Is the allocate-object unlimited polymorphic? */
7325 unlimited
= UNLIMITED_POLY(e
);
7327 if (e
->expr_type
!= EXPR_VARIABLE
)
7330 attr
= gfc_expr_attr (e
);
7331 pointer
= attr
.pointer
;
7332 dimension
= attr
.dimension
;
7333 codimension
= attr
.codimension
;
7337 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7339 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7340 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7341 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7342 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7343 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7347 allocatable
= sym
->attr
.allocatable
;
7348 pointer
= sym
->attr
.pointer
;
7349 dimension
= sym
->attr
.dimension
;
7350 codimension
= sym
->attr
.codimension
;
7355 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7360 if (ref
->u
.ar
.codimen
> 0)
7363 for (n
= ref
->u
.ar
.dimen
;
7364 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7365 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7372 if (ref
->next
!= NULL
)
7380 gfc_error ("Coindexed allocatable object at %L",
7385 c
= ref
->u
.c
.component
;
7386 if (c
->ts
.type
== BT_CLASS
)
7388 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7389 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7390 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7391 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7392 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7396 allocatable
= c
->attr
.allocatable
;
7397 pointer
= c
->attr
.pointer
;
7398 dimension
= c
->attr
.dimension
;
7399 codimension
= c
->attr
.codimension
;
7400 is_abstract
= c
->attr
.abstract
;
7412 /* Check for F08:C628. */
7413 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7415 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7420 /* Some checks for the SOURCE tag. */
7423 /* Check F03:C631. */
7424 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7426 gfc_error ("Type of entity at %L is type incompatible with "
7427 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7431 /* Check F03:C632 and restriction following Note 6.18. */
7432 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7435 /* Check F03:C633. */
7436 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7438 gfc_error ("The allocate-object at %L and the source-expr at %L "
7439 "shall have the same kind type parameter",
7440 &e
->where
, &code
->expr3
->where
);
7444 /* Check F2008, C642. */
7445 if (code
->expr3
->ts
.type
== BT_DERIVED
7446 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7447 || (code
->expr3
->ts
.u
.derived
->from_intmod
7448 == INTMOD_ISO_FORTRAN_ENV
7449 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7450 == ISOFORTRAN_LOCK_TYPE
)))
7452 gfc_error ("The source-expr at %L shall neither be of type "
7453 "LOCK_TYPE nor have a LOCK_TYPE component if "
7454 "allocate-object at %L is a coarray",
7455 &code
->expr3
->where
, &e
->where
);
7459 /* Check TS18508, C702/C703. */
7460 if (code
->expr3
->ts
.type
== BT_DERIVED
7461 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7462 || (code
->expr3
->ts
.u
.derived
->from_intmod
7463 == INTMOD_ISO_FORTRAN_ENV
7464 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7465 == ISOFORTRAN_EVENT_TYPE
)))
7467 gfc_error ("The source-expr at %L shall neither be of type "
7468 "EVENT_TYPE nor have a EVENT_TYPE component if "
7469 "allocate-object at %L is a coarray",
7470 &code
->expr3
->where
, &e
->where
);
7475 /* Check F08:C629. */
7476 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7479 gcc_assert (e
->ts
.type
== BT_CLASS
);
7480 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7481 "type-spec or source-expr", sym
->name
, &e
->where
);
7485 /* Check F08:C632. */
7486 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7487 && !UNLIMITED_POLY (e
))
7491 if (!e
->ts
.u
.cl
->length
)
7494 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7495 code
->ext
.alloc
.ts
.u
.cl
->length
);
7496 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7498 gfc_error ("Allocating %s at %L with type-spec requires the same "
7499 "character-length parameter as in the declaration",
7500 sym
->name
, &e
->where
);
7505 /* In the variable definition context checks, gfc_expr_attr is used
7506 on the expression. This is fooled by the array specification
7507 present in e, thus we have to eliminate that one temporarily. */
7508 e2
= remove_last_array_ref (e
);
7511 t
= gfc_check_vardef_context (e2
, true, true, false,
7512 _("ALLOCATE object"));
7514 t
= gfc_check_vardef_context (e2
, false, true, false,
7515 _("ALLOCATE object"));
7520 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7521 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7523 /* For class arrays, the initialization with SOURCE is done
7524 using _copy and trans_call. It is convenient to exploit that
7525 when the allocated type is different from the declared type but
7526 no SOURCE exists by setting expr3. */
7527 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7529 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7530 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7531 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7533 /* We have to zero initialize the integer variable. */
7534 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7537 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7539 /* Make sure the vtab symbol is present when
7540 the module variables are generated. */
7541 gfc_typespec ts
= e
->ts
;
7543 ts
= code
->expr3
->ts
;
7544 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7545 ts
= code
->ext
.alloc
.ts
;
7547 /* Finding the vtab also publishes the type's symbol. Therefore this
7548 statement is necessary. */
7549 gfc_find_derived_vtab (ts
.u
.derived
);
7551 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7553 /* Again, make sure the vtab symbol is present when
7554 the module variables are generated. */
7555 gfc_typespec
*ts
= NULL
;
7557 ts
= &code
->expr3
->ts
;
7559 ts
= &code
->ext
.alloc
.ts
;
7563 /* Finding the vtab also publishes the type's symbol. Therefore this
7564 statement is necessary. */
7568 if (dimension
== 0 && codimension
== 0)
7571 /* Make sure the last reference node is an array specification. */
7573 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7574 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7579 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7580 "in ALLOCATE statement at %L", &e
->where
))
7582 if (code
->expr3
->rank
!= 0)
7583 *array_alloc_wo_spec
= true;
7586 gfc_error ("Array specification or array-valued SOURCE= "
7587 "expression required in ALLOCATE statement at %L",
7594 gfc_error ("Array specification required in ALLOCATE statement "
7595 "at %L", &e
->where
);
7600 /* Make sure that the array section reference makes sense in the
7601 context of an ALLOCATE specification. */
7606 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7607 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7609 gfc_error ("Coarray specification required in ALLOCATE statement "
7610 "at %L", &e
->where
);
7614 for (i
= 0; i
< ar
->dimen
; i
++)
7616 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7619 switch (ar
->dimen_type
[i
])
7625 if (ar
->start
[i
] != NULL
7626 && ar
->end
[i
] != NULL
7627 && ar
->stride
[i
] == NULL
)
7635 case DIMEN_THIS_IMAGE
:
7636 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7642 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7644 sym
= a
->expr
->symtree
->n
.sym
;
7646 /* TODO - check derived type components. */
7647 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7650 if ((ar
->start
[i
] != NULL
7651 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7652 || (ar
->end
[i
] != NULL
7653 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7655 gfc_error ("%qs must not appear in the array specification at "
7656 "%L in the same ALLOCATE statement where it is "
7657 "itself allocated", sym
->name
, &ar
->where
);
7663 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7665 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7666 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7668 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7670 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7671 "statement at %L", &e
->where
);
7677 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7678 && ar
->stride
[i
] == NULL
)
7681 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7695 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7697 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7698 gfc_alloc
*a
, *p
, *q
;
7701 errmsg
= code
->expr2
;
7703 /* Check the stat variable. */
7706 gfc_check_vardef_context (stat
, false, false, false,
7707 _("STAT variable"));
7709 if ((stat
->ts
.type
!= BT_INTEGER
7710 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7711 || stat
->ref
->type
== REF_COMPONENT
)))
7713 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7714 "variable", &stat
->where
);
7716 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7717 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7719 gfc_ref
*ref1
, *ref2
;
7722 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7723 ref1
= ref1
->next
, ref2
= ref2
->next
)
7725 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7727 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7736 gfc_error ("Stat-variable at %L shall not be %sd within "
7737 "the same %s statement", &stat
->where
, fcn
, fcn
);
7743 /* Check the errmsg variable. */
7747 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7750 gfc_check_vardef_context (errmsg
, false, false, false,
7751 _("ERRMSG variable"));
7753 if ((errmsg
->ts
.type
!= BT_CHARACTER
7755 && (errmsg
->ref
->type
== REF_ARRAY
7756 || errmsg
->ref
->type
== REF_COMPONENT
)))
7757 || errmsg
->rank
> 0 )
7758 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7759 "variable", &errmsg
->where
);
7761 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7762 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7764 gfc_ref
*ref1
, *ref2
;
7767 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7768 ref1
= ref1
->next
, ref2
= ref2
->next
)
7770 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7772 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7781 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7782 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7788 /* Check that an allocate-object appears only once in the statement. */
7790 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7793 for (q
= p
->next
; q
; q
= q
->next
)
7796 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7798 /* This is a potential collision. */
7799 gfc_ref
*pr
= pe
->ref
;
7800 gfc_ref
*qr
= qe
->ref
;
7802 /* Follow the references until
7803 a) They start to differ, in which case there is no error;
7804 you can deallocate a%b and a%c in a single statement
7805 b) Both of them stop, which is an error
7806 c) One of them stops, which is also an error. */
7809 if (pr
== NULL
&& qr
== NULL
)
7811 gfc_error ("Allocate-object at %L also appears at %L",
7812 &pe
->where
, &qe
->where
);
7815 else if (pr
!= NULL
&& qr
== NULL
)
7817 gfc_error ("Allocate-object at %L is subobject of"
7818 " object at %L", &pe
->where
, &qe
->where
);
7821 else if (pr
== NULL
&& qr
!= NULL
)
7823 gfc_error ("Allocate-object at %L is subobject of"
7824 " object at %L", &qe
->where
, &pe
->where
);
7827 /* Here, pr != NULL && qr != NULL */
7828 gcc_assert(pr
->type
== qr
->type
);
7829 if (pr
->type
== REF_ARRAY
)
7831 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7833 gcc_assert (qr
->type
== REF_ARRAY
);
7835 if (pr
->next
&& qr
->next
)
7838 gfc_array_ref
*par
= &(pr
->u
.ar
);
7839 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7841 for (i
=0; i
<par
->dimen
; i
++)
7843 if ((par
->start
[i
] != NULL
7844 || qar
->start
[i
] != NULL
)
7845 && gfc_dep_compare_expr (par
->start
[i
],
7846 qar
->start
[i
]) != 0)
7853 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7866 if (strcmp (fcn
, "ALLOCATE") == 0)
7868 bool arr_alloc_wo_spec
= false;
7870 /* Resolving the expr3 in the loop over all objects to allocate would
7871 execute loop invariant code for each loop item. Therefore do it just
7873 if (code
->expr3
&& code
->expr3
->mold
7874 && code
->expr3
->ts
.type
== BT_DERIVED
)
7876 /* Default initialization via MOLD (non-polymorphic). */
7877 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7880 gfc_resolve_expr (rhs
);
7881 gfc_free_expr (code
->expr3
);
7885 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7886 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7888 if (arr_alloc_wo_spec
&& code
->expr3
)
7890 /* Mark the allocate to have to take the array specification
7892 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7897 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7898 resolve_deallocate_expr (a
->expr
);
7903 /************ SELECT CASE resolution subroutines ************/
7905 /* Callback function for our mergesort variant. Determines interval
7906 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7907 op1 > op2. Assumes we're not dealing with the default case.
7908 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7909 There are nine situations to check. */
7912 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7916 if (op1
->low
== NULL
) /* op1 = (:L) */
7918 /* op2 = (:N), so overlap. */
7920 /* op2 = (M:) or (M:N), L < M */
7921 if (op2
->low
!= NULL
7922 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7925 else if (op1
->high
== NULL
) /* op1 = (K:) */
7927 /* op2 = (M:), so overlap. */
7929 /* op2 = (:N) or (M:N), K > N */
7930 if (op2
->high
!= NULL
7931 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7934 else /* op1 = (K:L) */
7936 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7937 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7939 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7940 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7942 else /* op2 = (M:N) */
7946 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7949 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7958 /* Merge-sort a double linked case list, detecting overlap in the
7959 process. LIST is the head of the double linked case list before it
7960 is sorted. Returns the head of the sorted list if we don't see any
7961 overlap, or NULL otherwise. */
7964 check_case_overlap (gfc_case
*list
)
7966 gfc_case
*p
, *q
, *e
, *tail
;
7967 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7969 /* If the passed list was empty, return immediately. */
7976 /* Loop unconditionally. The only exit from this loop is a return
7977 statement, when we've finished sorting the case list. */
7984 /* Count the number of merges we do in this pass. */
7987 /* Loop while there exists a merge to be done. */
7992 /* Count this merge. */
7995 /* Cut the list in two pieces by stepping INSIZE places
7996 forward in the list, starting from P. */
7999 for (i
= 0; i
< insize
; i
++)
8008 /* Now we have two lists. Merge them! */
8009 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8011 /* See from which the next case to merge comes from. */
8014 /* P is empty so the next case must come from Q. */
8019 else if (qsize
== 0 || q
== NULL
)
8028 cmp
= compare_cases (p
, q
);
8031 /* The whole case range for P is less than the
8039 /* The whole case range for Q is greater than
8040 the case range for P. */
8047 /* The cases overlap, or they are the same
8048 element in the list. Either way, we must
8049 issue an error and get the next case from P. */
8050 /* FIXME: Sort P and Q by line number. */
8051 gfc_error ("CASE label at %L overlaps with CASE "
8052 "label at %L", &p
->where
, &q
->where
);
8060 /* Add the next element to the merged list. */
8069 /* P has now stepped INSIZE places along, and so has Q. So
8070 they're the same. */
8075 /* If we have done only one merge or none at all, we've
8076 finished sorting the cases. */
8085 /* Otherwise repeat, merging lists twice the size. */
8091 /* Check to see if an expression is suitable for use in a CASE statement.
8092 Makes sure that all case expressions are scalar constants of the same
8093 type. Return false if anything is wrong. */
8096 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8098 if (e
== NULL
) return true;
8100 if (e
->ts
.type
!= case_expr
->ts
.type
)
8102 gfc_error ("Expression in CASE statement at %L must be of type %s",
8103 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8107 /* C805 (R808) For a given case-construct, each case-value shall be of
8108 the same type as case-expr. For character type, length differences
8109 are allowed, but the kind type parameters shall be the same. */
8111 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8113 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8114 &e
->where
, case_expr
->ts
.kind
);
8118 /* Convert the case value kind to that of case expression kind,
8121 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8122 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8126 gfc_error ("Expression in CASE statement at %L must be scalar",
8135 /* Given a completely parsed select statement, we:
8137 - Validate all expressions and code within the SELECT.
8138 - Make sure that the selection expression is not of the wrong type.
8139 - Make sure that no case ranges overlap.
8140 - Eliminate unreachable cases and unreachable code resulting from
8141 removing case labels.
8143 The standard does allow unreachable cases, e.g. CASE (5:3). But
8144 they are a hassle for code generation, and to prevent that, we just
8145 cut them out here. This is not necessary for overlapping cases
8146 because they are illegal and we never even try to generate code.
8148 We have the additional caveat that a SELECT construct could have
8149 been a computed GOTO in the source code. Fortunately we can fairly
8150 easily work around that here: The case_expr for a "real" SELECT CASE
8151 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8152 we have to do is make sure that the case_expr is a scalar integer
8156 resolve_select (gfc_code
*code
, bool select_type
)
8159 gfc_expr
*case_expr
;
8160 gfc_case
*cp
, *default_case
, *tail
, *head
;
8161 int seen_unreachable
;
8167 if (code
->expr1
== NULL
)
8169 /* This was actually a computed GOTO statement. */
8170 case_expr
= code
->expr2
;
8171 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8172 gfc_error ("Selection expression in computed GOTO statement "
8173 "at %L must be a scalar integer expression",
8176 /* Further checking is not necessary because this SELECT was built
8177 by the compiler, so it should always be OK. Just move the
8178 case_expr from expr2 to expr so that we can handle computed
8179 GOTOs as normal SELECTs from here on. */
8180 code
->expr1
= code
->expr2
;
8185 case_expr
= code
->expr1
;
8186 type
= case_expr
->ts
.type
;
8189 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8191 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8192 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8194 /* Punt. Going on here just produce more garbage error messages. */
8199 if (!select_type
&& case_expr
->rank
!= 0)
8201 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8202 "expression", &case_expr
->where
);
8208 /* Raise a warning if an INTEGER case value exceeds the range of
8209 the case-expr. Later, all expressions will be promoted to the
8210 largest kind of all case-labels. */
8212 if (type
== BT_INTEGER
)
8213 for (body
= code
->block
; body
; body
= body
->block
)
8214 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8217 && gfc_check_integer_range (cp
->low
->value
.integer
,
8218 case_expr
->ts
.kind
) != ARITH_OK
)
8219 gfc_warning (0, "Expression in CASE statement at %L is "
8220 "not in the range of %s", &cp
->low
->where
,
8221 gfc_typename (&case_expr
->ts
));
8224 && cp
->low
!= cp
->high
8225 && gfc_check_integer_range (cp
->high
->value
.integer
,
8226 case_expr
->ts
.kind
) != ARITH_OK
)
8227 gfc_warning (0, "Expression in CASE statement at %L is "
8228 "not in the range of %s", &cp
->high
->where
,
8229 gfc_typename (&case_expr
->ts
));
8232 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8233 of the SELECT CASE expression and its CASE values. Walk the lists
8234 of case values, and if we find a mismatch, promote case_expr to
8235 the appropriate kind. */
8237 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8239 for (body
= code
->block
; body
; body
= body
->block
)
8241 /* Walk the case label list. */
8242 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8244 /* Intercept the DEFAULT case. It does not have a kind. */
8245 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8248 /* Unreachable case ranges are discarded, so ignore. */
8249 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8250 && cp
->low
!= cp
->high
8251 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8255 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8256 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8258 if (cp
->high
!= NULL
8259 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8260 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8265 /* Assume there is no DEFAULT case. */
8266 default_case
= NULL
;
8271 for (body
= code
->block
; body
; body
= body
->block
)
8273 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8275 seen_unreachable
= 0;
8277 /* Walk the case label list, making sure that all case labels
8279 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8281 /* Count the number of cases in the whole construct. */
8284 /* Intercept the DEFAULT case. */
8285 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8287 if (default_case
!= NULL
)
8289 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8290 "by a second DEFAULT CASE at %L",
8291 &default_case
->where
, &cp
->where
);
8302 /* Deal with single value cases and case ranges. Errors are
8303 issued from the validation function. */
8304 if (!validate_case_label_expr (cp
->low
, case_expr
)
8305 || !validate_case_label_expr (cp
->high
, case_expr
))
8311 if (type
== BT_LOGICAL
8312 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8313 || cp
->low
!= cp
->high
))
8315 gfc_error ("Logical range in CASE statement at %L is not "
8316 "allowed", &cp
->low
->where
);
8321 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8324 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8325 if (value
& seen_logical
)
8327 gfc_error ("Constant logical value in CASE statement "
8328 "is repeated at %L",
8333 seen_logical
|= value
;
8336 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8337 && cp
->low
!= cp
->high
8338 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8340 if (warn_surprising
)
8341 gfc_warning (OPT_Wsurprising
,
8342 "Range specification at %L can never be matched",
8345 cp
->unreachable
= 1;
8346 seen_unreachable
= 1;
8350 /* If the case range can be matched, it can also overlap with
8351 other cases. To make sure it does not, we put it in a
8352 double linked list here. We sort that with a merge sort
8353 later on to detect any overlapping cases. */
8357 head
->right
= head
->left
= NULL
;
8362 tail
->right
->left
= tail
;
8369 /* It there was a failure in the previous case label, give up
8370 for this case label list. Continue with the next block. */
8374 /* See if any case labels that are unreachable have been seen.
8375 If so, we eliminate them. This is a bit of a kludge because
8376 the case lists for a single case statement (label) is a
8377 single forward linked lists. */
8378 if (seen_unreachable
)
8380 /* Advance until the first case in the list is reachable. */
8381 while (body
->ext
.block
.case_list
!= NULL
8382 && body
->ext
.block
.case_list
->unreachable
)
8384 gfc_case
*n
= body
->ext
.block
.case_list
;
8385 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8387 gfc_free_case_list (n
);
8390 /* Strip all other unreachable cases. */
8391 if (body
->ext
.block
.case_list
)
8393 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8395 if (cp
->next
->unreachable
)
8397 gfc_case
*n
= cp
->next
;
8398 cp
->next
= cp
->next
->next
;
8400 gfc_free_case_list (n
);
8407 /* See if there were overlapping cases. If the check returns NULL,
8408 there was overlap. In that case we don't do anything. If head
8409 is non-NULL, we prepend the DEFAULT case. The sorted list can
8410 then used during code generation for SELECT CASE constructs with
8411 a case expression of a CHARACTER type. */
8414 head
= check_case_overlap (head
);
8416 /* Prepend the default_case if it is there. */
8417 if (head
!= NULL
&& default_case
)
8419 default_case
->left
= NULL
;
8420 default_case
->right
= head
;
8421 head
->left
= default_case
;
8425 /* Eliminate dead blocks that may be the result if we've seen
8426 unreachable case labels for a block. */
8427 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8429 if (body
->block
->ext
.block
.case_list
== NULL
)
8431 /* Cut the unreachable block from the code chain. */
8432 gfc_code
*c
= body
->block
;
8433 body
->block
= c
->block
;
8435 /* Kill the dead block, but not the blocks below it. */
8437 gfc_free_statements (c
);
8441 /* More than two cases is legal but insane for logical selects.
8442 Issue a warning for it. */
8443 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8444 gfc_warning (OPT_Wsurprising
,
8445 "Logical SELECT CASE block at %L has more that two cases",
8450 /* Check if a derived type is extensible. */
8453 gfc_type_is_extensible (gfc_symbol
*sym
)
8455 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8456 || (sym
->attr
.is_class
8457 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8462 resolve_types (gfc_namespace
*ns
);
8464 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8465 correct as well as possibly the array-spec. */
8468 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8472 gcc_assert (sym
->assoc
);
8473 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8475 /* If this is for SELECT TYPE, the target may not yet be set. In that
8476 case, return. Resolution will be called later manually again when
8478 target
= sym
->assoc
->target
;
8481 gcc_assert (!sym
->assoc
->dangling
);
8483 if (resolve_target
&& !gfc_resolve_expr (target
))
8486 /* For variable targets, we get some attributes from the target. */
8487 if (target
->expr_type
== EXPR_VARIABLE
)
8491 gcc_assert (target
->symtree
);
8492 tsym
= target
->symtree
->n
.sym
;
8494 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8495 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8497 sym
->attr
.target
= tsym
->attr
.target
8498 || gfc_expr_attr (target
).pointer
;
8499 if (is_subref_array (target
))
8500 sym
->attr
.subref_array_pointer
= 1;
8503 if (target
->expr_type
== EXPR_NULL
)
8505 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8508 else if (target
->ts
.type
== BT_UNKNOWN
)
8510 gfc_error ("Selector at %L has no type", &target
->where
);
8514 /* Get type if this was not already set. Note that it can be
8515 some other type than the target in case this is a SELECT TYPE
8516 selector! So we must not update when the type is already there. */
8517 if (sym
->ts
.type
== BT_UNKNOWN
)
8518 sym
->ts
= target
->ts
;
8520 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8522 /* See if this is a valid association-to-variable. */
8523 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8524 && !gfc_has_vector_subscript (target
));
8526 /* Finally resolve if this is an array or not. */
8527 if (sym
->attr
.dimension
&& target
->rank
== 0)
8529 /* primary.c makes the assumption that a reference to an associate
8530 name followed by a left parenthesis is an array reference. */
8531 if (sym
->ts
.type
!= BT_CHARACTER
)
8532 gfc_error ("Associate-name %qs at %L is used as array",
8533 sym
->name
, &sym
->declared_at
);
8534 sym
->attr
.dimension
= 0;
8539 /* We cannot deal with class selectors that need temporaries. */
8540 if (target
->ts
.type
== BT_CLASS
8541 && gfc_ref_needs_temporary_p (target
->ref
))
8543 gfc_error ("CLASS selector at %L needs a temporary which is not "
8544 "yet implemented", &target
->where
);
8548 if (target
->ts
.type
== BT_CLASS
)
8549 gfc_fix_class_refs (target
);
8551 if (target
->rank
!= 0)
8554 /* The rank may be incorrectly guessed at parsing, therefore make sure
8555 it is corrected now. */
8556 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8559 sym
->as
= gfc_get_array_spec ();
8561 as
->rank
= target
->rank
;
8562 as
->type
= AS_DEFERRED
;
8563 as
->corank
= gfc_get_corank (target
);
8564 sym
->attr
.dimension
= 1;
8565 if (as
->corank
!= 0)
8566 sym
->attr
.codimension
= 1;
8571 /* target's rank is 0, but the type of the sym is still array valued,
8572 which has to be corrected. */
8573 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8576 symbol_attribute attr
;
8577 /* The associated variable's type is still the array type
8578 correct this now. */
8579 gfc_typespec
*ts
= &target
->ts
;
8582 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8587 ts
= &ref
->u
.c
.component
->ts
;
8590 if (ts
->type
== BT_CLASS
)
8591 ts
= &ts
->u
.derived
->components
->ts
;
8597 /* Create a scalar instance of the current class type. Because the
8598 rank of a class array goes into its name, the type has to be
8599 rebuild. The alternative of (re-)setting just the attributes
8600 and as in the current type, destroys the type also in other
8604 sym
->ts
.type
= BT_CLASS
;
8605 attr
= CLASS_DATA (sym
)->attr
;
8607 attr
.associate_var
= 1;
8608 attr
.dimension
= attr
.codimension
= 0;
8609 attr
.class_pointer
= 1;
8610 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8612 /* Make sure the _vptr is set. */
8613 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8614 if (c
->ts
.u
.derived
== NULL
)
8615 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8616 CLASS_DATA (sym
)->attr
.pointer
= 1;
8617 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8618 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8619 gfc_commit_symbol (sym
->ts
.u
.derived
);
8620 /* _vptr now has the _vtab in it, change it to the _vtype. */
8621 if (c
->ts
.u
.derived
->attr
.vtab
)
8622 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8623 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8624 resolve_types (c
->ts
.u
.derived
->ns
);
8628 /* Mark this as an associate variable. */
8629 sym
->attr
.associate_var
= 1;
8631 /* Fix up the type-spec for CHARACTER types. */
8632 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8635 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8637 if (!sym
->ts
.u
.cl
->length
&& !sym
->ts
.deferred
8638 && target
->expr_type
== EXPR_CONSTANT
)
8639 sym
->ts
.u
.cl
->length
8640 = gfc_get_int_expr (gfc_charlen_int_kind
,
8641 NULL
, target
->value
.character
.length
);
8644 /* If the target is a good class object, so is the associate variable. */
8645 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8646 sym
->attr
.class_ok
= 1;
8650 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8651 array reference, where necessary. The symbols are artificial and so
8652 the dimension attribute and arrayspec can also be set. In addition,
8653 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8654 This is corrected here as well.*/
8657 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8658 int rank
, gfc_ref
*ref
)
8660 gfc_ref
*nref
= (*expr1
)->ref
;
8661 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8662 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8663 (*expr1
)->rank
= rank
;
8664 if (sym1
->ts
.type
== BT_CLASS
)
8666 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8667 (*expr1
)->ts
= sym1
->ts
;
8669 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8670 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8671 CLASS_DATA (sym1
)->as
8672 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8676 sym1
->attr
.dimension
= 1;
8677 if (sym1
->as
== NULL
&& sym2
)
8678 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8681 for (; nref
; nref
= nref
->next
)
8682 if (nref
->next
== NULL
)
8685 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8686 nref
->next
= gfc_copy_ref (ref
);
8687 else if (ref
&& !nref
)
8688 (*expr1
)->ref
= gfc_copy_ref (ref
);
8693 build_loc_call (gfc_expr
*sym_expr
)
8696 loc_call
= gfc_get_expr ();
8697 loc_call
->expr_type
= EXPR_FUNCTION
;
8698 gfc_get_sym_tree ("loc", gfc_current_ns
, &loc_call
->symtree
, false);
8699 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8700 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8701 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8702 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8703 loc_call
->ts
.type
= BT_INTEGER
;
8704 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8705 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8706 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8707 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8708 loc_call
->where
= sym_expr
->where
;
8712 /* Resolve a SELECT TYPE statement. */
8715 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8717 gfc_symbol
*selector_type
;
8718 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8719 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8722 char name
[GFC_MAX_SYMBOL_LEN
];
8726 gfc_ref
* ref
= NULL
;
8727 gfc_expr
*selector_expr
= NULL
;
8729 ns
= code
->ext
.block
.ns
;
8732 /* Check for F03:C813. */
8733 if (code
->expr1
->ts
.type
!= BT_CLASS
8734 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8736 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8737 "at %L", &code
->loc
);
8741 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8746 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8747 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8748 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8750 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
8751 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
8753 /* F2008: C803 The selector expression must not be coindexed. */
8754 if (gfc_is_coindexed (code
->expr2
))
8756 gfc_error ("Selector at %L must not be coindexed",
8757 &code
->expr2
->where
);
8764 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8766 if (gfc_is_coindexed (code
->expr1
))
8768 gfc_error ("Selector at %L must not be coindexed",
8769 &code
->expr1
->where
);
8774 /* Loop over TYPE IS / CLASS IS cases. */
8775 for (body
= code
->block
; body
; body
= body
->block
)
8777 c
= body
->ext
.block
.case_list
;
8781 /* Check for repeated cases. */
8782 for (tail
= code
->block
; tail
; tail
= tail
->block
)
8784 gfc_case
*d
= tail
->ext
.block
.case_list
;
8788 if (c
->ts
.type
== d
->ts
.type
8789 && ((c
->ts
.type
== BT_DERIVED
8790 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
8791 && !strcmp (c
->ts
.u
.derived
->name
,
8792 d
->ts
.u
.derived
->name
))
8793 || c
->ts
.type
== BT_UNKNOWN
8794 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8795 && c
->ts
.kind
== d
->ts
.kind
)))
8797 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8798 &c
->where
, &d
->where
);
8804 /* Check F03:C815. */
8805 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8806 && !selector_type
->attr
.unlimited_polymorphic
8807 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8809 gfc_error ("Derived type %qs at %L must be extensible",
8810 c
->ts
.u
.derived
->name
, &c
->where
);
8815 /* Check F03:C816. */
8816 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8817 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8818 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8820 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8821 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8822 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8824 gfc_error ("Unexpected intrinsic type %qs at %L",
8825 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8830 /* Check F03:C814. */
8831 if (c
->ts
.type
== BT_CHARACTER
8832 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
8834 gfc_error ("The type-spec at %L shall specify that each length "
8835 "type parameter is assumed", &c
->where
);
8840 /* Intercept the DEFAULT case. */
8841 if (c
->ts
.type
== BT_UNKNOWN
)
8843 /* Check F03:C818. */
8846 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8847 "by a second DEFAULT CASE at %L",
8848 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8853 default_case
= body
;
8860 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8861 target if present. If there are any EXIT statements referring to the
8862 SELECT TYPE construct, this is no problem because the gfc_code
8863 reference stays the same and EXIT is equally possible from the BLOCK
8864 it is changed to. */
8865 code
->op
= EXEC_BLOCK
;
8868 gfc_association_list
* assoc
;
8870 assoc
= gfc_get_association_list ();
8871 assoc
->st
= code
->expr1
->symtree
;
8872 assoc
->target
= gfc_copy_expr (code
->expr2
);
8873 assoc
->target
->where
= code
->expr2
->where
;
8874 /* assoc->variable will be set by resolve_assoc_var. */
8876 code
->ext
.block
.assoc
= assoc
;
8877 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8879 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8882 code
->ext
.block
.assoc
= NULL
;
8884 /* Ensure that the selector rank and arrayspec are available to
8885 correct expressions in which they might be missing. */
8886 if (code
->expr2
&& code
->expr2
->rank
)
8888 rank
= code
->expr2
->rank
;
8889 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
8890 if (ref
->next
== NULL
)
8892 if (ref
&& ref
->type
== REF_ARRAY
)
8893 ref
= gfc_copy_ref (ref
);
8895 /* Fixup expr1 if necessary. */
8897 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
8899 else if (code
->expr1
->rank
)
8901 rank
= code
->expr1
->rank
;
8902 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
8903 if (ref
->next
== NULL
)
8905 if (ref
&& ref
->type
== REF_ARRAY
)
8906 ref
= gfc_copy_ref (ref
);
8909 /* Add EXEC_SELECT to switch on type. */
8910 new_st
= gfc_get_code (code
->op
);
8911 new_st
->expr1
= code
->expr1
;
8912 new_st
->expr2
= code
->expr2
;
8913 new_st
->block
= code
->block
;
8914 code
->expr1
= code
->expr2
= NULL
;
8919 ns
->code
->next
= new_st
;
8921 code
->op
= EXEC_SELECT_TYPE
;
8923 /* Use the intrinsic LOC function to generate an integer expression
8924 for the vtable of the selector. Note that the rank of the selector
8925 expression has to be set to zero. */
8926 gfc_add_vptr_component (code
->expr1
);
8927 code
->expr1
->rank
= 0;
8928 code
->expr1
= build_loc_call (code
->expr1
);
8929 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
8931 /* Loop over TYPE IS / CLASS IS cases. */
8932 for (body
= code
->block
; body
; body
= body
->block
)
8936 c
= body
->ext
.block
.case_list
;
8938 /* Generate an index integer expression for address of the
8939 TYPE/CLASS vtable and store it in c->low. The hash expression
8940 is stored in c->high and is used to resolve intrinsic cases. */
8941 if (c
->ts
.type
!= BT_UNKNOWN
)
8943 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8945 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8947 c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8948 c
->ts
.u
.derived
->hash_value
);
8952 vtab
= gfc_find_vtab (&c
->ts
);
8953 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
8954 e
= CLASS_DATA (vtab
)->initializer
;
8955 c
->high
= gfc_copy_expr (e
);
8958 e
= gfc_lval_expr_from_sym (vtab
);
8959 c
->low
= build_loc_call (e
);
8964 /* Associate temporary to selector. This should only be done
8965 when this case is actually true, so build a new ASSOCIATE
8966 that does precisely this here (instead of using the
8969 if (c
->ts
.type
== BT_CLASS
)
8970 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8971 else if (c
->ts
.type
== BT_DERIVED
)
8972 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8973 else if (c
->ts
.type
== BT_CHARACTER
)
8975 HOST_WIDE_INT charlen
= 0;
8976 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8977 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8978 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
8979 snprintf (name
, sizeof (name
),
8980 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
8981 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
8984 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8987 st
= gfc_find_symtree (ns
->sym_root
, name
);
8988 gcc_assert (st
->n
.sym
->assoc
);
8989 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
8990 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
8991 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8993 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8994 /* Fixup the target expression if necessary. */
8996 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
8999 new_st
= gfc_get_code (EXEC_BLOCK
);
9000 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9001 new_st
->ext
.block
.ns
->code
= body
->next
;
9002 body
->next
= new_st
;
9004 /* Chain in the new list only if it is marked as dangling. Otherwise
9005 there is a CASE label overlap and this is already used. Just ignore,
9006 the error is diagnosed elsewhere. */
9007 if (st
->n
.sym
->assoc
->dangling
)
9009 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9010 st
->n
.sym
->assoc
->dangling
= 0;
9013 resolve_assoc_var (st
->n
.sym
, false);
9016 /* Take out CLASS IS cases for separate treatment. */
9018 while (body
&& body
->block
)
9020 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9022 /* Add to class_is list. */
9023 if (class_is
== NULL
)
9025 class_is
= body
->block
;
9030 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9031 tail
->block
= body
->block
;
9034 /* Remove from EXEC_SELECT list. */
9035 body
->block
= body
->block
->block
;
9048 /* Add a default case to hold the CLASS IS cases. */
9049 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9050 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9052 tail
->ext
.block
.case_list
= gfc_get_case ();
9053 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9055 default_case
= tail
;
9058 /* More than one CLASS IS block? */
9059 if (class_is
->block
)
9063 /* Sort CLASS IS blocks by extension level. */
9067 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9070 /* F03:C817 (check for doubles). */
9071 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9072 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9074 gfc_error ("Double CLASS IS block in SELECT TYPE "
9076 &c2
->ext
.block
.case_list
->where
);
9079 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9080 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9083 (*c1
)->block
= c2
->block
;
9093 /* Generate IF chain. */
9094 if_st
= gfc_get_code (EXEC_IF
);
9096 for (body
= class_is
; body
; body
= body
->block
)
9098 new_st
->block
= gfc_get_code (EXEC_IF
);
9099 new_st
= new_st
->block
;
9100 /* Set up IF condition: Call _gfortran_is_extension_of. */
9101 new_st
->expr1
= gfc_get_expr ();
9102 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9103 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9104 new_st
->expr1
->ts
.kind
= 4;
9105 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9106 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9107 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9108 /* Set up arguments. */
9109 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9110 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9111 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9112 new_st
->expr1
->where
= code
->loc
;
9113 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9114 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9115 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9116 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9117 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9118 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9119 new_st
->next
= body
->next
;
9121 if (default_case
->next
)
9123 new_st
->block
= gfc_get_code (EXEC_IF
);
9124 new_st
= new_st
->block
;
9125 new_st
->next
= default_case
->next
;
9128 /* Replace CLASS DEFAULT code by the IF chain. */
9129 default_case
->next
= if_st
;
9132 /* Resolve the internal code. This can not be done earlier because
9133 it requires that the sym->assoc of selectors is set already. */
9134 gfc_current_ns
= ns
;
9135 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9136 gfc_current_ns
= old_ns
;
9143 /* Resolve a transfer statement. This is making sure that:
9144 -- a derived type being transferred has only non-pointer components
9145 -- a derived type being transferred doesn't have private components, unless
9146 it's being transferred from the module where the type was defined
9147 -- we're not trying to transfer a whole assumed size array. */
9150 resolve_transfer (gfc_code
*code
)
9153 gfc_symbol
*sym
, *derived
;
9157 bool formatted
= false;
9158 gfc_dt
*dt
= code
->ext
.dt
;
9159 gfc_symbol
*dtio_sub
= NULL
;
9163 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9164 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9165 exp
= exp
->value
.op
.op1
;
9167 if (exp
&& exp
->expr_type
== EXPR_NULL
9170 gfc_error ("Invalid context for NULL () intrinsic at %L",
9175 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9176 && exp
->expr_type
!= EXPR_FUNCTION
9177 && exp
->expr_type
!= EXPR_STRUCTURE
))
9180 /* If we are reading, the variable will be changed. Note that
9181 code->ext.dt may be NULL if the TRANSFER is related to
9182 an INQUIRE statement -- but in this case, we are not reading, either. */
9183 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9184 && !gfc_check_vardef_context (exp
, false, false, false,
9188 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9190 /* Go to actual component transferred. */
9191 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9192 if (ref
->type
== REF_COMPONENT
)
9193 ts
= &ref
->u
.c
.component
->ts
;
9195 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9196 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9198 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
9199 derived
= ts
->u
.derived
;
9201 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
9203 /* Determine when to use the formatted DTIO procedure. */
9204 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9207 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9208 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9209 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9211 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9214 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9215 /* Check to see if this is a nested DTIO call, with the
9216 dummy as the io-list object. */
9217 if (sym
&& sym
== dtio_sub
&& sym
->formal
9218 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9219 && exp
->ref
== NULL
)
9221 if (!sym
->attr
.recursive
)
9223 gfc_error ("DTIO %s procedure at %L must be recursive",
9224 sym
->name
, &sym
->declared_at
);
9231 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9233 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9234 "it is processed by a defined input/output procedure",
9239 if (ts
->type
== BT_DERIVED
)
9241 /* Check that transferred derived type doesn't contain POINTER
9242 components unless it is processed by a defined input/output
9244 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9246 gfc_error ("Data transfer element at %L cannot have POINTER "
9247 "components unless it is processed by a defined "
9248 "input/output procedure", &code
->loc
);
9253 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9255 gfc_error ("Data transfer element at %L cannot have "
9256 "procedure pointer components", &code
->loc
);
9260 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9262 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9263 "components unless it is processed by a defined "
9264 "input/output procedure", &code
->loc
);
9268 /* C_PTR and C_FUNPTR have private components which means they can not
9269 be printed. However, if -std=gnu and not -pedantic, allow
9270 the component to be printed to help debugging. */
9271 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9273 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9274 "cannot have PRIVATE components", &code
->loc
))
9277 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9279 gfc_error ("Data transfer element at %L cannot have "
9280 "PRIVATE components unless it is processed by "
9281 "a defined input/output procedure", &code
->loc
);
9286 if (exp
->expr_type
== EXPR_STRUCTURE
)
9289 sym
= exp
->symtree
->n
.sym
;
9291 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9292 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9294 gfc_error ("Data transfer element at %L cannot be a full reference to "
9295 "an assumed-size array", &code
->loc
);
9299 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9300 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9304 /*********** Toplevel code resolution subroutines ***********/
9306 /* Find the set of labels that are reachable from this block. We also
9307 record the last statement in each block. */
9310 find_reachable_labels (gfc_code
*block
)
9317 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9319 /* Collect labels in this block. We don't keep those corresponding
9320 to END {IF|SELECT}, these are checked in resolve_branch by going
9321 up through the code_stack. */
9322 for (c
= block
; c
; c
= c
->next
)
9324 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9325 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9328 /* Merge with labels from parent block. */
9331 gcc_assert (cs_base
->prev
->reachable_labels
);
9332 bitmap_ior_into (cs_base
->reachable_labels
,
9333 cs_base
->prev
->reachable_labels
);
9339 resolve_lock_unlock_event (gfc_code
*code
)
9341 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9342 && code
->expr1
->value
.function
.isym
9343 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9344 remove_caf_get_intrinsic (code
->expr1
);
9346 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9347 && (code
->expr1
->ts
.type
!= BT_DERIVED
9348 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9349 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9350 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9351 || code
->expr1
->rank
!= 0
9352 || (!gfc_is_coarray (code
->expr1
) &&
9353 !gfc_is_coindexed (code
->expr1
))))
9354 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9355 &code
->expr1
->where
);
9356 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9357 && (code
->expr1
->ts
.type
!= BT_DERIVED
9358 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9359 || code
->expr1
->ts
.u
.derived
->from_intmod
9360 != INTMOD_ISO_FORTRAN_ENV
9361 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9362 != ISOFORTRAN_EVENT_TYPE
9363 || code
->expr1
->rank
!= 0))
9364 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9365 &code
->expr1
->where
);
9366 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9367 && !gfc_is_coindexed (code
->expr1
))
9368 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9369 &code
->expr1
->where
);
9370 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9371 gfc_error ("Event variable argument at %L must be a coarray but not "
9372 "coindexed", &code
->expr1
->where
);
9376 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9377 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9378 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9379 &code
->expr2
->where
);
9382 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9383 _("STAT variable")))
9388 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9389 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9390 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9391 &code
->expr3
->where
);
9394 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9395 _("ERRMSG variable")))
9398 /* Check for LOCK the ACQUIRED_LOCK. */
9399 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9400 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9401 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9402 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9403 "variable", &code
->expr4
->where
);
9405 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9406 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9407 _("ACQUIRED_LOCK variable")))
9410 /* Check for EVENT WAIT the UNTIL_COUNT. */
9411 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9413 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9414 || code
->expr4
->rank
!= 0)
9415 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9416 "expression", &code
->expr4
->where
);
9422 resolve_critical (gfc_code
*code
)
9424 gfc_symtree
*symtree
;
9425 gfc_symbol
*lock_type
;
9426 char name
[GFC_MAX_SYMBOL_LEN
];
9427 static int serial
= 0;
9429 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9432 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9433 GFC_PREFIX ("lock_type"));
9435 lock_type
= symtree
->n
.sym
;
9438 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9441 lock_type
= symtree
->n
.sym
;
9442 lock_type
->attr
.flavor
= FL_DERIVED
;
9443 lock_type
->attr
.zero_comp
= 1;
9444 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9445 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9448 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9449 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9452 code
->resolved_sym
= symtree
->n
.sym
;
9453 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9454 symtree
->n
.sym
->attr
.referenced
= 1;
9455 symtree
->n
.sym
->attr
.artificial
= 1;
9456 symtree
->n
.sym
->attr
.codimension
= 1;
9457 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9458 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9459 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9460 symtree
->n
.sym
->as
->corank
= 1;
9461 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9462 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9463 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9465 gfc_commit_symbols();
9470 resolve_sync (gfc_code
*code
)
9472 /* Check imageset. The * case matches expr1 == NULL. */
9475 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9476 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9477 "INTEGER expression", &code
->expr1
->where
);
9478 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9479 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9480 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9481 &code
->expr1
->where
);
9482 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9483 && gfc_simplify_expr (code
->expr1
, 0))
9485 gfc_constructor
*cons
;
9486 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9487 for (; cons
; cons
= gfc_constructor_next (cons
))
9488 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9489 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9490 gfc_error ("Imageset argument at %L must between 1 and "
9491 "num_images()", &cons
->expr
->where
);
9497 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9498 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9499 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9500 &code
->expr2
->where
);
9504 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9505 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9506 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9507 &code
->expr3
->where
);
9511 /* Given a branch to a label, see if the branch is conforming.
9512 The code node describes where the branch is located. */
9515 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9522 /* Step one: is this a valid branching target? */
9524 if (label
->defined
== ST_LABEL_UNKNOWN
)
9526 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9531 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9533 gfc_error ("Statement at %L is not a valid branch target statement "
9534 "for the branch statement at %L", &label
->where
, &code
->loc
);
9538 /* Step two: make sure this branch is not a branch to itself ;-) */
9540 if (code
->here
== label
)
9543 "Branch at %L may result in an infinite loop", &code
->loc
);
9547 /* Step three: See if the label is in the same block as the
9548 branching statement. The hard work has been done by setting up
9549 the bitmap reachable_labels. */
9551 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9553 /* Check now whether there is a CRITICAL construct; if so, check
9554 whether the label is still visible outside of the CRITICAL block,
9555 which is invalid. */
9556 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9558 if (stack
->current
->op
== EXEC_CRITICAL
9559 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9560 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9561 "label at %L", &code
->loc
, &label
->where
);
9562 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9563 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9564 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9565 "for label at %L", &code
->loc
, &label
->where
);
9571 /* Step four: If we haven't found the label in the bitmap, it may
9572 still be the label of the END of the enclosing block, in which
9573 case we find it by going up the code_stack. */
9575 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9577 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9579 if (stack
->current
->op
== EXEC_CRITICAL
)
9581 /* Note: A label at END CRITICAL does not leave the CRITICAL
9582 construct as END CRITICAL is still part of it. */
9583 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9584 " at %L", &code
->loc
, &label
->where
);
9587 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9589 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9590 "label at %L", &code
->loc
, &label
->where
);
9597 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9601 /* The label is not in an enclosing block, so illegal. This was
9602 allowed in Fortran 66, so we allow it as extension. No
9603 further checks are necessary in this case. */
9604 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9605 "as the GOTO statement at %L", &label
->where
,
9611 /* Check whether EXPR1 has the same shape as EXPR2. */
9614 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9616 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9617 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9618 bool result
= false;
9621 /* Compare the rank. */
9622 if (expr1
->rank
!= expr2
->rank
)
9625 /* Compare the size of each dimension. */
9626 for (i
=0; i
<expr1
->rank
; i
++)
9628 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9631 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9634 if (mpz_cmp (shape
[i
], shape2
[i
]))
9638 /* When either of the two expression is an assumed size array, we
9639 ignore the comparison of dimension sizes. */
9644 gfc_clear_shape (shape
, i
);
9645 gfc_clear_shape (shape2
, i
);
9650 /* Check whether a WHERE assignment target or a WHERE mask expression
9651 has the same shape as the outmost WHERE mask expression. */
9654 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9660 cblock
= code
->block
;
9662 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9663 In case of nested WHERE, only the outmost one is stored. */
9664 if (mask
== NULL
) /* outmost WHERE */
9666 else /* inner WHERE */
9673 /* Check if the mask-expr has a consistent shape with the
9674 outmost WHERE mask-expr. */
9675 if (!resolve_where_shape (cblock
->expr1
, e
))
9676 gfc_error ("WHERE mask at %L has inconsistent shape",
9677 &cblock
->expr1
->where
);
9680 /* the assignment statement of a WHERE statement, or the first
9681 statement in where-body-construct of a WHERE construct */
9682 cnext
= cblock
->next
;
9687 /* WHERE assignment statement */
9690 /* Check shape consistent for WHERE assignment target. */
9691 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9692 gfc_error ("WHERE assignment target at %L has "
9693 "inconsistent shape", &cnext
->expr1
->where
);
9697 case EXEC_ASSIGN_CALL
:
9698 resolve_call (cnext
);
9699 if (!cnext
->resolved_sym
->attr
.elemental
)
9700 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9701 &cnext
->ext
.actual
->expr
->where
);
9704 /* WHERE or WHERE construct is part of a where-body-construct */
9706 resolve_where (cnext
, e
);
9710 gfc_error ("Unsupported statement inside WHERE at %L",
9713 /* the next statement within the same where-body-construct */
9714 cnext
= cnext
->next
;
9716 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9717 cblock
= cblock
->block
;
9722 /* Resolve assignment in FORALL construct.
9723 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9724 FORALL index variables. */
9727 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9731 for (n
= 0; n
< nvar
; n
++)
9733 gfc_symbol
*forall_index
;
9735 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9737 /* Check whether the assignment target is one of the FORALL index
9739 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9740 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9741 gfc_error ("Assignment to a FORALL index variable at %L",
9742 &code
->expr1
->where
);
9745 /* If one of the FORALL index variables doesn't appear in the
9746 assignment variable, then there could be a many-to-one
9747 assignment. Emit a warning rather than an error because the
9748 mask could be resolving this problem. */
9749 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9750 gfc_warning (0, "The FORALL with index %qs is not used on the "
9751 "left side of the assignment at %L and so might "
9752 "cause multiple assignment to this object",
9753 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9759 /* Resolve WHERE statement in FORALL construct. */
9762 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9763 gfc_expr
**var_expr
)
9768 cblock
= code
->block
;
9771 /* the assignment statement of a WHERE statement, or the first
9772 statement in where-body-construct of a WHERE construct */
9773 cnext
= cblock
->next
;
9778 /* WHERE assignment statement */
9780 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9783 /* WHERE operator assignment statement */
9784 case EXEC_ASSIGN_CALL
:
9785 resolve_call (cnext
);
9786 if (!cnext
->resolved_sym
->attr
.elemental
)
9787 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9788 &cnext
->ext
.actual
->expr
->where
);
9791 /* WHERE or WHERE construct is part of a where-body-construct */
9793 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9797 gfc_error ("Unsupported statement inside WHERE at %L",
9800 /* the next statement within the same where-body-construct */
9801 cnext
= cnext
->next
;
9803 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9804 cblock
= cblock
->block
;
9809 /* Traverse the FORALL body to check whether the following errors exist:
9810 1. For assignment, check if a many-to-one assignment happens.
9811 2. For WHERE statement, check the WHERE body to see if there is any
9812 many-to-one assignment. */
9815 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9819 c
= code
->block
->next
;
9825 case EXEC_POINTER_ASSIGN
:
9826 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9829 case EXEC_ASSIGN_CALL
:
9833 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9834 there is no need to handle it here. */
9838 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9843 /* The next statement in the FORALL body. */
9849 /* Counts the number of iterators needed inside a forall construct, including
9850 nested forall constructs. This is used to allocate the needed memory
9851 in gfc_resolve_forall. */
9854 gfc_count_forall_iterators (gfc_code
*code
)
9856 int max_iters
, sub_iters
, current_iters
;
9857 gfc_forall_iterator
*fa
;
9859 gcc_assert(code
->op
== EXEC_FORALL
);
9863 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9866 code
= code
->block
->next
;
9870 if (code
->op
== EXEC_FORALL
)
9872 sub_iters
= gfc_count_forall_iterators (code
);
9873 if (sub_iters
> max_iters
)
9874 max_iters
= sub_iters
;
9879 return current_iters
+ max_iters
;
9883 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9884 gfc_resolve_forall_body to resolve the FORALL body. */
9887 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9889 static gfc_expr
**var_expr
;
9890 static int total_var
= 0;
9891 static int nvar
= 0;
9892 int i
, old_nvar
, tmp
;
9893 gfc_forall_iterator
*fa
;
9897 /* Start to resolve a FORALL construct */
9898 if (forall_save
== 0)
9900 /* Count the total number of FORALL indices in the nested FORALL
9901 construct in order to allocate the VAR_EXPR with proper size. */
9902 total_var
= gfc_count_forall_iterators (code
);
9904 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9905 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9908 /* The information about FORALL iterator, including FORALL indices start, end
9909 and stride. An outer FORALL indice cannot appear in start, end or stride. */
9910 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9912 /* Fortran 20008: C738 (R753). */
9913 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
9915 gfc_error ("FORALL index-name at %L must be a scalar variable "
9916 "of type integer", &fa
->var
->where
);
9920 /* Check if any outer FORALL index name is the same as the current
9922 for (i
= 0; i
< nvar
; i
++)
9924 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9925 gfc_error ("An outer FORALL construct already has an index "
9926 "with this name %L", &fa
->var
->where
);
9929 /* Record the current FORALL index. */
9930 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9934 /* No memory leak. */
9935 gcc_assert (nvar
<= total_var
);
9938 /* Resolve the FORALL body. */
9939 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9941 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9942 gfc_resolve_blocks (code
->block
, ns
);
9946 /* Free only the VAR_EXPRs allocated in this frame. */
9947 for (i
= nvar
; i
< tmp
; i
++)
9948 gfc_free_expr (var_expr
[i
]);
9952 /* We are in the outermost FORALL construct. */
9953 gcc_assert (forall_save
== 0);
9955 /* VAR_EXPR is not needed any more. */
9962 /* Resolve a BLOCK construct statement. */
9965 resolve_block_construct (gfc_code
* code
)
9967 /* Resolve the BLOCK's namespace. */
9968 gfc_resolve (code
->ext
.block
.ns
);
9970 /* For an ASSOCIATE block, the associations (and their targets) are already
9971 resolved during resolve_symbol. */
9975 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9979 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9983 for (; b
; b
= b
->block
)
9985 t
= gfc_resolve_expr (b
->expr1
);
9986 if (!gfc_resolve_expr (b
->expr2
))
9992 if (t
&& b
->expr1
!= NULL
9993 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9994 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10000 && b
->expr1
!= NULL
10001 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10002 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10007 resolve_branch (b
->label1
, b
);
10011 resolve_block_construct (b
);
10015 case EXEC_SELECT_TYPE
:
10018 case EXEC_DO_WHILE
:
10019 case EXEC_DO_CONCURRENT
:
10020 case EXEC_CRITICAL
:
10023 case EXEC_IOLENGTH
:
10027 case EXEC_OMP_ATOMIC
:
10028 case EXEC_OACC_ATOMIC
:
10030 gfc_omp_atomic_op aop
10031 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10033 /* Verify this before calling gfc_resolve_code, which might
10035 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10036 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10037 && b
->next
->next
== NULL
)
10038 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10039 && b
->next
->next
!= NULL
10040 && b
->next
->next
->op
== EXEC_ASSIGN
10041 && b
->next
->next
->next
== NULL
));
10045 case EXEC_OACC_PARALLEL_LOOP
:
10046 case EXEC_OACC_PARALLEL
:
10047 case EXEC_OACC_KERNELS_LOOP
:
10048 case EXEC_OACC_KERNELS
:
10049 case EXEC_OACC_DATA
:
10050 case EXEC_OACC_HOST_DATA
:
10051 case EXEC_OACC_LOOP
:
10052 case EXEC_OACC_UPDATE
:
10053 case EXEC_OACC_WAIT
:
10054 case EXEC_OACC_CACHE
:
10055 case EXEC_OACC_ENTER_DATA
:
10056 case EXEC_OACC_EXIT_DATA
:
10057 case EXEC_OACC_ROUTINE
:
10058 case EXEC_OMP_CRITICAL
:
10059 case EXEC_OMP_DISTRIBUTE
:
10060 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10061 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10062 case EXEC_OMP_DISTRIBUTE_SIMD
:
10064 case EXEC_OMP_DO_SIMD
:
10065 case EXEC_OMP_MASTER
:
10066 case EXEC_OMP_ORDERED
:
10067 case EXEC_OMP_PARALLEL
:
10068 case EXEC_OMP_PARALLEL_DO
:
10069 case EXEC_OMP_PARALLEL_DO_SIMD
:
10070 case EXEC_OMP_PARALLEL_SECTIONS
:
10071 case EXEC_OMP_PARALLEL_WORKSHARE
:
10072 case EXEC_OMP_SECTIONS
:
10073 case EXEC_OMP_SIMD
:
10074 case EXEC_OMP_SINGLE
:
10075 case EXEC_OMP_TARGET
:
10076 case EXEC_OMP_TARGET_DATA
:
10077 case EXEC_OMP_TARGET_ENTER_DATA
:
10078 case EXEC_OMP_TARGET_EXIT_DATA
:
10079 case EXEC_OMP_TARGET_PARALLEL
:
10080 case EXEC_OMP_TARGET_PARALLEL_DO
:
10081 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10082 case EXEC_OMP_TARGET_SIMD
:
10083 case EXEC_OMP_TARGET_TEAMS
:
10084 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10085 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10086 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10087 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10088 case EXEC_OMP_TARGET_UPDATE
:
10089 case EXEC_OMP_TASK
:
10090 case EXEC_OMP_TASKGROUP
:
10091 case EXEC_OMP_TASKLOOP
:
10092 case EXEC_OMP_TASKLOOP_SIMD
:
10093 case EXEC_OMP_TASKWAIT
:
10094 case EXEC_OMP_TASKYIELD
:
10095 case EXEC_OMP_TEAMS
:
10096 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10097 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10098 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10099 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10100 case EXEC_OMP_WORKSHARE
:
10104 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10107 gfc_resolve_code (b
->next
, ns
);
10112 /* Does everything to resolve an ordinary assignment. Returns true
10113 if this is an interface assignment. */
10115 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10122 symbol_attribute attr
;
10124 if (gfc_extend_assign (code
, ns
))
10128 if (code
->op
== EXEC_ASSIGN_CALL
)
10130 lhs
= code
->ext
.actual
->expr
;
10131 rhsptr
= &code
->ext
.actual
->next
->expr
;
10135 gfc_actual_arglist
* args
;
10136 gfc_typebound_proc
* tbp
;
10138 gcc_assert (code
->op
== EXEC_COMPCALL
);
10140 args
= code
->expr1
->value
.compcall
.actual
;
10142 rhsptr
= &args
->next
->expr
;
10144 tbp
= code
->expr1
->value
.compcall
.tbp
;
10145 gcc_assert (!tbp
->is_generic
);
10148 /* Make a temporary rhs when there is a default initializer
10149 and rhs is the same symbol as the lhs. */
10150 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10151 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10152 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10153 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10154 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10163 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10164 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10168 /* Handle the case of a BOZ literal on the RHS. */
10169 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10172 if (warn_surprising
)
10173 gfc_warning (OPT_Wsurprising
,
10174 "BOZ literal at %L is bitwise transferred "
10175 "non-integer symbol %qs", &code
->loc
,
10176 lhs
->symtree
->n
.sym
->name
);
10178 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10180 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10182 if (rc
== ARITH_UNDERFLOW
)
10183 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10184 ". This check can be disabled with the option "
10185 "%<-fno-range-check%>", &rhs
->where
);
10186 else if (rc
== ARITH_OVERFLOW
)
10187 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10188 ". This check can be disabled with the option "
10189 "%<-fno-range-check%>", &rhs
->where
);
10190 else if (rc
== ARITH_NAN
)
10191 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10192 ". This check can be disabled with the option "
10193 "%<-fno-range-check%>", &rhs
->where
);
10198 if (lhs
->ts
.type
== BT_CHARACTER
10199 && warn_character_truncation
)
10201 HOST_WIDE_INT llen
= 0, rlen
= 0;
10202 if (lhs
->ts
.u
.cl
!= NULL
10203 && lhs
->ts
.u
.cl
->length
!= NULL
10204 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10205 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10207 if (rhs
->expr_type
== EXPR_CONSTANT
)
10208 rlen
= rhs
->value
.character
.length
;
10210 else if (rhs
->ts
.u
.cl
!= NULL
10211 && rhs
->ts
.u
.cl
->length
!= NULL
10212 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10213 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10215 if (rlen
&& llen
&& rlen
> llen
)
10216 gfc_warning_now (OPT_Wcharacter_truncation
,
10217 "CHARACTER expression will be truncated "
10218 "in assignment (%ld/%ld) at %L",
10219 (long) llen
, (long) rlen
, &code
->loc
);
10222 /* Ensure that a vector index expression for the lvalue is evaluated
10223 to a temporary if the lvalue symbol is referenced in it. */
10226 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10227 if (ref
->type
== REF_ARRAY
)
10229 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10230 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10231 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10232 ref
->u
.ar
.start
[n
]))
10234 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10238 if (gfc_pure (NULL
))
10240 if (lhs
->ts
.type
== BT_DERIVED
10241 && lhs
->expr_type
== EXPR_VARIABLE
10242 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10243 && rhs
->expr_type
== EXPR_VARIABLE
10244 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10245 || gfc_is_coindexed (rhs
)))
10247 /* F2008, C1283. */
10248 if (gfc_is_coindexed (rhs
))
10249 gfc_error ("Coindexed expression at %L is assigned to "
10250 "a derived type variable with a POINTER "
10251 "component in a PURE procedure",
10254 gfc_error ("The impure variable at %L is assigned to "
10255 "a derived type variable with a POINTER "
10256 "component in a PURE procedure (12.6)",
10261 /* Fortran 2008, C1283. */
10262 if (gfc_is_coindexed (lhs
))
10264 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10265 "procedure", &rhs
->where
);
10270 if (gfc_implicit_pure (NULL
))
10272 if (lhs
->expr_type
== EXPR_VARIABLE
10273 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10274 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10275 gfc_unset_implicit_pure (NULL
);
10277 if (lhs
->ts
.type
== BT_DERIVED
10278 && lhs
->expr_type
== EXPR_VARIABLE
10279 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10280 && rhs
->expr_type
== EXPR_VARIABLE
10281 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10282 || gfc_is_coindexed (rhs
)))
10283 gfc_unset_implicit_pure (NULL
);
10285 /* Fortran 2008, C1283. */
10286 if (gfc_is_coindexed (lhs
))
10287 gfc_unset_implicit_pure (NULL
);
10290 /* F2008, 7.2.1.2. */
10291 attr
= gfc_expr_attr (lhs
);
10292 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10294 if (attr
.codimension
)
10296 gfc_error ("Assignment to polymorphic coarray at %L is not "
10297 "permitted", &lhs
->where
);
10300 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10301 "polymorphic variable at %L", &lhs
->where
))
10303 if (!flag_realloc_lhs
)
10305 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10306 "requires %<-frealloc-lhs%>", &lhs
->where
);
10310 else if (lhs
->ts
.type
== BT_CLASS
)
10312 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10313 "assignment at %L - check that there is a matching specific "
10314 "subroutine for '=' operator", &lhs
->where
);
10318 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10320 /* F2008, Section 7.2.1.2. */
10321 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10323 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10324 "component in assignment at %L", &lhs
->where
);
10328 /* Assign the 'data' of a class object to a derived type. */
10329 if (lhs
->ts
.type
== BT_DERIVED
10330 && rhs
->ts
.type
== BT_CLASS
10331 && rhs
->expr_type
!= EXPR_ARRAY
)
10332 gfc_add_data_component (rhs
);
10334 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10336 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10337 && code
->expr2
->value
.function
.isym
10338 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10339 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10340 && !gfc_expr_attr (rhs
).allocatable
10341 && !gfc_has_vector_subscript (rhs
)));
10343 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10345 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10346 Additionally, insert this code when the RHS is a CAF as we then use the
10347 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10348 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10349 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10351 if (caf_convert_to_send
)
10353 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10354 && code
->expr2
->value
.function
.isym
10355 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10356 remove_caf_get_intrinsic (code
->expr2
);
10357 code
->op
= EXEC_CALL
;
10358 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10359 code
->resolved_sym
= code
->symtree
->n
.sym
;
10360 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10361 code
->resolved_sym
->attr
.intrinsic
= 1;
10362 code
->resolved_sym
->attr
.subroutine
= 1;
10363 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10364 gfc_commit_symbol (code
->resolved_sym
);
10365 code
->ext
.actual
= gfc_get_actual_arglist ();
10366 code
->ext
.actual
->expr
= lhs
;
10367 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10368 code
->ext
.actual
->next
->expr
= rhs
;
10369 code
->expr1
= NULL
;
10370 code
->expr2
= NULL
;
10377 /* Add a component reference onto an expression. */
10380 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10385 ref
= &((*ref
)->next
);
10386 *ref
= gfc_get_ref ();
10387 (*ref
)->type
= REF_COMPONENT
;
10388 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10389 (*ref
)->u
.c
.component
= c
;
10392 /* Add a full array ref, as necessary. */
10395 gfc_add_full_array_ref (e
, c
->as
);
10396 e
->rank
= c
->as
->rank
;
10401 /* Build an assignment. Keep the argument 'op' for future use, so that
10402 pointer assignments can be made. */
10405 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10406 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10408 gfc_code
*this_code
;
10410 this_code
= gfc_get_code (op
);
10411 this_code
->next
= NULL
;
10412 this_code
->expr1
= gfc_copy_expr (expr1
);
10413 this_code
->expr2
= gfc_copy_expr (expr2
);
10414 this_code
->loc
= loc
;
10415 if (comp1
&& comp2
)
10417 add_comp_ref (this_code
->expr1
, comp1
);
10418 add_comp_ref (this_code
->expr2
, comp2
);
10425 /* Makes a temporary variable expression based on the characteristics of
10426 a given variable expression. */
10429 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10431 static int serial
= 0;
10432 char name
[GFC_MAX_SYMBOL_LEN
];
10434 gfc_array_spec
*as
;
10435 gfc_array_ref
*aref
;
10438 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10439 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10440 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10446 /* Obtain the arrayspec for the temporary. */
10447 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10448 && e
->expr_type
!= EXPR_FUNCTION
10449 && e
->expr_type
!= EXPR_OP
)
10451 aref
= gfc_find_array_ref (e
);
10452 if (e
->expr_type
== EXPR_VARIABLE
10453 && e
->symtree
->n
.sym
->as
== aref
->as
)
10457 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10458 if (ref
->type
== REF_COMPONENT
10459 && ref
->u
.c
.component
->as
== aref
->as
)
10467 /* Add the attributes and the arrayspec to the temporary. */
10468 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10469 tmp
->n
.sym
->attr
.function
= 0;
10470 tmp
->n
.sym
->attr
.result
= 0;
10471 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10475 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10478 if (as
->type
== AS_DEFERRED
)
10479 tmp
->n
.sym
->attr
.allocatable
= 1;
10481 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10482 || e
->expr_type
== EXPR_FUNCTION
10483 || e
->expr_type
== EXPR_OP
))
10485 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10486 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10487 tmp
->n
.sym
->as
->rank
= e
->rank
;
10488 tmp
->n
.sym
->attr
.allocatable
= 1;
10489 tmp
->n
.sym
->attr
.dimension
= 1;
10492 tmp
->n
.sym
->attr
.dimension
= 0;
10494 gfc_set_sym_referenced (tmp
->n
.sym
);
10495 gfc_commit_symbol (tmp
->n
.sym
);
10496 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10498 /* Should the lhs be a section, use its array ref for the
10499 temporary expression. */
10500 if (aref
&& aref
->type
!= AR_FULL
)
10502 gfc_free_ref_list (e
->ref
);
10503 e
->ref
= gfc_copy_ref (ref
);
10509 /* Add one line of code to the code chain, making sure that 'head' and
10510 'tail' are appropriately updated. */
10513 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10515 gcc_assert (this_code
);
10517 *head
= *tail
= *this_code
;
10519 *tail
= gfc_append_code (*tail
, *this_code
);
10524 /* Counts the potential number of part array references that would
10525 result from resolution of typebound defined assignments. */
10528 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10531 int c_depth
= 0, t_depth
;
10533 for (c
= derived
->components
; c
; c
= c
->next
)
10535 if ((!gfc_bt_struct (c
->ts
.type
)
10537 || c
->attr
.allocatable
10538 || c
->attr
.proc_pointer_comp
10539 || c
->attr
.class_pointer
10540 || c
->attr
.proc_pointer
)
10541 && !c
->attr
.defined_assign_comp
)
10544 if (c
->as
&& c_depth
== 0)
10547 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10548 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10553 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10555 return depth
+ c_depth
;
10559 /* Implement 7.2.1.3 of the F08 standard:
10560 "An intrinsic assignment where the variable is of derived type is
10561 performed as if each component of the variable were assigned from the
10562 corresponding component of expr using pointer assignment (7.2.2) for
10563 each pointer component, defined assignment for each nonpointer
10564 nonallocatable component of a type that has a type-bound defined
10565 assignment consistent with the component, intrinsic assignment for
10566 each other nonpointer nonallocatable component, ..."
10568 The pointer assignments are taken care of by the intrinsic
10569 assignment of the structure itself. This function recursively adds
10570 defined assignments where required. The recursion is accomplished
10571 by calling gfc_resolve_code.
10573 When the lhs in a defined assignment has intent INOUT, we need a
10574 temporary for the lhs. In pseudo-code:
10576 ! Only call function lhs once.
10577 if (lhs is not a constant or an variable)
10580 ! Do the intrinsic assignment
10582 ! Now do the defined assignments
10583 do over components with typebound defined assignment [%cmp]
10584 #if one component's assignment procedure is INOUT
10586 #if expr2 non-variable
10592 t1%cmp {defined=} expr2%cmp
10598 expr1%cmp {defined=} expr2%cmp
10602 /* The temporary assignments have to be put on top of the additional
10603 code to avoid the result being changed by the intrinsic assignment.
10605 static int component_assignment_level
= 0;
10606 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10609 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10611 gfc_component
*comp1
, *comp2
;
10612 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10614 int error_count
, depth
;
10616 gfc_get_errors (NULL
, &error_count
);
10618 /* Filter out continuing processing after an error. */
10620 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10621 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10624 /* TODO: Handle more than one part array reference in assignments. */
10625 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10626 (*code
)->expr1
->rank
? 1 : 0);
10629 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10630 "done because multiple part array references would "
10631 "occur in intermediate expressions.", &(*code
)->loc
);
10635 component_assignment_level
++;
10637 /* Create a temporary so that functions get called only once. */
10638 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10639 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10641 gfc_expr
*tmp_expr
;
10643 /* Assign the rhs to the temporary. */
10644 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10645 this_code
= build_assignment (EXEC_ASSIGN
,
10646 tmp_expr
, (*code
)->expr2
,
10647 NULL
, NULL
, (*code
)->loc
);
10648 /* Add the code and substitute the rhs expression. */
10649 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10650 gfc_free_expr ((*code
)->expr2
);
10651 (*code
)->expr2
= tmp_expr
;
10654 /* Do the intrinsic assignment. This is not needed if the lhs is one
10655 of the temporaries generated here, since the intrinsic assignment
10656 to the final result already does this. */
10657 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10659 this_code
= build_assignment (EXEC_ASSIGN
,
10660 (*code
)->expr1
, (*code
)->expr2
,
10661 NULL
, NULL
, (*code
)->loc
);
10662 add_code_to_chain (&this_code
, &head
, &tail
);
10665 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10666 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10669 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10671 bool inout
= false;
10673 /* The intrinsic assignment does the right thing for pointers
10674 of all kinds and allocatable components. */
10675 if (!gfc_bt_struct (comp1
->ts
.type
)
10676 || comp1
->attr
.pointer
10677 || comp1
->attr
.allocatable
10678 || comp1
->attr
.proc_pointer_comp
10679 || comp1
->attr
.class_pointer
10680 || comp1
->attr
.proc_pointer
)
10683 /* Make an assigment for this component. */
10684 this_code
= build_assignment (EXEC_ASSIGN
,
10685 (*code
)->expr1
, (*code
)->expr2
,
10686 comp1
, comp2
, (*code
)->loc
);
10688 /* Convert the assignment if there is a defined assignment for
10689 this type. Otherwise, using the call from gfc_resolve_code,
10690 recurse into its components. */
10691 gfc_resolve_code (this_code
, ns
);
10693 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10695 gfc_formal_arglist
*dummy_args
;
10697 /* Check that there is a typebound defined assignment. If not,
10698 then this must be a module defined assignment. We cannot
10699 use the defined_assign_comp attribute here because it must
10700 be this derived type that has the defined assignment and not
10702 if (!(comp1
->ts
.u
.derived
->f2k_derived
10703 && comp1
->ts
.u
.derived
->f2k_derived
10704 ->tb_op
[INTRINSIC_ASSIGN
]))
10706 gfc_free_statements (this_code
);
10711 /* If the first argument of the subroutine has intent INOUT
10712 a temporary must be generated and used instead. */
10713 rsym
= this_code
->resolved_sym
;
10714 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10716 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10718 gfc_code
*temp_code
;
10721 /* Build the temporary required for the assignment and put
10722 it at the head of the generated code. */
10725 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10726 temp_code
= build_assignment (EXEC_ASSIGN
,
10727 t1
, (*code
)->expr1
,
10728 NULL
, NULL
, (*code
)->loc
);
10730 /* For allocatable LHS, check whether it is allocated. Note
10731 that allocatable components with defined assignment are
10732 not yet support. See PR 57696. */
10733 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10737 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10738 block
= gfc_get_code (EXEC_IF
);
10739 block
->block
= gfc_get_code (EXEC_IF
);
10740 block
->block
->expr1
10741 = gfc_build_intrinsic_call (ns
,
10742 GFC_ISYM_ALLOCATED
, "allocated",
10743 (*code
)->loc
, 1, e
);
10744 block
->block
->next
= temp_code
;
10747 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10750 /* Replace the first actual arg with the component of the
10752 gfc_free_expr (this_code
->ext
.actual
->expr
);
10753 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10754 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10756 /* If the LHS variable is allocatable and wasn't allocated and
10757 the temporary is allocatable, pointer assign the address of
10758 the freshly allocated LHS to the temporary. */
10759 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10760 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10765 cond
= gfc_get_expr ();
10766 cond
->ts
.type
= BT_LOGICAL
;
10767 cond
->ts
.kind
= gfc_default_logical_kind
;
10768 cond
->expr_type
= EXPR_OP
;
10769 cond
->where
= (*code
)->loc
;
10770 cond
->value
.op
.op
= INTRINSIC_NOT
;
10771 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10772 GFC_ISYM_ALLOCATED
, "allocated",
10773 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10774 block
= gfc_get_code (EXEC_IF
);
10775 block
->block
= gfc_get_code (EXEC_IF
);
10776 block
->block
->expr1
= cond
;
10777 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10778 t1
, (*code
)->expr1
,
10779 NULL
, NULL
, (*code
)->loc
);
10780 add_code_to_chain (&block
, &head
, &tail
);
10784 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10786 /* Don't add intrinsic assignments since they are already
10787 effected by the intrinsic assignment of the structure. */
10788 gfc_free_statements (this_code
);
10793 add_code_to_chain (&this_code
, &head
, &tail
);
10797 /* Transfer the value to the final result. */
10798 this_code
= build_assignment (EXEC_ASSIGN
,
10799 (*code
)->expr1
, t1
,
10800 comp1
, comp2
, (*code
)->loc
);
10801 add_code_to_chain (&this_code
, &head
, &tail
);
10805 /* Put the temporary assignments at the top of the generated code. */
10806 if (tmp_head
&& component_assignment_level
== 1)
10808 gfc_append_code (tmp_head
, head
);
10810 tmp_head
= tmp_tail
= NULL
;
10813 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10814 // not accidentally deallocated. Hence, nullify t1.
10815 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10816 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10822 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10823 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10824 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10825 block
= gfc_get_code (EXEC_IF
);
10826 block
->block
= gfc_get_code (EXEC_IF
);
10827 block
->block
->expr1
= cond
;
10828 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10829 t1
, gfc_get_null_expr (&(*code
)->loc
),
10830 NULL
, NULL
, (*code
)->loc
);
10831 gfc_append_code (tail
, block
);
10835 /* Now attach the remaining code chain to the input code. Step on
10836 to the end of the new code since resolution is complete. */
10837 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10838 tail
->next
= (*code
)->next
;
10839 /* Overwrite 'code' because this would place the intrinsic assignment
10840 before the temporary for the lhs is created. */
10841 gfc_free_expr ((*code
)->expr1
);
10842 gfc_free_expr ((*code
)->expr2
);
10848 component_assignment_level
--;
10852 /* F2008: Pointer function assignments are of the form:
10853 ptr_fcn (args) = expr
10854 This function breaks these assignments into two statements:
10855 temporary_pointer => ptr_fcn(args)
10856 temporary_pointer = expr */
10859 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10861 gfc_expr
*tmp_ptr_expr
;
10862 gfc_code
*this_code
;
10863 gfc_component
*comp
;
10866 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10869 /* Even if standard does not support this feature, continue to build
10870 the two statements to avoid upsetting frontend_passes.c. */
10871 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10872 "%L", &(*code
)->loc
);
10874 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10877 s
= comp
->ts
.interface
;
10879 s
= (*code
)->expr1
->symtree
->n
.sym
;
10881 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10883 gfc_error ("The function result on the lhs of the assignment at "
10884 "%L must have the pointer attribute.",
10885 &(*code
)->expr1
->where
);
10886 (*code
)->op
= EXEC_NOP
;
10890 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10892 /* get_temp_from_expression is set up for ordinary assignments. To that
10893 end, where array bounds are not known, arrays are made allocatable.
10894 Change the temporary to a pointer here. */
10895 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10896 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10897 tmp_ptr_expr
->where
= (*code
)->loc
;
10899 this_code
= build_assignment (EXEC_ASSIGN
,
10900 tmp_ptr_expr
, (*code
)->expr2
,
10901 NULL
, NULL
, (*code
)->loc
);
10902 this_code
->next
= (*code
)->next
;
10903 (*code
)->next
= this_code
;
10904 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10905 (*code
)->expr2
= (*code
)->expr1
;
10906 (*code
)->expr1
= tmp_ptr_expr
;
10912 /* Deferred character length assignments from an operator expression
10913 require a temporary because the character length of the lhs can
10914 change in the course of the assignment. */
10917 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10919 gfc_expr
*tmp_expr
;
10920 gfc_code
*this_code
;
10922 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10923 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10924 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10927 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10930 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10931 tmp_expr
->where
= (*code
)->loc
;
10933 /* A new charlen is required to ensure that the variable string
10934 length is different to that of the original lhs. */
10935 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10936 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10937 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10938 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10940 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10942 this_code
= build_assignment (EXEC_ASSIGN
,
10944 gfc_copy_expr (tmp_expr
),
10945 NULL
, NULL
, (*code
)->loc
);
10947 (*code
)->expr1
= tmp_expr
;
10949 this_code
->next
= (*code
)->next
;
10950 (*code
)->next
= this_code
;
10956 /* Given a block of code, recursively resolve everything pointed to by this
10960 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10962 int omp_workshare_save
;
10963 int forall_save
, do_concurrent_save
;
10967 frame
.prev
= cs_base
;
10971 find_reachable_labels (code
);
10973 for (; code
; code
= code
->next
)
10975 frame
.current
= code
;
10976 forall_save
= forall_flag
;
10977 do_concurrent_save
= gfc_do_concurrent_flag
;
10979 if (code
->op
== EXEC_FORALL
)
10982 gfc_resolve_forall (code
, ns
, forall_save
);
10985 else if (code
->block
)
10987 omp_workshare_save
= -1;
10990 case EXEC_OACC_PARALLEL_LOOP
:
10991 case EXEC_OACC_PARALLEL
:
10992 case EXEC_OACC_KERNELS_LOOP
:
10993 case EXEC_OACC_KERNELS
:
10994 case EXEC_OACC_DATA
:
10995 case EXEC_OACC_HOST_DATA
:
10996 case EXEC_OACC_LOOP
:
10997 gfc_resolve_oacc_blocks (code
, ns
);
10999 case EXEC_OMP_PARALLEL_WORKSHARE
:
11000 omp_workshare_save
= omp_workshare_flag
;
11001 omp_workshare_flag
= 1;
11002 gfc_resolve_omp_parallel_blocks (code
, ns
);
11004 case EXEC_OMP_PARALLEL
:
11005 case EXEC_OMP_PARALLEL_DO
:
11006 case EXEC_OMP_PARALLEL_DO_SIMD
:
11007 case EXEC_OMP_PARALLEL_SECTIONS
:
11008 case EXEC_OMP_TARGET_PARALLEL
:
11009 case EXEC_OMP_TARGET_PARALLEL_DO
:
11010 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11011 case EXEC_OMP_TARGET_TEAMS
:
11012 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11013 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11014 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11015 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11016 case EXEC_OMP_TASK
:
11017 case EXEC_OMP_TASKLOOP
:
11018 case EXEC_OMP_TASKLOOP_SIMD
:
11019 case EXEC_OMP_TEAMS
:
11020 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11021 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11022 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11023 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11024 omp_workshare_save
= omp_workshare_flag
;
11025 omp_workshare_flag
= 0;
11026 gfc_resolve_omp_parallel_blocks (code
, ns
);
11028 case EXEC_OMP_DISTRIBUTE
:
11029 case EXEC_OMP_DISTRIBUTE_SIMD
:
11031 case EXEC_OMP_DO_SIMD
:
11032 case EXEC_OMP_SIMD
:
11033 case EXEC_OMP_TARGET_SIMD
:
11034 gfc_resolve_omp_do_blocks (code
, ns
);
11036 case EXEC_SELECT_TYPE
:
11037 /* Blocks are handled in resolve_select_type because we have
11038 to transform the SELECT TYPE into ASSOCIATE first. */
11040 case EXEC_DO_CONCURRENT
:
11041 gfc_do_concurrent_flag
= 1;
11042 gfc_resolve_blocks (code
->block
, ns
);
11043 gfc_do_concurrent_flag
= 2;
11045 case EXEC_OMP_WORKSHARE
:
11046 omp_workshare_save
= omp_workshare_flag
;
11047 omp_workshare_flag
= 1;
11050 gfc_resolve_blocks (code
->block
, ns
);
11054 if (omp_workshare_save
!= -1)
11055 omp_workshare_flag
= omp_workshare_save
;
11059 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11060 t
= gfc_resolve_expr (code
->expr1
);
11061 forall_flag
= forall_save
;
11062 gfc_do_concurrent_flag
= do_concurrent_save
;
11064 if (!gfc_resolve_expr (code
->expr2
))
11067 if (code
->op
== EXEC_ALLOCATE
11068 && !gfc_resolve_expr (code
->expr3
))
11074 case EXEC_END_BLOCK
:
11075 case EXEC_END_NESTED_BLOCK
:
11079 case EXEC_ERROR_STOP
:
11081 case EXEC_CONTINUE
:
11083 case EXEC_ASSIGN_CALL
:
11086 case EXEC_CRITICAL
:
11087 resolve_critical (code
);
11090 case EXEC_SYNC_ALL
:
11091 case EXEC_SYNC_IMAGES
:
11092 case EXEC_SYNC_MEMORY
:
11093 resolve_sync (code
);
11098 case EXEC_EVENT_POST
:
11099 case EXEC_EVENT_WAIT
:
11100 resolve_lock_unlock_event (code
);
11103 case EXEC_FAIL_IMAGE
:
11104 case EXEC_FORM_TEAM
:
11105 case EXEC_CHANGE_TEAM
:
11106 case EXEC_END_TEAM
:
11107 case EXEC_SYNC_TEAM
:
11111 /* Keep track of which entry we are up to. */
11112 current_entry_id
= code
->ext
.entry
->id
;
11116 resolve_where (code
, NULL
);
11120 if (code
->expr1
!= NULL
)
11122 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11123 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11124 "INTEGER variable", &code
->expr1
->where
);
11125 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11126 gfc_error ("Variable %qs has not been assigned a target "
11127 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11128 &code
->expr1
->where
);
11131 resolve_branch (code
->label1
, code
);
11135 if (code
->expr1
!= NULL
11136 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11137 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11138 "INTEGER return specifier", &code
->expr1
->where
);
11141 case EXEC_INIT_ASSIGN
:
11142 case EXEC_END_PROCEDURE
:
11149 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11151 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11152 && code
->expr1
->value
.function
.isym
11153 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11154 remove_caf_get_intrinsic (code
->expr1
);
11156 /* If this is a pointer function in an lvalue variable context,
11157 the new code will have to be resolved afresh. This is also the
11158 case with an error, where the code is transformed into NOP to
11159 prevent ICEs downstream. */
11160 if (resolve_ptr_fcn_assign (&code
, ns
)
11161 || code
->op
== EXEC_NOP
)
11164 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11168 if (resolve_ordinary_assign (code
, ns
))
11170 if (code
->op
== EXEC_COMPCALL
)
11176 /* Check for dependencies in deferred character length array
11177 assignments and generate a temporary, if necessary. */
11178 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11181 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11182 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11183 && code
->expr1
->ts
.u
.derived
11184 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11185 generate_component_assignments (&code
, ns
);
11189 case EXEC_LABEL_ASSIGN
:
11190 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11191 gfc_error ("Label %d referenced at %L is never defined",
11192 code
->label1
->value
, &code
->label1
->where
);
11194 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11195 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11196 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11197 != gfc_default_integer_kind
11198 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11199 gfc_error ("ASSIGN statement at %L requires a scalar "
11200 "default INTEGER variable", &code
->expr1
->where
);
11203 case EXEC_POINTER_ASSIGN
:
11210 /* This is both a variable definition and pointer assignment
11211 context, so check both of them. For rank remapping, a final
11212 array ref may be present on the LHS and fool gfc_expr_attr
11213 used in gfc_check_vardef_context. Remove it. */
11214 e
= remove_last_array_ref (code
->expr1
);
11215 t
= gfc_check_vardef_context (e
, true, false, false,
11216 _("pointer assignment"));
11218 t
= gfc_check_vardef_context (e
, false, false, false,
11219 _("pointer assignment"));
11224 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
11226 /* Assigning a class object always is a regular assign. */
11227 if (code
->expr2
->ts
.type
== BT_CLASS
11228 && code
->expr1
->ts
.type
== BT_CLASS
11229 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11230 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11231 && code
->expr2
->expr_type
== EXPR_VARIABLE
11232 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11234 code
->op
= EXEC_ASSIGN
;
11238 case EXEC_ARITHMETIC_IF
:
11240 gfc_expr
*e
= code
->expr1
;
11242 gfc_resolve_expr (e
);
11243 if (e
->expr_type
== EXPR_NULL
)
11244 gfc_error ("Invalid NULL at %L", &e
->where
);
11246 if (t
&& (e
->rank
> 0
11247 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11248 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11249 "REAL or INTEGER expression", &e
->where
);
11251 resolve_branch (code
->label1
, code
);
11252 resolve_branch (code
->label2
, code
);
11253 resolve_branch (code
->label3
, code
);
11258 if (t
&& code
->expr1
!= NULL
11259 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11260 || code
->expr1
->rank
!= 0))
11261 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11262 &code
->expr1
->where
);
11267 resolve_call (code
);
11270 case EXEC_COMPCALL
:
11272 resolve_typebound_subroutine (code
);
11275 case EXEC_CALL_PPC
:
11276 resolve_ppc_call (code
);
11280 /* Select is complicated. Also, a SELECT construct could be
11281 a transformed computed GOTO. */
11282 resolve_select (code
, false);
11285 case EXEC_SELECT_TYPE
:
11286 resolve_select_type (code
, ns
);
11290 resolve_block_construct (code
);
11294 if (code
->ext
.iterator
!= NULL
)
11296 gfc_iterator
*iter
= code
->ext
.iterator
;
11297 if (gfc_resolve_iterator (iter
, true, false))
11298 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11303 case EXEC_DO_WHILE
:
11304 if (code
->expr1
== NULL
)
11305 gfc_internal_error ("gfc_resolve_code(): No expression on "
11308 && (code
->expr1
->rank
!= 0
11309 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11310 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11311 "a scalar LOGICAL expression", &code
->expr1
->where
);
11314 case EXEC_ALLOCATE
:
11316 resolve_allocate_deallocate (code
, "ALLOCATE");
11320 case EXEC_DEALLOCATE
:
11322 resolve_allocate_deallocate (code
, "DEALLOCATE");
11327 if (!gfc_resolve_open (code
->ext
.open
))
11330 resolve_branch (code
->ext
.open
->err
, code
);
11334 if (!gfc_resolve_close (code
->ext
.close
))
11337 resolve_branch (code
->ext
.close
->err
, code
);
11340 case EXEC_BACKSPACE
:
11344 if (!gfc_resolve_filepos (code
->ext
.filepos
))
11347 resolve_branch (code
->ext
.filepos
->err
, code
);
11351 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11354 resolve_branch (code
->ext
.inquire
->err
, code
);
11357 case EXEC_IOLENGTH
:
11358 gcc_assert (code
->ext
.inquire
!= NULL
);
11359 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11362 resolve_branch (code
->ext
.inquire
->err
, code
);
11366 if (!gfc_resolve_wait (code
->ext
.wait
))
11369 resolve_branch (code
->ext
.wait
->err
, code
);
11370 resolve_branch (code
->ext
.wait
->end
, code
);
11371 resolve_branch (code
->ext
.wait
->eor
, code
);
11376 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11379 resolve_branch (code
->ext
.dt
->err
, code
);
11380 resolve_branch (code
->ext
.dt
->end
, code
);
11381 resolve_branch (code
->ext
.dt
->eor
, code
);
11384 case EXEC_TRANSFER
:
11385 resolve_transfer (code
);
11388 case EXEC_DO_CONCURRENT
:
11390 resolve_forall_iterators (code
->ext
.forall_iterator
);
11392 if (code
->expr1
!= NULL
11393 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11394 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11395 "expression", &code
->expr1
->where
);
11398 case EXEC_OACC_PARALLEL_LOOP
:
11399 case EXEC_OACC_PARALLEL
:
11400 case EXEC_OACC_KERNELS_LOOP
:
11401 case EXEC_OACC_KERNELS
:
11402 case EXEC_OACC_DATA
:
11403 case EXEC_OACC_HOST_DATA
:
11404 case EXEC_OACC_LOOP
:
11405 case EXEC_OACC_UPDATE
:
11406 case EXEC_OACC_WAIT
:
11407 case EXEC_OACC_CACHE
:
11408 case EXEC_OACC_ENTER_DATA
:
11409 case EXEC_OACC_EXIT_DATA
:
11410 case EXEC_OACC_ATOMIC
:
11411 case EXEC_OACC_DECLARE
:
11412 gfc_resolve_oacc_directive (code
, ns
);
11415 case EXEC_OMP_ATOMIC
:
11416 case EXEC_OMP_BARRIER
:
11417 case EXEC_OMP_CANCEL
:
11418 case EXEC_OMP_CANCELLATION_POINT
:
11419 case EXEC_OMP_CRITICAL
:
11420 case EXEC_OMP_FLUSH
:
11421 case EXEC_OMP_DISTRIBUTE
:
11422 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11423 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11424 case EXEC_OMP_DISTRIBUTE_SIMD
:
11426 case EXEC_OMP_DO_SIMD
:
11427 case EXEC_OMP_MASTER
:
11428 case EXEC_OMP_ORDERED
:
11429 case EXEC_OMP_SECTIONS
:
11430 case EXEC_OMP_SIMD
:
11431 case EXEC_OMP_SINGLE
:
11432 case EXEC_OMP_TARGET
:
11433 case EXEC_OMP_TARGET_DATA
:
11434 case EXEC_OMP_TARGET_ENTER_DATA
:
11435 case EXEC_OMP_TARGET_EXIT_DATA
:
11436 case EXEC_OMP_TARGET_PARALLEL
:
11437 case EXEC_OMP_TARGET_PARALLEL_DO
:
11438 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11439 case EXEC_OMP_TARGET_SIMD
:
11440 case EXEC_OMP_TARGET_TEAMS
:
11441 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11442 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11443 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11444 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11445 case EXEC_OMP_TARGET_UPDATE
:
11446 case EXEC_OMP_TASK
:
11447 case EXEC_OMP_TASKGROUP
:
11448 case EXEC_OMP_TASKLOOP
:
11449 case EXEC_OMP_TASKLOOP_SIMD
:
11450 case EXEC_OMP_TASKWAIT
:
11451 case EXEC_OMP_TASKYIELD
:
11452 case EXEC_OMP_TEAMS
:
11453 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11454 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11455 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11456 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11457 case EXEC_OMP_WORKSHARE
:
11458 gfc_resolve_omp_directive (code
, ns
);
11461 case EXEC_OMP_PARALLEL
:
11462 case EXEC_OMP_PARALLEL_DO
:
11463 case EXEC_OMP_PARALLEL_DO_SIMD
:
11464 case EXEC_OMP_PARALLEL_SECTIONS
:
11465 case EXEC_OMP_PARALLEL_WORKSHARE
:
11466 omp_workshare_save
= omp_workshare_flag
;
11467 omp_workshare_flag
= 0;
11468 gfc_resolve_omp_directive (code
, ns
);
11469 omp_workshare_flag
= omp_workshare_save
;
11473 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11477 cs_base
= frame
.prev
;
11481 /* Resolve initial values and make sure they are compatible with
11485 resolve_values (gfc_symbol
*sym
)
11489 if (sym
->value
== NULL
)
11492 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11493 t
= resolve_structure_cons (sym
->value
, 1);
11495 t
= gfc_resolve_expr (sym
->value
);
11500 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11504 /* Verify any BIND(C) derived types in the namespace so we can report errors
11505 for them once, rather than for each variable declared of that type. */
11508 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11510 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11511 && derived_sym
->attr
.is_bind_c
== 1)
11512 verify_bind_c_derived_type (derived_sym
);
11518 /* Check the interfaces of DTIO procedures associated with derived
11519 type 'sym'. These procedures can either have typebound bindings or
11520 can appear in DTIO generic interfaces. */
11523 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11525 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11528 gfc_check_dtio_interfaces (sym
);
11533 /* Verify that any binding labels used in a given namespace do not collide
11534 with the names or binding labels of any global symbols. Multiple INTERFACE
11535 for the same procedure are permitted. */
11538 gfc_verify_binding_labels (gfc_symbol
*sym
)
11541 const char *module
;
11543 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11544 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11547 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11550 module
= sym
->module
;
11551 else if (sym
->ns
&& sym
->ns
->proc_name
11552 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11553 module
= sym
->ns
->proc_name
->name
;
11554 else if (sym
->ns
&& sym
->ns
->parent
11555 && sym
->ns
&& sym
->ns
->parent
->proc_name
11556 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11557 module
= sym
->ns
->parent
->proc_name
->name
;
11563 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11566 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11567 gsym
->where
= sym
->declared_at
;
11568 gsym
->sym_name
= sym
->name
;
11569 gsym
->binding_label
= sym
->binding_label
;
11570 gsym
->ns
= sym
->ns
;
11571 gsym
->mod_name
= module
;
11572 if (sym
->attr
.function
)
11573 gsym
->type
= GSYM_FUNCTION
;
11574 else if (sym
->attr
.subroutine
)
11575 gsym
->type
= GSYM_SUBROUTINE
;
11576 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11577 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11581 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11583 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11584 "identifier as entity at %L", sym
->name
,
11585 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11586 /* Clear the binding label to prevent checking multiple times. */
11587 sym
->binding_label
= NULL
;
11590 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11591 && (strcmp (module
, gsym
->mod_name
) != 0
11592 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11594 /* This can only happen if the variable is defined in a module - if it
11595 isn't the same module, reject it. */
11596 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11597 "uses the same global identifier as entity at %L from module %qs",
11598 sym
->name
, module
, sym
->binding_label
,
11599 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11600 sym
->binding_label
= NULL
;
11602 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11603 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11604 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11605 && sym
!= gsym
->ns
->proc_name
11606 && (module
!= gsym
->mod_name
11607 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11608 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11610 /* Print an error if the procedure is defined multiple times; we have to
11611 exclude references to the same procedure via module association or
11612 multiple checks for the same procedure. */
11613 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11614 "global identifier as entity at %L", sym
->name
,
11615 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11616 sym
->binding_label
= NULL
;
11621 /* Resolve an index expression. */
11624 resolve_index_expr (gfc_expr
*e
)
11626 if (!gfc_resolve_expr (e
))
11629 if (!gfc_simplify_expr (e
, 0))
11632 if (!gfc_specification_expr (e
))
11639 /* Resolve a charlen structure. */
11642 resolve_charlen (gfc_charlen
*cl
)
11645 bool saved_specification_expr
;
11651 saved_specification_expr
= specification_expr
;
11652 specification_expr
= true;
11654 if (cl
->length_from_typespec
)
11656 if (!gfc_resolve_expr (cl
->length
))
11658 specification_expr
= saved_specification_expr
;
11662 if (!gfc_simplify_expr (cl
->length
, 0))
11664 specification_expr
= saved_specification_expr
;
11668 /* cl->length has been resolved. It should have an integer type. */
11669 if (cl
->length
->ts
.type
!= BT_INTEGER
)
11671 gfc_error ("Scalar INTEGER expression expected at %L",
11672 &cl
->length
->where
);
11678 if (!resolve_index_expr (cl
->length
))
11680 specification_expr
= saved_specification_expr
;
11685 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11686 a negative value, the length of character entities declared is zero. */
11687 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11688 && mpz_sgn (cl
->length
->value
.integer
) < 0)
11689 gfc_replace_expr (cl
->length
,
11690 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
11692 /* Check that the character length is not too large. */
11693 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11694 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11695 && cl
->length
->ts
.type
== BT_INTEGER
11696 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11698 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11699 specification_expr
= saved_specification_expr
;
11703 specification_expr
= saved_specification_expr
;
11708 /* Test for non-constant shape arrays. */
11711 is_non_constant_shape_array (gfc_symbol
*sym
)
11717 not_constant
= false;
11718 if (sym
->as
!= NULL
)
11720 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11721 has not been simplified; parameter array references. Do the
11722 simplification now. */
11723 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11725 e
= sym
->as
->lower
[i
];
11726 if (e
&& (!resolve_index_expr(e
)
11727 || !gfc_is_constant_expr (e
)))
11728 not_constant
= true;
11729 e
= sym
->as
->upper
[i
];
11730 if (e
&& (!resolve_index_expr(e
)
11731 || !gfc_is_constant_expr (e
)))
11732 not_constant
= true;
11735 return not_constant
;
11738 /* Given a symbol and an initialization expression, add code to initialize
11739 the symbol to the function entry. */
11741 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11745 gfc_namespace
*ns
= sym
->ns
;
11747 /* Search for the function namespace if this is a contained
11748 function without an explicit result. */
11749 if (sym
->attr
.function
&& sym
== sym
->result
11750 && sym
->name
!= sym
->ns
->proc_name
->name
)
11752 ns
= ns
->contained
;
11753 for (;ns
; ns
= ns
->sibling
)
11754 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11760 gfc_free_expr (init
);
11764 /* Build an l-value expression for the result. */
11765 lval
= gfc_lval_expr_from_sym (sym
);
11767 /* Add the code at scope entry. */
11768 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11769 init_st
->next
= ns
->code
;
11770 ns
->code
= init_st
;
11772 /* Assign the default initializer to the l-value. */
11773 init_st
->loc
= sym
->declared_at
;
11774 init_st
->expr1
= lval
;
11775 init_st
->expr2
= init
;
11779 /* Whether or not we can generate a default initializer for a symbol. */
11782 can_generate_init (gfc_symbol
*sym
)
11784 symbol_attribute
*a
;
11789 /* These symbols should never have a default initialization. */
11794 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11795 && (CLASS_DATA (sym
)->attr
.class_pointer
11796 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11797 || a
->in_equivalence
11804 || (!a
->referenced
&& !a
->result
)
11805 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
11806 || (a
->function
&& sym
!= sym
->result
)
11811 /* Assign the default initializer to a derived type variable or result. */
11814 apply_default_init (gfc_symbol
*sym
)
11816 gfc_expr
*init
= NULL
;
11818 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11821 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11822 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11824 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11827 build_init_assign (sym
, init
);
11828 sym
->attr
.referenced
= 1;
11832 /* Build an initializer for a local. Returns null if the symbol should not have
11833 a default initialization. */
11836 build_default_init_expr (gfc_symbol
*sym
)
11838 /* These symbols should never have a default initialization. */
11839 if (sym
->attr
.allocatable
11840 || sym
->attr
.external
11842 || sym
->attr
.pointer
11843 || sym
->attr
.in_equivalence
11844 || sym
->attr
.in_common
11847 || sym
->attr
.cray_pointee
11848 || sym
->attr
.cray_pointer
11852 /* Get the appropriate init expression. */
11853 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
11856 /* Add an initialization expression to a local variable. */
11858 apply_default_init_local (gfc_symbol
*sym
)
11860 gfc_expr
*init
= NULL
;
11862 /* The symbol should be a variable or a function return value. */
11863 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11864 || (sym
->attr
.function
&& sym
->result
!= sym
))
11867 /* Try to build the initializer expression. If we can't initialize
11868 this symbol, then init will be NULL. */
11869 init
= build_default_init_expr (sym
);
11873 /* For saved variables, we don't want to add an initializer at function
11874 entry, so we just add a static initializer. Note that automatic variables
11875 are stack allocated even with -fno-automatic; we have also to exclude
11876 result variable, which are also nonstatic. */
11877 if (!sym
->attr
.automatic
11878 && (sym
->attr
.save
|| sym
->ns
->save_all
11879 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11880 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11881 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
11883 /* Don't clobber an existing initializer! */
11884 gcc_assert (sym
->value
== NULL
);
11889 build_init_assign (sym
, init
);
11893 /* Resolution of common features of flavors variable and procedure. */
11896 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11898 gfc_array_spec
*as
;
11900 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11901 as
= CLASS_DATA (sym
)->as
;
11905 /* Constraints on deferred shape variable. */
11906 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11908 bool pointer
, allocatable
, dimension
;
11910 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11912 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11913 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11914 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11918 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11919 allocatable
= sym
->attr
.allocatable
;
11920 dimension
= sym
->attr
.dimension
;
11925 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11927 gfc_error ("Allocatable array %qs at %L must have a deferred "
11928 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11931 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11932 "%qs at %L may not be ALLOCATABLE",
11933 sym
->name
, &sym
->declared_at
))
11937 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11939 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11940 "assumed rank", sym
->name
, &sym
->declared_at
);
11946 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11947 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11949 gfc_error ("Array %qs at %L cannot have a deferred shape",
11950 sym
->name
, &sym
->declared_at
);
11955 /* Constraints on polymorphic variables. */
11956 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11959 if (sym
->attr
.class_ok
11960 && !sym
->attr
.select_type_temporary
11961 && !UNLIMITED_POLY (sym
)
11962 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11964 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11965 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11966 &sym
->declared_at
);
11971 /* Assume that use associated symbols were checked in the module ns.
11972 Class-variables that are associate-names are also something special
11973 and excepted from the test. */
11974 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11976 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11977 "or pointer", sym
->name
, &sym
->declared_at
);
11986 /* Additional checks for symbols with flavor variable and derived
11987 type. To be called from resolve_fl_variable. */
11990 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11992 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11994 /* Check to see if a derived type is blocked from being host
11995 associated by the presence of another class I symbol in the same
11996 namespace. 14.6.1.3 of the standard and the discussion on
11997 comp.lang.fortran. */
11998 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11999 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12002 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12003 if (s
&& s
->attr
.generic
)
12004 s
= gfc_find_dt_in_generic (s
);
12005 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12007 gfc_error ("The type %qs cannot be host associated at %L "
12008 "because it is blocked by an incompatible object "
12009 "of the same name declared at %L",
12010 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12016 /* 4th constraint in section 11.3: "If an object of a type for which
12017 component-initialization is specified (R429) appears in the
12018 specification-part of a module and does not have the ALLOCATABLE
12019 or POINTER attribute, the object shall have the SAVE attribute."
12021 The check for initializers is performed with
12022 gfc_has_default_initializer because gfc_default_initializer generates
12023 a hidden default for allocatable components. */
12024 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12025 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12026 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12027 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12028 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12029 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12030 "%qs at %L, needed due to the default "
12031 "initialization", sym
->name
, &sym
->declared_at
))
12034 /* Assign default initializer. */
12035 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12036 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12037 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12043 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12044 except in the declaration of an entity or component that has the POINTER
12045 or ALLOCATABLE attribute. */
12048 deferred_requirements (gfc_symbol
*sym
)
12050 if (sym
->ts
.deferred
12051 && !(sym
->attr
.pointer
12052 || sym
->attr
.allocatable
12053 || sym
->attr
.associate_var
12054 || sym
->attr
.omp_udr_artificial_var
))
12056 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12057 "requires either the POINTER or ALLOCATABLE attribute",
12058 sym
->name
, &sym
->declared_at
);
12065 /* Resolve symbols with flavor variable. */
12068 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12070 int no_init_flag
, automatic_flag
;
12072 const char *auto_save_msg
;
12073 bool saved_specification_expr
;
12075 auto_save_msg
= "Automatic object %qs at %L cannot have the "
12078 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12081 /* Set this flag to check that variables are parameters of all entries.
12082 This check is effected by the call to gfc_resolve_expr through
12083 is_non_constant_shape_array. */
12084 saved_specification_expr
= specification_expr
;
12085 specification_expr
= true;
12087 if (sym
->ns
->proc_name
12088 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12089 || sym
->ns
->proc_name
->attr
.is_main_program
)
12090 && !sym
->attr
.use_assoc
12091 && !sym
->attr
.allocatable
12092 && !sym
->attr
.pointer
12093 && is_non_constant_shape_array (sym
))
12095 /* F08:C541. The shape of an array defined in a main program or module
12096 * needs to be constant. */
12097 gfc_error ("The module or main program array %qs at %L must "
12098 "have constant shape", sym
->name
, &sym
->declared_at
);
12099 specification_expr
= saved_specification_expr
;
12103 /* Constraints on deferred type parameter. */
12104 if (!deferred_requirements (sym
))
12107 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12109 /* Make sure that character string variables with assumed length are
12110 dummy arguments. */
12111 e
= sym
->ts
.u
.cl
->length
;
12112 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12113 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12114 && !sym
->attr
.omp_udr_artificial_var
)
12116 gfc_error ("Entity with assumed character length at %L must be a "
12117 "dummy argument or a PARAMETER", &sym
->declared_at
);
12118 specification_expr
= saved_specification_expr
;
12122 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12124 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12125 specification_expr
= saved_specification_expr
;
12129 if (!gfc_is_constant_expr (e
)
12130 && !(e
->expr_type
== EXPR_VARIABLE
12131 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12133 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12134 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12135 || sym
->ns
->proc_name
->attr
.is_main_program
))
12137 gfc_error ("%qs at %L must have constant character length "
12138 "in this context", sym
->name
, &sym
->declared_at
);
12139 specification_expr
= saved_specification_expr
;
12142 if (sym
->attr
.in_common
)
12144 gfc_error ("COMMON variable %qs at %L must have constant "
12145 "character length", sym
->name
, &sym
->declared_at
);
12146 specification_expr
= saved_specification_expr
;
12152 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12153 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12155 /* Determine if the symbol may not have an initializer. */
12156 no_init_flag
= automatic_flag
= 0;
12157 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12158 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12160 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12161 && is_non_constant_shape_array (sym
))
12163 no_init_flag
= automatic_flag
= 1;
12165 /* Also, they must not have the SAVE attribute.
12166 SAVE_IMPLICIT is checked below. */
12167 if (sym
->as
&& sym
->attr
.codimension
)
12169 int corank
= sym
->as
->corank
;
12170 sym
->as
->corank
= 0;
12171 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12172 sym
->as
->corank
= corank
;
12174 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12176 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12177 specification_expr
= saved_specification_expr
;
12182 /* Ensure that any initializer is simplified. */
12184 gfc_simplify_expr (sym
->value
, 1);
12186 /* Reject illegal initializers. */
12187 if (!sym
->mark
&& sym
->value
)
12189 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12190 && CLASS_DATA (sym
)->attr
.allocatable
))
12191 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12192 sym
->name
, &sym
->declared_at
);
12193 else if (sym
->attr
.external
)
12194 gfc_error ("External %qs at %L cannot have an initializer",
12195 sym
->name
, &sym
->declared_at
);
12196 else if (sym
->attr
.dummy
12197 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12198 gfc_error ("Dummy %qs at %L cannot have an initializer",
12199 sym
->name
, &sym
->declared_at
);
12200 else if (sym
->attr
.intrinsic
)
12201 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12202 sym
->name
, &sym
->declared_at
);
12203 else if (sym
->attr
.result
)
12204 gfc_error ("Function result %qs at %L cannot have an initializer",
12205 sym
->name
, &sym
->declared_at
);
12206 else if (automatic_flag
)
12207 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12208 sym
->name
, &sym
->declared_at
);
12210 goto no_init_error
;
12211 specification_expr
= saved_specification_expr
;
12216 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12218 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12219 specification_expr
= saved_specification_expr
;
12223 specification_expr
= saved_specification_expr
;
12228 /* Compare the dummy characteristics of a module procedure interface
12229 declaration with the corresponding declaration in a submodule. */
12230 static gfc_formal_arglist
*new_formal
;
12231 static char errmsg
[200];
12234 compare_fsyms (gfc_symbol
*sym
)
12238 if (sym
== NULL
|| new_formal
== NULL
)
12241 fsym
= new_formal
->sym
;
12246 if (strcmp (sym
->name
, fsym
->name
) == 0)
12248 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12249 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12254 /* Resolve a procedure. */
12257 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12259 gfc_formal_arglist
*arg
;
12261 if (sym
->attr
.function
12262 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12265 if (sym
->ts
.type
== BT_CHARACTER
)
12267 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12269 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12270 && !resolve_charlen (cl
))
12273 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12274 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12276 gfc_error ("Character-valued statement function %qs at %L must "
12277 "have constant length", sym
->name
, &sym
->declared_at
);
12282 /* Ensure that derived type for are not of a private type. Internal
12283 module procedures are excluded by 2.2.3.3 - i.e., they are not
12284 externally accessible and can access all the objects accessible in
12286 if (!(sym
->ns
->parent
12287 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12288 && gfc_check_symbol_access (sym
))
12290 gfc_interface
*iface
;
12292 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12295 && arg
->sym
->ts
.type
== BT_DERIVED
12296 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12297 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12298 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12299 "and cannot be a dummy argument"
12300 " of %qs, which is PUBLIC at %L",
12301 arg
->sym
->name
, sym
->name
,
12302 &sym
->declared_at
))
12304 /* Stop this message from recurring. */
12305 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12310 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12311 PRIVATE to the containing module. */
12312 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12314 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12317 && arg
->sym
->ts
.type
== BT_DERIVED
12318 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12319 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12320 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12321 "PUBLIC interface %qs at %L "
12322 "takes dummy arguments of %qs which "
12323 "is PRIVATE", iface
->sym
->name
,
12324 sym
->name
, &iface
->sym
->declared_at
,
12325 gfc_typename(&arg
->sym
->ts
)))
12327 /* Stop this message from recurring. */
12328 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12335 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12336 && !sym
->attr
.proc_pointer
)
12338 gfc_error ("Function %qs at %L cannot have an initializer",
12339 sym
->name
, &sym
->declared_at
);
12343 /* An external symbol may not have an initializer because it is taken to be
12344 a procedure. Exception: Procedure Pointers. */
12345 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12347 gfc_error ("External object %qs at %L may not have an initializer",
12348 sym
->name
, &sym
->declared_at
);
12352 /* An elemental function is required to return a scalar 12.7.1 */
12353 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
12355 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12356 "result", sym
->name
, &sym
->declared_at
);
12357 /* Reset so that the error only occurs once. */
12358 sym
->attr
.elemental
= 0;
12362 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12363 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12365 gfc_error ("Statement function %qs at %L may not have pointer or "
12366 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12370 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12371 char-len-param shall not be array-valued, pointer-valued, recursive
12372 or pure. ....snip... A character value of * may only be used in the
12373 following ways: (i) Dummy arg of procedure - dummy associates with
12374 actual length; (ii) To declare a named constant; or (iii) External
12375 function - but length must be declared in calling scoping unit. */
12376 if (sym
->attr
.function
12377 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12378 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12380 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12381 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12383 if (sym
->as
&& sym
->as
->rank
)
12384 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12385 "array-valued", sym
->name
, &sym
->declared_at
);
12387 if (sym
->attr
.pointer
)
12388 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12389 "pointer-valued", sym
->name
, &sym
->declared_at
);
12391 if (sym
->attr
.pure
)
12392 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12393 "pure", sym
->name
, &sym
->declared_at
);
12395 if (sym
->attr
.recursive
)
12396 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12397 "recursive", sym
->name
, &sym
->declared_at
);
12402 /* Appendix B.2 of the standard. Contained functions give an
12403 error anyway. Deferred character length is an F2003 feature.
12404 Don't warn on intrinsic conversion functions, which start
12405 with two underscores. */
12406 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12407 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12408 gfc_notify_std (GFC_STD_F95_OBS
,
12409 "CHARACTER(*) function %qs at %L",
12410 sym
->name
, &sym
->declared_at
);
12413 /* F2008, C1218. */
12414 if (sym
->attr
.elemental
)
12416 if (sym
->attr
.proc_pointer
)
12418 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12419 sym
->name
, &sym
->declared_at
);
12422 if (sym
->attr
.dummy
)
12424 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12425 sym
->name
, &sym
->declared_at
);
12430 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12432 gfc_formal_arglist
*curr_arg
;
12433 int has_non_interop_arg
= 0;
12435 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12436 sym
->common_block
))
12438 /* Clear these to prevent looking at them again if there was an
12440 sym
->attr
.is_bind_c
= 0;
12441 sym
->attr
.is_c_interop
= 0;
12442 sym
->ts
.is_c_interop
= 0;
12446 /* So far, no errors have been found. */
12447 sym
->attr
.is_c_interop
= 1;
12448 sym
->ts
.is_c_interop
= 1;
12451 curr_arg
= gfc_sym_get_dummy_args (sym
);
12452 while (curr_arg
!= NULL
)
12454 /* Skip implicitly typed dummy args here. */
12455 if (curr_arg
->sym
->attr
.implicit_type
== 0)
12456 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12457 /* If something is found to fail, record the fact so we
12458 can mark the symbol for the procedure as not being
12459 BIND(C) to try and prevent multiple errors being
12461 has_non_interop_arg
= 1;
12463 curr_arg
= curr_arg
->next
;
12466 /* See if any of the arguments were not interoperable and if so, clear
12467 the procedure symbol to prevent duplicate error messages. */
12468 if (has_non_interop_arg
!= 0)
12470 sym
->attr
.is_c_interop
= 0;
12471 sym
->ts
.is_c_interop
= 0;
12472 sym
->attr
.is_bind_c
= 0;
12476 if (!sym
->attr
.proc_pointer
)
12478 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12480 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12481 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12484 if (sym
->attr
.intent
)
12486 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12487 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12490 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12492 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12493 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12496 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12497 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12498 || sym
->attr
.contained
))
12500 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12501 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12504 if (strcmp ("ppr@", sym
->name
) == 0)
12506 gfc_error ("Procedure pointer result %qs at %L "
12507 "is missing the pointer attribute",
12508 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12513 /* Assume that a procedure whose body is not known has references
12514 to external arrays. */
12515 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12516 sym
->attr
.array_outer_dependency
= 1;
12518 /* Compare the characteristics of a module procedure with the
12519 interface declaration. Ideally this would be done with
12520 gfc_compare_interfaces but, at present, the formal interface
12521 cannot be copied to the ts.interface. */
12522 if (sym
->attr
.module_procedure
12523 && sym
->attr
.if_source
== IFSRC_DECL
)
12526 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12528 char *submodule_name
;
12529 strcpy (name
, sym
->ns
->proc_name
->name
);
12530 module_name
= strtok (name
, ".");
12531 submodule_name
= strtok (NULL
, ".");
12533 iface
= sym
->tlink
;
12536 /* Make sure that the result uses the correct charlen for deferred
12538 if (iface
&& sym
->result
12539 && iface
->ts
.type
== BT_CHARACTER
12540 && iface
->ts
.deferred
)
12541 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12546 /* Check the procedure characteristics. */
12547 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12549 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12550 "PROCEDURE at %L and its interface in %s",
12551 &sym
->declared_at
, module_name
);
12555 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12557 gfc_error ("Mismatch in PURE attribute between MODULE "
12558 "PROCEDURE at %L and its interface in %s",
12559 &sym
->declared_at
, module_name
);
12563 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12565 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12566 "PROCEDURE at %L and its interface in %s",
12567 &sym
->declared_at
, module_name
);
12571 /* Check the result characteristics. */
12572 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12574 gfc_error ("%s between the MODULE PROCEDURE declaration "
12575 "in MODULE %qs and the declaration at %L in "
12577 errmsg
, module_name
, &sym
->declared_at
,
12578 submodule_name
? submodule_name
: module_name
);
12583 /* Check the characteristics of the formal arguments. */
12584 if (sym
->formal
&& sym
->formal_ns
)
12586 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12589 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12597 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12598 been defined and we now know their defined arguments, check that they fulfill
12599 the requirements of the standard for procedures used as finalizers. */
12602 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12604 gfc_finalizer
* list
;
12605 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12606 bool result
= true;
12607 bool seen_scalar
= false;
12610 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12613 gfc_resolve_finalizers (parent
, finalizable
);
12615 /* Ensure that derived-type components have a their finalizers resolved. */
12616 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12617 for (c
= derived
->components
; c
; c
= c
->next
)
12618 if (c
->ts
.type
== BT_DERIVED
12619 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12621 bool has_final2
= false;
12622 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12623 return false; /* Error. */
12624 has_final
= has_final
|| has_final2
;
12626 /* Return early if not finalizable. */
12630 *finalizable
= false;
12634 /* Walk over the list of finalizer-procedures, check them, and if any one
12635 does not fit in with the standard's definition, print an error and remove
12636 it from the list. */
12637 prev_link
= &derived
->f2k_derived
->finalizers
;
12638 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12640 gfc_formal_arglist
*dummy_args
;
12645 /* Skip this finalizer if we already resolved it. */
12646 if (list
->proc_tree
)
12648 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12649 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
12650 seen_scalar
= true;
12651 prev_link
= &(list
->next
);
12655 /* Check this exists and is a SUBROUTINE. */
12656 if (!list
->proc_sym
->attr
.subroutine
)
12658 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12659 list
->proc_sym
->name
, &list
->where
);
12663 /* We should have exactly one argument. */
12664 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12665 if (!dummy_args
|| dummy_args
->next
)
12667 gfc_error ("FINAL procedure at %L must have exactly one argument",
12671 arg
= dummy_args
->sym
;
12673 /* This argument must be of our type. */
12674 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12676 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12677 &arg
->declared_at
, derived
->name
);
12681 /* It must neither be a pointer nor allocatable nor optional. */
12682 if (arg
->attr
.pointer
)
12684 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12685 &arg
->declared_at
);
12688 if (arg
->attr
.allocatable
)
12690 gfc_error ("Argument of FINAL procedure at %L must not be"
12691 " ALLOCATABLE", &arg
->declared_at
);
12694 if (arg
->attr
.optional
)
12696 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12697 &arg
->declared_at
);
12701 /* It must not be INTENT(OUT). */
12702 if (arg
->attr
.intent
== INTENT_OUT
)
12704 gfc_error ("Argument of FINAL procedure at %L must not be"
12705 " INTENT(OUT)", &arg
->declared_at
);
12709 /* Warn if the procedure is non-scalar and not assumed shape. */
12710 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12711 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12712 gfc_warning (OPT_Wsurprising
,
12713 "Non-scalar FINAL procedure at %L should have assumed"
12714 " shape argument", &arg
->declared_at
);
12716 /* Check that it does not match in kind and rank with a FINAL procedure
12717 defined earlier. To really loop over the *earlier* declarations,
12718 we need to walk the tail of the list as new ones were pushed at the
12720 /* TODO: Handle kind parameters once they are implemented. */
12721 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12722 for (i
= list
->next
; i
; i
= i
->next
)
12724 gfc_formal_arglist
*dummy_args
;
12726 /* Argument list might be empty; that is an error signalled earlier,
12727 but we nevertheless continued resolving. */
12728 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12731 gfc_symbol
* i_arg
= dummy_args
->sym
;
12732 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12733 if (i_rank
== my_rank
)
12735 gfc_error ("FINAL procedure %qs declared at %L has the same"
12736 " rank (%d) as %qs",
12737 list
->proc_sym
->name
, &list
->where
, my_rank
,
12738 i
->proc_sym
->name
);
12744 /* Is this the/a scalar finalizer procedure? */
12746 seen_scalar
= true;
12748 /* Find the symtree for this procedure. */
12749 gcc_assert (!list
->proc_tree
);
12750 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12752 prev_link
= &list
->next
;
12755 /* Remove wrong nodes immediately from the list so we don't risk any
12756 troubles in the future when they might fail later expectations. */
12759 *prev_link
= list
->next
;
12760 gfc_free_finalizer (i
);
12764 if (result
== false)
12767 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12768 were nodes in the list, must have been for arrays. It is surely a good
12769 idea to have a scalar version there if there's something to finalize. */
12770 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
12771 gfc_warning (OPT_Wsurprising
,
12772 "Only array FINAL procedures declared for derived type %qs"
12773 " defined at %L, suggest also scalar one",
12774 derived
->name
, &derived
->declared_at
);
12776 vtab
= gfc_find_derived_vtab (derived
);
12777 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12778 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12781 *finalizable
= true;
12787 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12790 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12791 const char* generic_name
, locus where
)
12793 gfc_symbol
*sym1
, *sym2
;
12794 const char *pass1
, *pass2
;
12795 gfc_formal_arglist
*dummy_args
;
12797 gcc_assert (t1
->specific
&& t2
->specific
);
12798 gcc_assert (!t1
->specific
->is_generic
);
12799 gcc_assert (!t2
->specific
->is_generic
);
12800 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12802 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12803 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12808 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12809 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12810 || sym1
->attr
.function
!= sym2
->attr
.function
)
12812 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12813 " GENERIC %qs at %L",
12814 sym1
->name
, sym2
->name
, generic_name
, &where
);
12818 /* Determine PASS arguments. */
12819 if (t1
->specific
->nopass
)
12821 else if (t1
->specific
->pass_arg
)
12822 pass1
= t1
->specific
->pass_arg
;
12825 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12827 pass1
= dummy_args
->sym
->name
;
12831 if (t2
->specific
->nopass
)
12833 else if (t2
->specific
->pass_arg
)
12834 pass2
= t2
->specific
->pass_arg
;
12837 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12839 pass2
= dummy_args
->sym
->name
;
12844 /* Compare the interfaces. */
12845 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12846 NULL
, 0, pass1
, pass2
))
12848 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12849 sym1
->name
, sym2
->name
, generic_name
, &where
);
12857 /* Worker function for resolving a generic procedure binding; this is used to
12858 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12860 The difference between those cases is finding possible inherited bindings
12861 that are overridden, as one has to look for them in tb_sym_root,
12862 tb_uop_root or tb_op, respectively. Thus the caller must already find
12863 the super-type and set p->overridden correctly. */
12866 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12867 gfc_typebound_proc
* p
, const char* name
)
12869 gfc_tbp_generic
* target
;
12870 gfc_symtree
* first_target
;
12871 gfc_symtree
* inherited
;
12873 gcc_assert (p
&& p
->is_generic
);
12875 /* Try to find the specific bindings for the symtrees in our target-list. */
12876 gcc_assert (p
->u
.generic
);
12877 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12878 if (!target
->specific
)
12880 gfc_typebound_proc
* overridden_tbp
;
12881 gfc_tbp_generic
* g
;
12882 const char* target_name
;
12884 target_name
= target
->specific_st
->name
;
12886 /* Defined for this type directly. */
12887 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12889 target
->specific
= target
->specific_st
->n
.tb
;
12890 goto specific_found
;
12893 /* Look for an inherited specific binding. */
12896 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12901 gcc_assert (inherited
->n
.tb
);
12902 target
->specific
= inherited
->n
.tb
;
12903 goto specific_found
;
12907 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12908 " at %L", target_name
, name
, &p
->where
);
12911 /* Once we've found the specific binding, check it is not ambiguous with
12912 other specifics already found or inherited for the same GENERIC. */
12914 gcc_assert (target
->specific
);
12916 /* This must really be a specific binding! */
12917 if (target
->specific
->is_generic
)
12919 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12920 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12924 /* Check those already resolved on this type directly. */
12925 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12926 if (g
!= target
&& g
->specific
12927 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12930 /* Check for ambiguity with inherited specific targets. */
12931 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12932 overridden_tbp
= overridden_tbp
->overridden
)
12933 if (overridden_tbp
->is_generic
)
12935 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12937 gcc_assert (g
->specific
);
12938 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12944 /* If we attempt to "overwrite" a specific binding, this is an error. */
12945 if (p
->overridden
&& !p
->overridden
->is_generic
)
12947 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12948 " the same name", name
, &p
->where
);
12952 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12953 all must have the same attributes here. */
12954 first_target
= p
->u
.generic
->specific
->u
.specific
;
12955 gcc_assert (first_target
);
12956 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12957 p
->function
= first_target
->n
.sym
->attr
.function
;
12963 /* Resolve a GENERIC procedure binding for a derived type. */
12966 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12968 gfc_symbol
* super_type
;
12970 /* Find the overridden binding if any. */
12971 st
->n
.tb
->overridden
= NULL
;
12972 super_type
= gfc_get_derived_super_type (derived
);
12975 gfc_symtree
* overridden
;
12976 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12979 if (overridden
&& overridden
->n
.tb
)
12980 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12983 /* Resolve using worker function. */
12984 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12988 /* Retrieve the target-procedure of an operator binding and do some checks in
12989 common for intrinsic and user-defined type-bound operators. */
12992 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12994 gfc_symbol
* target_proc
;
12996 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12997 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12998 gcc_assert (target_proc
);
13000 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13001 if (target
->specific
->nopass
)
13003 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
13007 return target_proc
;
13011 /* Resolve a type-bound intrinsic operator. */
13014 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13015 gfc_typebound_proc
* p
)
13017 gfc_symbol
* super_type
;
13018 gfc_tbp_generic
* target
;
13020 /* If there's already an error here, do nothing (but don't fail again). */
13024 /* Operators should always be GENERIC bindings. */
13025 gcc_assert (p
->is_generic
);
13027 /* Look for an overridden binding. */
13028 super_type
= gfc_get_derived_super_type (derived
);
13029 if (super_type
&& super_type
->f2k_derived
)
13030 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13033 p
->overridden
= NULL
;
13035 /* Resolve general GENERIC properties using worker function. */
13036 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13039 /* Check the targets to be procedures of correct interface. */
13040 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13042 gfc_symbol
* target_proc
;
13044 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13048 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13051 /* Add target to non-typebound operator list. */
13052 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13053 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13055 gfc_interface
*head
, *intr
;
13057 /* Preempt 'gfc_check_new_interface' for submodules, where the
13058 mechanism for handling module procedures winds up resolving
13059 operator interfaces twice and would otherwise cause an error. */
13060 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13061 if (intr
->sym
== target_proc
13062 && target_proc
->attr
.used_in_submodule
)
13065 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13066 target_proc
, p
->where
))
13068 head
= derived
->ns
->op
[op
];
13069 intr
= gfc_get_interface ();
13070 intr
->sym
= target_proc
;
13071 intr
->where
= p
->where
;
13073 derived
->ns
->op
[op
] = intr
;
13085 /* Resolve a type-bound user operator (tree-walker callback). */
13087 static gfc_symbol
* resolve_bindings_derived
;
13088 static bool resolve_bindings_result
;
13090 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13093 resolve_typebound_user_op (gfc_symtree
* stree
)
13095 gfc_symbol
* super_type
;
13096 gfc_tbp_generic
* target
;
13098 gcc_assert (stree
&& stree
->n
.tb
);
13100 if (stree
->n
.tb
->error
)
13103 /* Operators should always be GENERIC bindings. */
13104 gcc_assert (stree
->n
.tb
->is_generic
);
13106 /* Find overridden procedure, if any. */
13107 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13108 if (super_type
&& super_type
->f2k_derived
)
13110 gfc_symtree
* overridden
;
13111 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13112 stree
->name
, true, NULL
);
13114 if (overridden
&& overridden
->n
.tb
)
13115 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13118 stree
->n
.tb
->overridden
= NULL
;
13120 /* Resolve basically using worker function. */
13121 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13124 /* Check the targets to be functions of correct interface. */
13125 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13127 gfc_symbol
* target_proc
;
13129 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13133 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13140 resolve_bindings_result
= false;
13141 stree
->n
.tb
->error
= 1;
13145 /* Resolve the type-bound procedures for a derived type. */
13148 resolve_typebound_procedure (gfc_symtree
* stree
)
13152 gfc_symbol
* me_arg
;
13153 gfc_symbol
* super_type
;
13154 gfc_component
* comp
;
13156 gcc_assert (stree
);
13158 /* Undefined specific symbol from GENERIC target definition. */
13162 if (stree
->n
.tb
->error
)
13165 /* If this is a GENERIC binding, use that routine. */
13166 if (stree
->n
.tb
->is_generic
)
13168 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13173 /* Get the target-procedure to check it. */
13174 gcc_assert (!stree
->n
.tb
->is_generic
);
13175 gcc_assert (stree
->n
.tb
->u
.specific
);
13176 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13177 where
= stree
->n
.tb
->where
;
13179 /* Default access should already be resolved from the parser. */
13180 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13182 if (stree
->n
.tb
->deferred
)
13184 if (!check_proc_interface (proc
, &where
))
13189 /* Check for F08:C465. */
13190 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13191 || (proc
->attr
.proc
!= PROC_MODULE
13192 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13193 || proc
->attr
.abstract
)
13195 gfc_error ("%qs must be a module procedure or an external procedure with"
13196 " an explicit interface at %L", proc
->name
, &where
);
13201 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13202 stree
->n
.tb
->function
= proc
->attr
.function
;
13204 /* Find the super-type of the current derived type. We could do this once and
13205 store in a global if speed is needed, but as long as not I believe this is
13206 more readable and clearer. */
13207 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13209 /* If PASS, resolve and check arguments if not already resolved / loaded
13210 from a .mod file. */
13211 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13213 gfc_formal_arglist
*dummy_args
;
13215 dummy_args
= gfc_sym_get_dummy_args (proc
);
13216 if (stree
->n
.tb
->pass_arg
)
13218 gfc_formal_arglist
*i
;
13220 /* If an explicit passing argument name is given, walk the arg-list
13221 and look for it. */
13224 stree
->n
.tb
->pass_arg_num
= 1;
13225 for (i
= dummy_args
; i
; i
= i
->next
)
13227 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13232 ++stree
->n
.tb
->pass_arg_num
;
13237 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13239 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13240 stree
->n
.tb
->pass_arg
);
13246 /* Otherwise, take the first one; there should in fact be at least
13248 stree
->n
.tb
->pass_arg_num
= 1;
13251 gfc_error ("Procedure %qs with PASS at %L must have at"
13252 " least one argument", proc
->name
, &where
);
13255 me_arg
= dummy_args
->sym
;
13258 /* Now check that the argument-type matches and the passed-object
13259 dummy argument is generally fine. */
13261 gcc_assert (me_arg
);
13263 if (me_arg
->ts
.type
!= BT_CLASS
)
13265 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13266 " at %L", proc
->name
, &where
);
13270 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13271 != resolve_bindings_derived
)
13273 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13274 " the derived-type %qs", me_arg
->name
, proc
->name
,
13275 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13279 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13280 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13282 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13283 " scalar", proc
->name
, &where
);
13286 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13288 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13289 " be ALLOCATABLE", proc
->name
, &where
);
13292 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13294 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13295 " be POINTER", proc
->name
, &where
);
13300 /* If we are extending some type, check that we don't override a procedure
13301 flagged NON_OVERRIDABLE. */
13302 stree
->n
.tb
->overridden
= NULL
;
13305 gfc_symtree
* overridden
;
13306 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13307 stree
->name
, true, NULL
);
13311 if (overridden
->n
.tb
)
13312 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13314 if (!gfc_check_typebound_override (stree
, overridden
))
13319 /* See if there's a name collision with a component directly in this type. */
13320 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13321 if (!strcmp (comp
->name
, stree
->name
))
13323 gfc_error ("Procedure %qs at %L has the same name as a component of"
13325 stree
->name
, &where
, resolve_bindings_derived
->name
);
13329 /* Try to find a name collision with an inherited component. */
13330 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13333 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13334 " component of %qs",
13335 stree
->name
, &where
, resolve_bindings_derived
->name
);
13339 stree
->n
.tb
->error
= 0;
13343 resolve_bindings_result
= false;
13344 stree
->n
.tb
->error
= 1;
13349 resolve_typebound_procedures (gfc_symbol
* derived
)
13352 gfc_symbol
* super_type
;
13354 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13357 super_type
= gfc_get_derived_super_type (derived
);
13359 resolve_symbol (super_type
);
13361 resolve_bindings_derived
= derived
;
13362 resolve_bindings_result
= true;
13364 if (derived
->f2k_derived
->tb_sym_root
)
13365 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13366 &resolve_typebound_procedure
);
13368 if (derived
->f2k_derived
->tb_uop_root
)
13369 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13370 &resolve_typebound_user_op
);
13372 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13374 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13375 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13376 (gfc_intrinsic_op
)op
, p
))
13377 resolve_bindings_result
= false;
13380 return resolve_bindings_result
;
13384 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13385 to give all identical derived types the same backend_decl. */
13387 add_dt_to_dt_list (gfc_symbol
*derived
)
13389 gfc_dt_list
*dt_list
;
13391 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
13392 if (derived
== dt_list
->derived
)
13395 dt_list
= gfc_get_dt_list ();
13396 dt_list
->next
= gfc_derived_types
;
13397 dt_list
->derived
= derived
;
13398 gfc_derived_types
= dt_list
;
13402 /* Ensure that a derived-type is really not abstract, meaning that every
13403 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13406 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13411 if (!ensure_not_abstract_walker (sub
, st
->left
))
13413 if (!ensure_not_abstract_walker (sub
, st
->right
))
13416 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13418 gfc_symtree
* overriding
;
13419 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13422 gcc_assert (overriding
->n
.tb
);
13423 if (overriding
->n
.tb
->deferred
)
13425 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13426 " %qs is DEFERRED and not overridden",
13427 sub
->name
, &sub
->declared_at
, st
->name
);
13436 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13438 /* The algorithm used here is to recursively travel up the ancestry of sub
13439 and for each ancestor-type, check all bindings. If any of them is
13440 DEFERRED, look it up starting from sub and see if the found (overriding)
13441 binding is not DEFERRED.
13442 This is not the most efficient way to do this, but it should be ok and is
13443 clearer than something sophisticated. */
13445 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13447 if (!ancestor
->attr
.abstract
)
13450 /* Walk bindings of this ancestor. */
13451 if (ancestor
->f2k_derived
)
13454 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13459 /* Find next ancestor type and recurse on it. */
13460 ancestor
= gfc_get_derived_super_type (ancestor
);
13462 return ensure_not_abstract (sub
, ancestor
);
13468 /* This check for typebound defined assignments is done recursively
13469 since the order in which derived types are resolved is not always in
13470 order of the declarations. */
13473 check_defined_assignments (gfc_symbol
*derived
)
13477 for (c
= derived
->components
; c
; c
= c
->next
)
13479 if (!gfc_bt_struct (c
->ts
.type
)
13481 || c
->attr
.allocatable
13482 || c
->attr
.proc_pointer_comp
13483 || c
->attr
.class_pointer
13484 || c
->attr
.proc_pointer
)
13487 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13488 || (c
->ts
.u
.derived
->f2k_derived
13489 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13491 derived
->attr
.defined_assign_comp
= 1;
13495 check_defined_assignments (c
->ts
.u
.derived
);
13496 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13498 derived
->attr
.defined_assign_comp
= 1;
13505 /* Resolve a single component of a derived type or structure. */
13508 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13510 gfc_symbol
*super_type
;
13512 if (c
->attr
.artificial
)
13515 /* Do not allow vtype components to be resolved in nameless namespaces
13516 such as block data because the procedure pointers will cause ICEs
13517 and vtables are not needed in these contexts. */
13518 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13519 && sym
->ns
->proc_name
== NULL
)
13523 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13524 && c
->attr
.codimension
13525 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13527 gfc_error ("Coarray component %qs at %L must be allocatable with "
13528 "deferred shape", c
->name
, &c
->loc
);
13533 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13534 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13536 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13537 "shall not be a coarray", c
->name
, &c
->loc
);
13542 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13543 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13544 || c
->attr
.allocatable
))
13546 gfc_error ("Component %qs at %L with coarray component "
13547 "shall be a nonpointer, nonallocatable scalar",
13553 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13555 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13556 "is not an array pointer", c
->name
, &c
->loc
);
13560 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13562 gfc_symbol
*ifc
= c
->ts
.interface
;
13564 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13570 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13572 /* Resolve interface and copy attributes. */
13573 if (ifc
->formal
&& !ifc
->formal_ns
)
13574 resolve_symbol (ifc
);
13575 if (ifc
->attr
.intrinsic
)
13576 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13580 c
->ts
= ifc
->result
->ts
;
13581 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13582 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13583 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13584 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13585 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13590 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13591 c
->attr
.pointer
= ifc
->attr
.pointer
;
13592 c
->attr
.dimension
= ifc
->attr
.dimension
;
13593 c
->as
= gfc_copy_array_spec (ifc
->as
);
13594 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13596 c
->ts
.interface
= ifc
;
13597 c
->attr
.function
= ifc
->attr
.function
;
13598 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13600 c
->attr
.pure
= ifc
->attr
.pure
;
13601 c
->attr
.elemental
= ifc
->attr
.elemental
;
13602 c
->attr
.recursive
= ifc
->attr
.recursive
;
13603 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13604 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13605 /* Copy char length. */
13606 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13608 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13609 if (cl
->length
&& !cl
->resolved
13610 && !gfc_resolve_expr (cl
->length
))
13619 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13621 /* Since PPCs are not implicitly typed, a PPC without an explicit
13622 interface must be a subroutine. */
13623 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13626 /* Procedure pointer components: Check PASS arg. */
13627 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13628 && !sym
->attr
.vtype
)
13630 gfc_symbol
* me_arg
;
13632 if (c
->tb
->pass_arg
)
13634 gfc_formal_arglist
* i
;
13636 /* If an explicit passing argument name is given, walk the arg-list
13637 and look for it. */
13640 c
->tb
->pass_arg_num
= 1;
13641 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13643 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13648 c
->tb
->pass_arg_num
++;
13653 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13654 "at %L has no argument %qs", c
->name
,
13655 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13662 /* Otherwise, take the first one; there should in fact be at least
13664 c
->tb
->pass_arg_num
= 1;
13665 if (!c
->ts
.interface
->formal
)
13667 gfc_error ("Procedure pointer component %qs with PASS at %L "
13668 "must have at least one argument",
13673 me_arg
= c
->ts
.interface
->formal
->sym
;
13676 /* Now check that the argument-type matches. */
13677 gcc_assert (me_arg
);
13678 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13679 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13680 || (me_arg
->ts
.type
== BT_CLASS
13681 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13683 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13684 " the derived type %qs", me_arg
->name
, c
->name
,
13685 me_arg
->name
, &c
->loc
, sym
->name
);
13690 /* Check for C453. */
13691 if (me_arg
->attr
.dimension
)
13693 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13694 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13700 if (me_arg
->attr
.pointer
)
13702 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13703 "may not have the POINTER attribute", me_arg
->name
,
13704 c
->name
, me_arg
->name
, &c
->loc
);
13709 if (me_arg
->attr
.allocatable
)
13711 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13712 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13713 me_arg
->name
, &c
->loc
);
13718 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13720 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13721 " at %L", c
->name
, &c
->loc
);
13727 /* Check type-spec if this is not the parent-type component. */
13728 if (((sym
->attr
.is_class
13729 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13730 || c
!= sym
->components
->ts
.u
.derived
->components
))
13731 || (!sym
->attr
.is_class
13732 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13733 && !sym
->attr
.vtype
13734 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13737 super_type
= gfc_get_derived_super_type (sym
);
13739 /* If this type is an extension, set the accessibility of the parent
13742 && ((sym
->attr
.is_class
13743 && c
== sym
->components
->ts
.u
.derived
->components
)
13744 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13745 && strcmp (super_type
->name
, c
->name
) == 0)
13746 c
->attr
.access
= super_type
->attr
.access
;
13748 /* If this type is an extension, see if this component has the same name
13749 as an inherited type-bound procedure. */
13750 if (super_type
&& !sym
->attr
.is_class
13751 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13753 gfc_error ("Component %qs of %qs at %L has the same name as an"
13754 " inherited type-bound procedure",
13755 c
->name
, sym
->name
, &c
->loc
);
13759 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13760 && !c
->ts
.deferred
)
13762 if (c
->ts
.u
.cl
->length
== NULL
13763 || (!resolve_charlen(c
->ts
.u
.cl
))
13764 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13766 gfc_error ("Character length of component %qs needs to "
13767 "be a constant specification expression at %L",
13769 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13774 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13775 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13777 gfc_error ("Character component %qs of %qs at %L with deferred "
13778 "length must be a POINTER or ALLOCATABLE",
13779 c
->name
, sym
->name
, &c
->loc
);
13783 /* Add the hidden deferred length field. */
13784 if (c
->ts
.type
== BT_CHARACTER
13785 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
13786 && !c
->attr
.function
13787 && !sym
->attr
.is_class
)
13789 char name
[GFC_MAX_SYMBOL_LEN
+9];
13790 gfc_component
*strlen
;
13791 sprintf (name
, "_%s_length", c
->name
);
13792 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
13793 if (strlen
== NULL
)
13795 if (!gfc_add_component (sym
, name
, &strlen
))
13797 strlen
->ts
.type
= BT_INTEGER
;
13798 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13799 strlen
->attr
.access
= ACCESS_PRIVATE
;
13800 strlen
->attr
.artificial
= 1;
13804 if (c
->ts
.type
== BT_DERIVED
13805 && sym
->component_access
!= ACCESS_PRIVATE
13806 && gfc_check_symbol_access (sym
)
13807 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13808 && !c
->ts
.u
.derived
->attr
.use_assoc
13809 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13810 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13811 "PRIVATE type and cannot be a component of "
13812 "%qs, which is PUBLIC at %L", c
->name
,
13813 sym
->name
, &sym
->declared_at
))
13816 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13818 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13819 "type %s", c
->name
, &c
->loc
, sym
->name
);
13823 if (sym
->attr
.sequence
)
13825 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13827 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13828 "not have the SEQUENCE attribute",
13829 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13834 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13835 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13836 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13837 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13838 CLASS_DATA (c
)->ts
.u
.derived
13839 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13841 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13842 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13843 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13845 gfc_error ("The pointer component %qs of %qs at %L is a type "
13846 "that has not been declared", c
->name
, sym
->name
,
13851 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13852 && CLASS_DATA (c
)->attr
.class_pointer
13853 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13854 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13855 && !UNLIMITED_POLY (c
))
13857 gfc_error ("The pointer component %qs of %qs at %L is a type "
13858 "that has not been declared", c
->name
, sym
->name
,
13863 /* If an allocatable component derived type is of the same type as
13864 the enclosing derived type, we need a vtable generating so that
13865 the __deallocate procedure is created. */
13866 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
13867 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
13868 gfc_find_vtab (&c
->ts
);
13870 /* Ensure that all the derived type components are put on the
13871 derived type list; even in formal namespaces, where derived type
13872 pointer components might not have been declared. */
13873 if (c
->ts
.type
== BT_DERIVED
13875 && c
->ts
.u
.derived
->components
13877 && sym
!= c
->ts
.u
.derived
)
13878 add_dt_to_dt_list (c
->ts
.u
.derived
);
13880 if (!gfc_resolve_array_spec (c
->as
,
13881 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13882 || c
->attr
.allocatable
)))
13885 if (c
->initializer
&& !sym
->attr
.vtype
13886 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
13887 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13894 /* Be nice about the locus for a structure expression - show the locus of the
13895 first non-null sub-expression if we can. */
13898 cons_where (gfc_expr
*struct_expr
)
13900 gfc_constructor
*cons
;
13902 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
13904 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
13905 for (; cons
; cons
= gfc_constructor_next (cons
))
13907 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
13908 return &cons
->expr
->where
;
13911 return &struct_expr
->where
;
13914 /* Resolve the components of a structure type. Much less work than derived
13918 resolve_fl_struct (gfc_symbol
*sym
)
13921 gfc_expr
*init
= NULL
;
13924 /* Make sure UNIONs do not have overlapping initializers. */
13925 if (sym
->attr
.flavor
== FL_UNION
)
13927 for (c
= sym
->components
; c
; c
= c
->next
)
13929 if (init
&& c
->initializer
)
13931 gfc_error ("Conflicting initializers in union at %L and %L",
13932 cons_where (init
), cons_where (c
->initializer
));
13933 gfc_free_expr (c
->initializer
);
13934 c
->initializer
= NULL
;
13937 init
= c
->initializer
;
13942 for (c
= sym
->components
; c
; c
= c
->next
)
13943 if (!resolve_component (c
, sym
))
13949 if (sym
->components
)
13950 add_dt_to_dt_list (sym
);
13956 /* Resolve the components of a derived type. This does not have to wait until
13957 resolution stage, but can be done as soon as the dt declaration has been
13961 resolve_fl_derived0 (gfc_symbol
*sym
)
13963 gfc_symbol
* super_type
;
13965 gfc_formal_arglist
*f
;
13968 if (sym
->attr
.unlimited_polymorphic
)
13971 super_type
= gfc_get_derived_super_type (sym
);
13974 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
13976 gfc_error ("As extending type %qs at %L has a coarray component, "
13977 "parent type %qs shall also have one", sym
->name
,
13978 &sym
->declared_at
, super_type
->name
);
13982 /* Ensure the extended type gets resolved before we do. */
13983 if (super_type
&& !resolve_fl_derived0 (super_type
))
13986 /* An ABSTRACT type must be extensible. */
13987 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
13989 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
13990 sym
->name
, &sym
->declared_at
);
13994 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
13998 for ( ; c
!= NULL
; c
= c
->next
)
13999 if (!resolve_component (c
, sym
))
14005 /* Now add the caf token field, where needed. */
14006 if (flag_coarray
!= GFC_FCOARRAY_NONE
14007 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14009 for (c
= sym
->components
; c
; c
= c
->next
)
14010 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14011 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14013 char name
[GFC_MAX_SYMBOL_LEN
+9];
14014 gfc_component
*token
;
14015 sprintf (name
, "_caf_%s", c
->name
);
14016 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14019 if (!gfc_add_component (sym
, name
, &token
))
14021 token
->ts
.type
= BT_VOID
;
14022 token
->ts
.kind
= gfc_default_integer_kind
;
14023 token
->attr
.access
= ACCESS_PRIVATE
;
14024 token
->attr
.artificial
= 1;
14025 token
->attr
.caf_token
= 1;
14030 check_defined_assignments (sym
);
14032 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14033 sym
->attr
.defined_assign_comp
14034 = super_type
->attr
.defined_assign_comp
;
14036 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14037 all DEFERRED bindings are overridden. */
14038 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14039 && !sym
->attr
.is_class
14040 && !ensure_not_abstract (sym
, super_type
))
14043 /* Check that there is a component for every PDT parameter. */
14044 if (sym
->attr
.pdt_template
)
14046 for (f
= sym
->formal
; f
; f
= f
->next
)
14050 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14053 gfc_error ("Parameterized type %qs does not have a component "
14054 "corresponding to parameter %qs at %L", sym
->name
,
14055 f
->sym
->name
, &sym
->declared_at
);
14061 /* Add derived type to the derived type list. */
14062 add_dt_to_dt_list (sym
);
14068 /* The following procedure does the full resolution of a derived type,
14069 including resolution of all type-bound procedures (if present). In contrast
14070 to 'resolve_fl_derived0' this can only be done after the module has been
14071 parsed completely. */
14074 resolve_fl_derived (gfc_symbol
*sym
)
14076 gfc_symbol
*gen_dt
= NULL
;
14078 if (sym
->attr
.unlimited_polymorphic
)
14081 if (!sym
->attr
.is_class
)
14082 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14083 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14084 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14085 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14086 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14087 "%qs at %L being the same name as derived "
14088 "type at %L", sym
->name
,
14089 gen_dt
->generic
->sym
== sym
14090 ? gen_dt
->generic
->next
->sym
->name
14091 : gen_dt
->generic
->sym
->name
,
14092 gen_dt
->generic
->sym
== sym
14093 ? &gen_dt
->generic
->next
->sym
->declared_at
14094 : &gen_dt
->generic
->sym
->declared_at
,
14095 &sym
->declared_at
))
14098 /* Resolve the finalizer procedures. */
14099 if (!gfc_resolve_finalizers (sym
, NULL
))
14102 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14104 /* Fix up incomplete CLASS symbols. */
14105 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14106 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14108 /* Nothing more to do for unlimited polymorphic entities. */
14109 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14111 else if (vptr
->ts
.u
.derived
== NULL
)
14113 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14115 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14116 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14121 if (!resolve_fl_derived0 (sym
))
14124 /* Resolve the type-bound procedures. */
14125 if (!resolve_typebound_procedures (sym
))
14128 /* Generate module vtables subject to their accessibility and their not
14129 being vtables or pdt templates. If this is not done class declarations
14130 in external procedures wind up with their own version and so SELECT TYPE
14131 fails because the vptrs do not have the same address. */
14132 if (gfc_option
.allow_std
& GFC_STD_F2003
14133 && sym
->ns
->proc_name
14134 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14135 && sym
->attr
.access
!= ACCESS_PRIVATE
14136 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14138 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14139 gfc_set_sym_referenced (vtab
);
14147 resolve_fl_namelist (gfc_symbol
*sym
)
14152 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14154 /* Check again, the check in match only works if NAMELIST comes
14156 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14158 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14159 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14163 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14164 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14165 "with assumed shape in namelist %qs at %L",
14166 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14169 if (is_non_constant_shape_array (nl
->sym
)
14170 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14171 "with nonconstant shape in namelist %qs at %L",
14172 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14175 if (nl
->sym
->ts
.type
== BT_CHARACTER
14176 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14177 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14178 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14179 "nonconstant character length in "
14180 "namelist %qs at %L", nl
->sym
->name
,
14181 sym
->name
, &sym
->declared_at
))
14186 /* Reject PRIVATE objects in a PUBLIC namelist. */
14187 if (gfc_check_symbol_access (sym
))
14189 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14191 if (!nl
->sym
->attr
.use_assoc
14192 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14193 && !gfc_check_symbol_access (nl
->sym
))
14195 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14196 "cannot be member of PUBLIC namelist %qs at %L",
14197 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14201 if (nl
->sym
->ts
.type
== BT_DERIVED
14202 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14203 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14205 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14206 "namelist %qs at %L with ALLOCATABLE "
14207 "or POINTER components", nl
->sym
->name
,
14208 sym
->name
, &sym
->declared_at
))
14213 /* Types with private components that came here by USE-association. */
14214 if (nl
->sym
->ts
.type
== BT_DERIVED
14215 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14217 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14218 "components and cannot be member of namelist %qs at %L",
14219 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14223 /* Types with private components that are defined in the same module. */
14224 if (nl
->sym
->ts
.type
== BT_DERIVED
14225 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14226 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14228 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14229 "cannot be a member of PUBLIC namelist %qs at %L",
14230 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14237 /* 14.1.2 A module or internal procedure represent local entities
14238 of the same type as a namelist member and so are not allowed. */
14239 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14241 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14244 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14245 if ((nl
->sym
== sym
->ns
->proc_name
)
14247 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14252 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14253 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14255 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14256 "attribute in %qs at %L", nlsym
->name
,
14257 &sym
->declared_at
);
14264 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14265 nl
->sym
->attr
.asynchronous
= 1;
14272 resolve_fl_parameter (gfc_symbol
*sym
)
14274 /* A parameter array's shape needs to be constant. */
14275 if (sym
->as
!= NULL
14276 && (sym
->as
->type
== AS_DEFERRED
14277 || is_non_constant_shape_array (sym
)))
14279 gfc_error ("Parameter array %qs at %L cannot be automatic "
14280 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14284 /* Constraints on deferred type parameter. */
14285 if (!deferred_requirements (sym
))
14288 /* Make sure a parameter that has been implicitly typed still
14289 matches the implicit type, since PARAMETER statements can precede
14290 IMPLICIT statements. */
14291 if (sym
->attr
.implicit_type
14292 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14295 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14296 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14300 /* Make sure the types of derived parameters are consistent. This
14301 type checking is deferred until resolution because the type may
14302 refer to a derived type from the host. */
14303 if (sym
->ts
.type
== BT_DERIVED
14304 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14306 gfc_error ("Incompatible derived type in PARAMETER at %L",
14307 &sym
->value
->where
);
14311 /* F03:C509,C514. */
14312 if (sym
->ts
.type
== BT_CLASS
)
14314 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14315 sym
->name
, &sym
->declared_at
);
14323 /* Called by resolve_symbol to check PDTs. */
14326 resolve_pdt (gfc_symbol
* sym
)
14328 gfc_symbol
*derived
= NULL
;
14329 gfc_actual_arglist
*param
;
14331 bool const_len_exprs
= true;
14332 bool assumed_len_exprs
= false;
14333 symbol_attribute
*attr
;
14335 if (sym
->ts
.type
== BT_DERIVED
)
14337 derived
= sym
->ts
.u
.derived
;
14338 attr
= &(sym
->attr
);
14340 else if (sym
->ts
.type
== BT_CLASS
)
14342 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14343 attr
= &(CLASS_DATA (sym
)->attr
);
14346 gcc_unreachable ();
14348 gcc_assert (derived
->attr
.pdt_type
);
14350 for (param
= sym
->param_list
; param
; param
= param
->next
)
14352 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14354 if (c
->attr
.pdt_kind
)
14357 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14358 && c
->attr
.pdt_len
)
14359 const_len_exprs
= false;
14360 else if (param
->spec_type
== SPEC_ASSUMED
)
14361 assumed_len_exprs
= true;
14363 if (param
->spec_type
== SPEC_DEFERRED
14364 && !attr
->allocatable
&& !attr
->pointer
)
14365 gfc_error ("The object %qs at %L has a deferred LEN "
14366 "parameter %qs and is neither allocatable "
14367 "nor a pointer", sym
->name
, &sym
->declared_at
,
14372 if (!const_len_exprs
14373 && (sym
->ns
->proc_name
->attr
.is_main_program
14374 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14375 || sym
->attr
.save
!= SAVE_NONE
))
14376 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14377 "SAVE attribute or be a variable declared in the "
14378 "main program, a module or a submodule(F08/C513)",
14379 sym
->name
, &sym
->declared_at
);
14381 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14382 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14383 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14384 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14385 sym
->name
, &sym
->declared_at
);
14389 /* Do anything necessary to resolve a symbol. Right now, we just
14390 assume that an otherwise unknown symbol is a variable. This sort
14391 of thing commonly happens for symbols in module. */
14394 resolve_symbol (gfc_symbol
*sym
)
14396 int check_constant
, mp_flag
;
14397 gfc_symtree
*symtree
;
14398 gfc_symtree
*this_symtree
;
14401 symbol_attribute class_attr
;
14402 gfc_array_spec
*as
;
14403 bool saved_specification_expr
;
14409 /* No symbol will ever have union type; only components can be unions.
14410 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14411 (just like derived type declaration symbols have flavor FL_DERIVED). */
14412 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14414 /* Coarrayed polymorphic objects with allocatable or pointer components are
14415 yet unsupported for -fcoarray=lib. */
14416 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14417 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14418 && CLASS_DATA (sym
)->attr
.codimension
14419 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14420 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14422 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14423 "type coarrays at %L are unsupported", &sym
->declared_at
);
14427 if (sym
->attr
.artificial
)
14430 if (sym
->attr
.unlimited_polymorphic
)
14433 if (sym
->attr
.flavor
== FL_UNKNOWN
14434 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14435 && !sym
->attr
.generic
&& !sym
->attr
.external
14436 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14437 && sym
->ts
.type
== BT_UNKNOWN
))
14440 /* If we find that a flavorless symbol is an interface in one of the
14441 parent namespaces, find its symtree in this namespace, free the
14442 symbol and set the symtree to point to the interface symbol. */
14443 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14445 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14446 if (symtree
&& (symtree
->n
.sym
->generic
||
14447 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14448 && sym
->ns
->construct_entities
)))
14450 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14452 if (this_symtree
->n
.sym
== sym
)
14454 symtree
->n
.sym
->refs
++;
14455 gfc_release_symbol (sym
);
14456 this_symtree
->n
.sym
= symtree
->n
.sym
;
14462 /* Otherwise give it a flavor according to such attributes as
14464 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14465 && sym
->attr
.intrinsic
== 0)
14466 sym
->attr
.flavor
= FL_VARIABLE
;
14467 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14469 sym
->attr
.flavor
= FL_PROCEDURE
;
14470 if (sym
->attr
.dimension
)
14471 sym
->attr
.function
= 1;
14475 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14476 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14478 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14479 && !resolve_procedure_interface (sym
))
14482 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14483 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14485 if (sym
->attr
.external
)
14486 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14487 "at %L", &sym
->declared_at
);
14489 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14490 "at %L", &sym
->declared_at
);
14495 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14498 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14499 && !resolve_fl_struct (sym
))
14502 /* Symbols that are module procedures with results (functions) have
14503 the types and array specification copied for type checking in
14504 procedures that call them, as well as for saving to a module
14505 file. These symbols can't stand the scrutiny that their results
14507 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14509 /* Make sure that the intrinsic is consistent with its internal
14510 representation. This needs to be done before assigning a default
14511 type to avoid spurious warnings. */
14512 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14513 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14516 /* Resolve associate names. */
14518 resolve_assoc_var (sym
, true);
14520 /* Assign default type to symbols that need one and don't have one. */
14521 if (sym
->ts
.type
== BT_UNKNOWN
)
14523 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14525 gfc_set_default_type (sym
, 1, NULL
);
14528 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14529 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14530 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14531 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14533 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14535 /* The specific case of an external procedure should emit an error
14536 in the case that there is no implicit type. */
14539 if (!sym
->attr
.mixed_entry_master
)
14540 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14544 /* Result may be in another namespace. */
14545 resolve_symbol (sym
->result
);
14547 if (!sym
->result
->attr
.proc_pointer
)
14549 sym
->ts
= sym
->result
->ts
;
14550 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14551 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14552 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14553 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14554 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14559 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14561 bool saved_specification_expr
= specification_expr
;
14562 specification_expr
= true;
14563 gfc_resolve_array_spec (sym
->result
->as
, false);
14564 specification_expr
= saved_specification_expr
;
14567 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14569 as
= CLASS_DATA (sym
)->as
;
14570 class_attr
= CLASS_DATA (sym
)->attr
;
14571 class_attr
.pointer
= class_attr
.class_pointer
;
14575 class_attr
= sym
->attr
;
14580 if (sym
->attr
.contiguous
14581 && (!class_attr
.dimension
14582 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14583 && !class_attr
.pointer
)))
14585 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14586 "array pointer or an assumed-shape or assumed-rank array",
14587 sym
->name
, &sym
->declared_at
);
14591 /* Assumed size arrays and assumed shape arrays must be dummy
14592 arguments. Array-spec's of implied-shape should have been resolved to
14593 AS_EXPLICIT already. */
14597 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14598 specification expression. */
14599 if (as
->type
== AS_IMPLIED_SHAPE
)
14602 for (i
=0; i
<as
->rank
; i
++)
14604 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
14606 gfc_error ("Bad specification for assumed size array at %L",
14607 &as
->lower
[i
]->where
);
14614 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14615 || as
->type
== AS_ASSUMED_SHAPE
)
14616 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14618 if (as
->type
== AS_ASSUMED_SIZE
)
14619 gfc_error ("Assumed size array at %L must be a dummy argument",
14620 &sym
->declared_at
);
14622 gfc_error ("Assumed shape array at %L must be a dummy argument",
14623 &sym
->declared_at
);
14626 /* TS 29113, C535a. */
14627 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14628 && !sym
->attr
.select_type_temporary
)
14630 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14631 &sym
->declared_at
);
14634 if (as
->type
== AS_ASSUMED_RANK
14635 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14637 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14638 "CODIMENSION attribute", &sym
->declared_at
);
14643 /* Make sure symbols with known intent or optional are really dummy
14644 variable. Because of ENTRY statement, this has to be deferred
14645 until resolution time. */
14647 if (!sym
->attr
.dummy
14648 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14650 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14654 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14656 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14657 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14661 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14663 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14664 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14666 gfc_error ("Character dummy variable %qs at %L with VALUE "
14667 "attribute must have constant length",
14668 sym
->name
, &sym
->declared_at
);
14672 if (sym
->ts
.is_c_interop
14673 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14675 gfc_error ("C interoperable character dummy variable %qs at %L "
14676 "with VALUE attribute must have length one",
14677 sym
->name
, &sym
->declared_at
);
14682 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14683 && sym
->ts
.u
.derived
->attr
.generic
)
14685 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14686 if (!sym
->ts
.u
.derived
)
14688 gfc_error ("The derived type %qs at %L is of type %qs, "
14689 "which has not been defined", sym
->name
,
14690 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14691 sym
->ts
.type
= BT_UNKNOWN
;
14696 /* Use the same constraints as TYPE(*), except for the type check
14697 and that only scalars and assumed-size arrays are permitted. */
14698 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14700 if (!sym
->attr
.dummy
)
14702 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14703 "a dummy argument", sym
->name
, &sym
->declared_at
);
14707 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14708 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14709 && sym
->ts
.type
!= BT_COMPLEX
)
14711 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14712 "of type TYPE(*) or of an numeric intrinsic type",
14713 sym
->name
, &sym
->declared_at
);
14717 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14718 || sym
->attr
.pointer
|| sym
->attr
.value
)
14720 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14721 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14722 "attribute", sym
->name
, &sym
->declared_at
);
14726 if (sym
->attr
.intent
== INTENT_OUT
)
14728 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14729 "have the INTENT(OUT) attribute",
14730 sym
->name
, &sym
->declared_at
);
14733 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14735 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14736 "either be a scalar or an assumed-size array",
14737 sym
->name
, &sym
->declared_at
);
14741 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14742 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14744 sym
->ts
.type
= BT_ASSUMED
;
14745 sym
->as
= gfc_get_array_spec ();
14746 sym
->as
->type
= AS_ASSUMED_SIZE
;
14748 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14750 else if (sym
->ts
.type
== BT_ASSUMED
)
14752 /* TS 29113, C407a. */
14753 if (!sym
->attr
.dummy
)
14755 gfc_error ("Assumed type of variable %s at %L is only permitted "
14756 "for dummy variables", sym
->name
, &sym
->declared_at
);
14759 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14760 || sym
->attr
.pointer
|| sym
->attr
.value
)
14762 gfc_error ("Assumed-type variable %s at %L may not have the "
14763 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14764 sym
->name
, &sym
->declared_at
);
14767 if (sym
->attr
.intent
== INTENT_OUT
)
14769 gfc_error ("Assumed-type variable %s at %L may not have the "
14770 "INTENT(OUT) attribute",
14771 sym
->name
, &sym
->declared_at
);
14774 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14776 gfc_error ("Assumed-type variable %s at %L shall not be an "
14777 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14782 /* If the symbol is marked as bind(c), that it is declared at module level
14783 scope and verify its type and kind. Do not do the latter for symbols
14784 that are implicitly typed because that is handled in
14785 gfc_set_default_type. Handle dummy arguments and procedure definitions
14786 separately. Also, anything that is use associated is not handled here
14787 but instead is handled in the module it is declared in. Finally, derived
14788 type definitions are allowed to be BIND(C) since that only implies that
14789 they're interoperable, and they are checked fully for interoperability
14790 when a variable is declared of that type. */
14791 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
14792 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
14793 && sym
->attr
.flavor
!= FL_DERIVED
)
14797 /* First, make sure the variable is declared at the
14798 module-level scope (J3/04-007, Section 15.3). */
14799 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
14800 sym
->attr
.in_common
== 0)
14802 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14803 "is neither a COMMON block nor declared at the "
14804 "module level scope", sym
->name
, &(sym
->declared_at
));
14807 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
14809 t
= verify_com_block_vars_c_interop (sym
->common_head
);
14811 else if (sym
->attr
.implicit_type
== 0)
14813 /* If type() declaration, we need to verify that the components
14814 of the given type are all C interoperable, etc. */
14815 if (sym
->ts
.type
== BT_DERIVED
&&
14816 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
14818 /* Make sure the user marked the derived type as BIND(C). If
14819 not, call the verify routine. This could print an error
14820 for the derived type more than once if multiple variables
14821 of that type are declared. */
14822 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
14823 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
14827 /* Verify the variable itself as C interoperable if it
14828 is BIND(C). It is not possible for this to succeed if
14829 the verify_bind_c_derived_type failed, so don't have to handle
14830 any error returned by verify_bind_c_derived_type. */
14831 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
14832 sym
->common_block
);
14837 /* clear the is_bind_c flag to prevent reporting errors more than
14838 once if something failed. */
14839 sym
->attr
.is_bind_c
= 0;
14844 /* If a derived type symbol has reached this point, without its
14845 type being declared, we have an error. Notice that most
14846 conditions that produce undefined derived types have already
14847 been dealt with. However, the likes of:
14848 implicit type(t) (t) ..... call foo (t) will get us here if
14849 the type is not declared in the scope of the implicit
14850 statement. Change the type to BT_UNKNOWN, both because it is so
14851 and to prevent an ICE. */
14852 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14853 && sym
->ts
.u
.derived
->components
== NULL
14854 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14856 gfc_error ("The derived type %qs at %L is of type %qs, "
14857 "which has not been defined", sym
->name
,
14858 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14859 sym
->ts
.type
= BT_UNKNOWN
;
14863 /* Make sure that the derived type has been resolved and that the
14864 derived type is visible in the symbol's namespace, if it is a
14865 module function and is not PRIVATE. */
14866 if (sym
->ts
.type
== BT_DERIVED
14867 && sym
->ts
.u
.derived
->attr
.use_assoc
14868 && sym
->ns
->proc_name
14869 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14870 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14873 /* Unless the derived-type declaration is use associated, Fortran 95
14874 does not allow public entries of private derived types.
14875 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14876 161 in 95-006r3. */
14877 if (sym
->ts
.type
== BT_DERIVED
14878 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14879 && !sym
->ts
.u
.derived
->attr
.use_assoc
14880 && gfc_check_symbol_access (sym
)
14881 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14882 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14883 "derived type %qs",
14884 (sym
->attr
.flavor
== FL_PARAMETER
)
14885 ? "parameter" : "variable",
14886 sym
->name
, &sym
->declared_at
,
14887 sym
->ts
.u
.derived
->name
))
14890 /* F2008, C1302. */
14891 if (sym
->ts
.type
== BT_DERIVED
14892 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14893 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14894 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14895 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14897 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14898 "type LOCK_TYPE must be a coarray", sym
->name
,
14899 &sym
->declared_at
);
14903 /* TS18508, C702/C703. */
14904 if (sym
->ts
.type
== BT_DERIVED
14905 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14906 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14907 || sym
->ts
.u
.derived
->attr
.event_comp
)
14908 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14910 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14911 "type EVENT_TYPE must be a coarray", sym
->name
,
14912 &sym
->declared_at
);
14916 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14917 default initialization is defined (5.1.2.4.4). */
14918 if (sym
->ts
.type
== BT_DERIVED
14920 && sym
->attr
.intent
== INTENT_OUT
14922 && sym
->as
->type
== AS_ASSUMED_SIZE
)
14924 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
14926 if (c
->initializer
)
14928 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14929 "ASSUMED SIZE and so cannot have a default initializer",
14930 sym
->name
, &sym
->declared_at
);
14937 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14938 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
14940 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14941 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14946 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14947 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
14949 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14950 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14955 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14956 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14957 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14958 || class_attr
.codimension
)
14959 && (sym
->attr
.result
|| sym
->result
== sym
))
14961 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14962 "a coarray component", sym
->name
, &sym
->declared_at
);
14967 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
14968 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
14970 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14971 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
14976 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14977 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14978 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14979 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
14980 || class_attr
.allocatable
))
14982 gfc_error ("Variable %qs at %L with coarray component shall be a "
14983 "nonpointer, nonallocatable scalar, which is not a coarray",
14984 sym
->name
, &sym
->declared_at
);
14988 /* F2008, C526. The function-result case was handled above. */
14989 if (class_attr
.codimension
14990 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
14991 || sym
->attr
.select_type_temporary
14992 || sym
->attr
.associate_var
14993 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14994 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14995 || sym
->ns
->proc_name
->attr
.is_main_program
14996 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
14998 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14999 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15003 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15004 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15006 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15007 "deferred shape", sym
->name
, &sym
->declared_at
);
15010 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15011 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15013 gfc_error ("Allocatable coarray variable %qs at %L must have "
15014 "deferred shape", sym
->name
, &sym
->declared_at
);
15019 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15020 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15021 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15022 || (class_attr
.codimension
&& class_attr
.allocatable
))
15023 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15025 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15026 "allocatable coarray or have coarray components",
15027 sym
->name
, &sym
->declared_at
);
15031 if (class_attr
.codimension
&& sym
->attr
.dummy
15032 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15034 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15035 "procedure %qs", sym
->name
, &sym
->declared_at
,
15036 sym
->ns
->proc_name
->name
);
15040 if (sym
->ts
.type
== BT_LOGICAL
15041 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15042 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15043 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15046 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15047 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15049 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15050 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15051 "%L with non-C_Bool kind in BIND(C) procedure "
15052 "%qs", sym
->name
, &sym
->declared_at
,
15053 sym
->ns
->proc_name
->name
))
15055 else if (!gfc_logical_kinds
[i
].c_bool
15056 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15057 "%qs at %L with non-C_Bool kind in "
15058 "BIND(C) procedure %qs", sym
->name
,
15060 sym
->attr
.function
? sym
->name
15061 : sym
->ns
->proc_name
->name
))
15065 switch (sym
->attr
.flavor
)
15068 if (!resolve_fl_variable (sym
, mp_flag
))
15073 if (sym
->formal
&& !sym
->formal_ns
)
15075 /* Check that none of the arguments are a namelist. */
15076 gfc_formal_arglist
*formal
= sym
->formal
;
15078 for (; formal
; formal
= formal
->next
)
15079 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15081 gfc_error ("Namelist %qs can not be an argument to "
15082 "subroutine or function at %L",
15083 formal
->sym
->name
, &sym
->declared_at
);
15088 if (!resolve_fl_procedure (sym
, mp_flag
))
15093 if (!resolve_fl_namelist (sym
))
15098 if (!resolve_fl_parameter (sym
))
15106 /* Resolve array specifier. Check as well some constraints
15107 on COMMON blocks. */
15109 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15111 /* Set the formal_arg_flag so that check_conflict will not throw
15112 an error for host associated variables in the specification
15113 expression for an array_valued function. */
15114 if (sym
->attr
.function
&& sym
->as
)
15115 formal_arg_flag
= true;
15117 saved_specification_expr
= specification_expr
;
15118 specification_expr
= true;
15119 gfc_resolve_array_spec (sym
->as
, check_constant
);
15120 specification_expr
= saved_specification_expr
;
15122 formal_arg_flag
= false;
15124 /* Resolve formal namespaces. */
15125 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15126 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15127 gfc_resolve (sym
->formal_ns
);
15129 /* Make sure the formal namespace is present. */
15130 if (sym
->formal
&& !sym
->formal_ns
)
15132 gfc_formal_arglist
*formal
= sym
->formal
;
15133 while (formal
&& !formal
->sym
)
15134 formal
= formal
->next
;
15138 sym
->formal_ns
= formal
->sym
->ns
;
15139 if (sym
->ns
!= formal
->sym
->ns
)
15140 sym
->formal_ns
->refs
++;
15144 /* Check threadprivate restrictions. */
15145 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15146 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15147 && (!sym
->attr
.in_common
15148 && sym
->module
== NULL
15149 && (sym
->ns
->proc_name
== NULL
15150 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15151 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15153 /* Check omp declare target restrictions. */
15154 if (sym
->attr
.omp_declare_target
15155 && sym
->attr
.flavor
== FL_VARIABLE
15157 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15158 && (!sym
->attr
.in_common
15159 && sym
->module
== NULL
15160 && (sym
->ns
->proc_name
== NULL
15161 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15162 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15163 sym
->name
, &sym
->declared_at
);
15165 /* If we have come this far we can apply default-initializers, as
15166 described in 14.7.5, to those variables that have not already
15167 been assigned one. */
15168 if (sym
->ts
.type
== BT_DERIVED
15170 && !sym
->attr
.allocatable
15171 && !sym
->attr
.alloc_comp
)
15173 symbol_attribute
*a
= &sym
->attr
;
15175 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15176 && !a
->in_common
&& !a
->use_assoc
15178 && !((a
->function
|| a
->result
)
15180 || sym
->ts
.u
.derived
->attr
.alloc_comp
15181 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15182 && !(a
->function
&& sym
!= sym
->result
))
15183 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15184 apply_default_init (sym
);
15185 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15186 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15187 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15188 /* Mark the result symbol to be referenced, when it has allocatable
15190 sym
->result
->attr
.referenced
= 1;
15193 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15194 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15195 && !CLASS_DATA (sym
)->attr
.class_pointer
15196 && !CLASS_DATA (sym
)->attr
.allocatable
)
15197 apply_default_init (sym
);
15199 /* If this symbol has a type-spec, check it. */
15200 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15201 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15202 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15205 if (sym
->param_list
)
15210 /************* Resolve DATA statements *************/
15214 gfc_data_value
*vnode
;
15220 /* Advance the values structure to point to the next value in the data list. */
15223 next_data_value (void)
15225 while (mpz_cmp_ui (values
.left
, 0) == 0)
15228 if (values
.vnode
->next
== NULL
)
15231 values
.vnode
= values
.vnode
->next
;
15232 mpz_set (values
.left
, values
.vnode
->repeat
);
15240 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15246 ar_type mark
= AR_UNKNOWN
;
15248 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15254 if (!gfc_resolve_expr (var
->expr
))
15258 mpz_init_set_si (offset
, 0);
15261 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15262 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15263 e
= e
->value
.function
.actual
->expr
;
15265 if (e
->expr_type
!= EXPR_VARIABLE
)
15266 gfc_internal_error ("check_data_variable(): Bad expression");
15268 sym
= e
->symtree
->n
.sym
;
15270 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15272 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15273 sym
->name
, &sym
->declared_at
);
15276 if (e
->ref
== NULL
&& sym
->as
)
15278 gfc_error ("DATA array %qs at %L must be specified in a previous"
15279 " declaration", sym
->name
, where
);
15283 has_pointer
= sym
->attr
.pointer
;
15285 if (gfc_is_coindexed (e
))
15287 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15292 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15294 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15298 && ref
->type
== REF_ARRAY
15299 && ref
->u
.ar
.type
!= AR_FULL
)
15301 gfc_error ("DATA element %qs at %L is a pointer and so must "
15302 "be a full array", sym
->name
, where
);
15307 if (e
->rank
== 0 || has_pointer
)
15309 mpz_init_set_ui (size
, 1);
15316 /* Find the array section reference. */
15317 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15319 if (ref
->type
!= REF_ARRAY
)
15321 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15327 /* Set marks according to the reference pattern. */
15328 switch (ref
->u
.ar
.type
)
15336 /* Get the start position of array section. */
15337 gfc_get_section_index (ar
, section_index
, &offset
);
15342 gcc_unreachable ();
15345 if (!gfc_array_size (e
, &size
))
15347 gfc_error ("Nonconstant array section at %L in DATA statement",
15349 mpz_clear (offset
);
15356 while (mpz_cmp_ui (size
, 0) > 0)
15358 if (!next_data_value ())
15360 gfc_error ("DATA statement at %L has more variables than values",
15366 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15370 /* If we have more than one element left in the repeat count,
15371 and we have more than one element left in the target variable,
15372 then create a range assignment. */
15373 /* FIXME: Only done for full arrays for now, since array sections
15375 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15376 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15380 if (mpz_cmp (size
, values
.left
) >= 0)
15382 mpz_init_set (range
, values
.left
);
15383 mpz_sub (size
, size
, values
.left
);
15384 mpz_set_ui (values
.left
, 0);
15388 mpz_init_set (range
, size
);
15389 mpz_sub (values
.left
, values
.left
, size
);
15390 mpz_set_ui (size
, 0);
15393 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15396 mpz_add (offset
, offset
, range
);
15403 /* Assign initial value to symbol. */
15406 mpz_sub_ui (values
.left
, values
.left
, 1);
15407 mpz_sub_ui (size
, size
, 1);
15409 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15414 if (mark
== AR_FULL
)
15415 mpz_add_ui (offset
, offset
, 1);
15417 /* Modify the array section indexes and recalculate the offset
15418 for next element. */
15419 else if (mark
== AR_SECTION
)
15420 gfc_advance_section (section_index
, ar
, &offset
);
15424 if (mark
== AR_SECTION
)
15426 for (i
= 0; i
< ar
->dimen
; i
++)
15427 mpz_clear (section_index
[i
]);
15431 mpz_clear (offset
);
15437 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15439 /* Iterate over a list of elements in a DATA statement. */
15442 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15445 iterator_stack frame
;
15446 gfc_expr
*e
, *start
, *end
, *step
;
15447 bool retval
= true;
15449 mpz_init (frame
.value
);
15452 start
= gfc_copy_expr (var
->iter
.start
);
15453 end
= gfc_copy_expr (var
->iter
.end
);
15454 step
= gfc_copy_expr (var
->iter
.step
);
15456 if (!gfc_simplify_expr (start
, 1)
15457 || start
->expr_type
!= EXPR_CONSTANT
)
15459 gfc_error ("start of implied-do loop at %L could not be "
15460 "simplified to a constant value", &start
->where
);
15464 if (!gfc_simplify_expr (end
, 1)
15465 || end
->expr_type
!= EXPR_CONSTANT
)
15467 gfc_error ("end of implied-do loop at %L could not be "
15468 "simplified to a constant value", &start
->where
);
15472 if (!gfc_simplify_expr (step
, 1)
15473 || step
->expr_type
!= EXPR_CONSTANT
)
15475 gfc_error ("step of implied-do loop at %L could not be "
15476 "simplified to a constant value", &start
->where
);
15481 mpz_set (trip
, end
->value
.integer
);
15482 mpz_sub (trip
, trip
, start
->value
.integer
);
15483 mpz_add (trip
, trip
, step
->value
.integer
);
15485 mpz_div (trip
, trip
, step
->value
.integer
);
15487 mpz_set (frame
.value
, start
->value
.integer
);
15489 frame
.prev
= iter_stack
;
15490 frame
.variable
= var
->iter
.var
->symtree
;
15491 iter_stack
= &frame
;
15493 while (mpz_cmp_ui (trip
, 0) > 0)
15495 if (!traverse_data_var (var
->list
, where
))
15501 e
= gfc_copy_expr (var
->expr
);
15502 if (!gfc_simplify_expr (e
, 1))
15509 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15511 mpz_sub_ui (trip
, trip
, 1);
15515 mpz_clear (frame
.value
);
15518 gfc_free_expr (start
);
15519 gfc_free_expr (end
);
15520 gfc_free_expr (step
);
15522 iter_stack
= frame
.prev
;
15527 /* Type resolve variables in the variable list of a DATA statement. */
15530 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15534 for (; var
; var
= var
->next
)
15536 if (var
->expr
== NULL
)
15537 t
= traverse_data_list (var
, where
);
15539 t
= check_data_variable (var
, where
);
15549 /* Resolve the expressions and iterators associated with a data statement.
15550 This is separate from the assignment checking because data lists should
15551 only be resolved once. */
15554 resolve_data_variables (gfc_data_variable
*d
)
15556 for (; d
; d
= d
->next
)
15558 if (d
->list
== NULL
)
15560 if (!gfc_resolve_expr (d
->expr
))
15565 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15568 if (!resolve_data_variables (d
->list
))
15577 /* Resolve a single DATA statement. We implement this by storing a pointer to
15578 the value list into static variables, and then recursively traversing the
15579 variables list, expanding iterators and such. */
15582 resolve_data (gfc_data
*d
)
15585 if (!resolve_data_variables (d
->var
))
15588 values
.vnode
= d
->value
;
15589 if (d
->value
== NULL
)
15590 mpz_set_ui (values
.left
, 0);
15592 mpz_set (values
.left
, d
->value
->repeat
);
15594 if (!traverse_data_var (d
->var
, &d
->where
))
15597 /* At this point, we better not have any values left. */
15599 if (next_data_value ())
15600 gfc_error ("DATA statement at %L has more values than variables",
15605 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15606 accessed by host or use association, is a dummy argument to a pure function,
15607 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15608 is storage associated with any such variable, shall not be used in the
15609 following contexts: (clients of this function). */
15611 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15612 procedure. Returns zero if assignment is OK, nonzero if there is a
15615 gfc_impure_variable (gfc_symbol
*sym
)
15620 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15623 /* Check if the symbol's ns is inside the pure procedure. */
15624 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15628 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15632 proc
= sym
->ns
->proc_name
;
15633 if (sym
->attr
.dummy
15634 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15635 || proc
->attr
.function
))
15638 /* TODO: Sort out what can be storage associated, if anything, and include
15639 it here. In principle equivalences should be scanned but it does not
15640 seem to be possible to storage associate an impure variable this way. */
15645 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15646 current namespace is inside a pure procedure. */
15649 gfc_pure (gfc_symbol
*sym
)
15651 symbol_attribute attr
;
15656 /* Check if the current namespace or one of its parents
15657 belongs to a pure procedure. */
15658 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15660 sym
= ns
->proc_name
;
15664 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15672 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15676 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15677 checks if the current namespace is implicitly pure. Note that this
15678 function returns false for a PURE procedure. */
15681 gfc_implicit_pure (gfc_symbol
*sym
)
15687 /* Check if the current procedure is implicit_pure. Walk up
15688 the procedure list until we find a procedure. */
15689 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15691 sym
= ns
->proc_name
;
15695 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15700 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15701 && !sym
->attr
.pure
;
15706 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15712 /* Check if the current procedure is implicit_pure. Walk up
15713 the procedure list until we find a procedure. */
15714 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15716 sym
= ns
->proc_name
;
15720 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15725 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15726 sym
->attr
.implicit_pure
= 0;
15728 sym
->attr
.pure
= 0;
15732 /* Test whether the current procedure is elemental or not. */
15735 gfc_elemental (gfc_symbol
*sym
)
15737 symbol_attribute attr
;
15740 sym
= gfc_current_ns
->proc_name
;
15745 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15749 /* Warn about unused labels. */
15752 warn_unused_fortran_label (gfc_st_label
*label
)
15757 warn_unused_fortran_label (label
->left
);
15759 if (label
->defined
== ST_LABEL_UNKNOWN
)
15762 switch (label
->referenced
)
15764 case ST_LABEL_UNKNOWN
:
15765 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
15766 label
->value
, &label
->where
);
15769 case ST_LABEL_BAD_TARGET
:
15770 gfc_warning (OPT_Wunused_label
,
15771 "Label %d at %L defined but cannot be used",
15772 label
->value
, &label
->where
);
15779 warn_unused_fortran_label (label
->right
);
15783 /* Returns the sequence type of a symbol or sequence. */
15786 sequence_type (gfc_typespec ts
)
15795 if (ts
.u
.derived
->components
== NULL
)
15796 return SEQ_NONDEFAULT
;
15798 result
= sequence_type (ts
.u
.derived
->components
->ts
);
15799 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
15800 if (sequence_type (c
->ts
) != result
)
15806 if (ts
.kind
!= gfc_default_character_kind
)
15807 return SEQ_NONDEFAULT
;
15809 return SEQ_CHARACTER
;
15812 if (ts
.kind
!= gfc_default_integer_kind
)
15813 return SEQ_NONDEFAULT
;
15815 return SEQ_NUMERIC
;
15818 if (!(ts
.kind
== gfc_default_real_kind
15819 || ts
.kind
== gfc_default_double_kind
))
15820 return SEQ_NONDEFAULT
;
15822 return SEQ_NUMERIC
;
15825 if (ts
.kind
!= gfc_default_complex_kind
)
15826 return SEQ_NONDEFAULT
;
15828 return SEQ_NUMERIC
;
15831 if (ts
.kind
!= gfc_default_logical_kind
)
15832 return SEQ_NONDEFAULT
;
15834 return SEQ_NUMERIC
;
15837 return SEQ_NONDEFAULT
;
15842 /* Resolve derived type EQUIVALENCE object. */
15845 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
15847 gfc_component
*c
= derived
->components
;
15852 /* Shall not be an object of nonsequence derived type. */
15853 if (!derived
->attr
.sequence
)
15855 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15856 "attribute to be an EQUIVALENCE object", sym
->name
,
15861 /* Shall not have allocatable components. */
15862 if (derived
->attr
.alloc_comp
)
15864 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15865 "components to be an EQUIVALENCE object",sym
->name
,
15870 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
15872 gfc_error ("Derived type variable %qs at %L with default "
15873 "initialization cannot be in EQUIVALENCE with a variable "
15874 "in COMMON", sym
->name
, &e
->where
);
15878 for (; c
; c
= c
->next
)
15880 if (gfc_bt_struct (c
->ts
.type
)
15881 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15884 /* Shall not be an object of sequence derived type containing a pointer
15885 in the structure. */
15886 if (c
->attr
.pointer
)
15888 gfc_error ("Derived type variable %qs at %L with pointer "
15889 "component(s) cannot be an EQUIVALENCE object",
15890 sym
->name
, &e
->where
);
15898 /* Resolve equivalence object.
15899 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15900 an allocatable array, an object of nonsequence derived type, an object of
15901 sequence derived type containing a pointer at any level of component
15902 selection, an automatic object, a function name, an entry name, a result
15903 name, a named constant, a structure component, or a subobject of any of
15904 the preceding objects. A substring shall not have length zero. A
15905 derived type shall not have components with default initialization nor
15906 shall two objects of an equivalence group be initialized.
15907 Either all or none of the objects shall have an protected attribute.
15908 The simple constraints are done in symbol.c(check_conflict) and the rest
15909 are implemented here. */
15912 resolve_equivalence (gfc_equiv
*eq
)
15915 gfc_symbol
*first_sym
;
15918 locus
*last_where
= NULL
;
15919 seq_type eq_type
, last_eq_type
;
15920 gfc_typespec
*last_ts
;
15921 int object
, cnt_protected
;
15924 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
15926 first_sym
= eq
->expr
->symtree
->n
.sym
;
15930 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
15934 e
->ts
= e
->symtree
->n
.sym
->ts
;
15935 /* match_varspec might not know yet if it is seeing
15936 array reference or substring reference, as it doesn't
15938 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
15940 gfc_ref
*ref
= e
->ref
;
15941 sym
= e
->symtree
->n
.sym
;
15943 if (sym
->attr
.dimension
)
15945 ref
->u
.ar
.as
= sym
->as
;
15949 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15950 if (e
->ts
.type
== BT_CHARACTER
15952 && ref
->type
== REF_ARRAY
15953 && ref
->u
.ar
.dimen
== 1
15954 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
15955 && ref
->u
.ar
.stride
[0] == NULL
)
15957 gfc_expr
*start
= ref
->u
.ar
.start
[0];
15958 gfc_expr
*end
= ref
->u
.ar
.end
[0];
15961 /* Optimize away the (:) reference. */
15962 if (start
== NULL
&& end
== NULL
)
15965 e
->ref
= ref
->next
;
15967 e
->ref
->next
= ref
->next
;
15972 ref
->type
= REF_SUBSTRING
;
15974 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
15976 ref
->u
.ss
.start
= start
;
15977 if (end
== NULL
&& e
->ts
.u
.cl
)
15978 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
15979 ref
->u
.ss
.end
= end
;
15980 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
15987 /* Any further ref is an error. */
15990 gcc_assert (ref
->type
== REF_ARRAY
);
15991 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15997 if (!gfc_resolve_expr (e
))
16000 sym
= e
->symtree
->n
.sym
;
16002 if (sym
->attr
.is_protected
)
16004 if (cnt_protected
> 0 && cnt_protected
!= object
)
16006 gfc_error ("Either all or none of the objects in the "
16007 "EQUIVALENCE set at %L shall have the "
16008 "PROTECTED attribute",
16013 /* Shall not equivalence common block variables in a PURE procedure. */
16014 if (sym
->ns
->proc_name
16015 && sym
->ns
->proc_name
->attr
.pure
16016 && sym
->attr
.in_common
)
16018 /* Need to check for symbols that may have entered the pure
16019 procedure via a USE statement. */
16020 bool saw_sym
= false;
16021 if (sym
->ns
->use_stmts
)
16024 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16025 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16031 gfc_error ("COMMON block member %qs at %L cannot be an "
16032 "EQUIVALENCE object in the pure procedure %qs",
16033 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16037 /* Shall not be a named constant. */
16038 if (e
->expr_type
== EXPR_CONSTANT
)
16040 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16041 "object", sym
->name
, &e
->where
);
16045 if (e
->ts
.type
== BT_DERIVED
16046 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16049 /* Check that the types correspond correctly:
16051 A numeric sequence structure may be equivalenced to another sequence
16052 structure, an object of default integer type, default real type, double
16053 precision real type, default logical type such that components of the
16054 structure ultimately only become associated to objects of the same
16055 kind. A character sequence structure may be equivalenced to an object
16056 of default character kind or another character sequence structure.
16057 Other objects may be equivalenced only to objects of the same type and
16058 kind parameters. */
16060 /* Identical types are unconditionally OK. */
16061 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16062 goto identical_types
;
16064 last_eq_type
= sequence_type (*last_ts
);
16065 eq_type
= sequence_type (sym
->ts
);
16067 /* Since the pair of objects is not of the same type, mixed or
16068 non-default sequences can be rejected. */
16070 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16071 "statement at %L with different type objects";
16073 && last_eq_type
== SEQ_MIXED
16074 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16075 || (eq_type
== SEQ_MIXED
16076 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16079 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16080 "statement at %L with objects of different type";
16082 && last_eq_type
== SEQ_NONDEFAULT
16083 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16084 || (eq_type
== SEQ_NONDEFAULT
16085 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16088 msg
="Non-CHARACTER object %qs in default CHARACTER "
16089 "EQUIVALENCE statement at %L";
16090 if (last_eq_type
== SEQ_CHARACTER
16091 && eq_type
!= SEQ_CHARACTER
16092 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16095 msg
="Non-NUMERIC object %qs in default NUMERIC "
16096 "EQUIVALENCE statement at %L";
16097 if (last_eq_type
== SEQ_NUMERIC
16098 && eq_type
!= SEQ_NUMERIC
16099 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16104 last_where
= &e
->where
;
16109 /* Shall not be an automatic array. */
16110 if (e
->ref
->type
== REF_ARRAY
16111 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16113 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16114 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16121 /* Shall not be a structure component. */
16122 if (r
->type
== REF_COMPONENT
)
16124 gfc_error ("Structure component %qs at %L cannot be an "
16125 "EQUIVALENCE object",
16126 r
->u
.c
.component
->name
, &e
->where
);
16130 /* A substring shall not have length zero. */
16131 if (r
->type
== REF_SUBSTRING
)
16133 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16135 gfc_error ("Substring at %L has length zero",
16136 &r
->u
.ss
.start
->where
);
16146 /* Function called by resolve_fntype to flag other symbol used in the
16147 length type parameter specification of function resuls. */
16150 flag_fn_result_spec (gfc_expr
*expr
,
16151 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
16152 int *f ATTRIBUTE_UNUSED
)
16157 if (expr
->expr_type
== EXPR_VARIABLE
)
16159 s
= expr
->symtree
->n
.sym
;
16160 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16164 if (!s
->fn_result_spec
16165 && s
->attr
.flavor
== FL_PARAMETER
)
16167 /* Function contained in a module.... */
16168 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16171 s
->fn_result_spec
= 1;
16172 /* Make sure that this symbol is translated as a module
16174 st
= gfc_get_unique_symtree (ns
);
16178 /* ... which is use associated and called. */
16179 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16181 /* External function matched with an interface. */
16184 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16185 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16186 && s
->ns
->proc_name
->attr
.function
))
16187 s
->fn_result_spec
= 1;
16194 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16197 resolve_fntype (gfc_namespace
*ns
)
16199 gfc_entry_list
*el
;
16202 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16205 /* If there are any entries, ns->proc_name is the entry master
16206 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16208 sym
= ns
->entries
->sym
;
16210 sym
= ns
->proc_name
;
16211 if (sym
->result
== sym
16212 && sym
->ts
.type
== BT_UNKNOWN
16213 && !gfc_set_default_type (sym
, 0, NULL
)
16214 && !sym
->attr
.untyped
)
16216 gfc_error ("Function %qs at %L has no IMPLICIT type",
16217 sym
->name
, &sym
->declared_at
);
16218 sym
->attr
.untyped
= 1;
16221 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16222 && !sym
->attr
.contained
16223 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16224 && gfc_check_symbol_access (sym
))
16226 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16227 "%L of PRIVATE type %qs", sym
->name
,
16228 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16232 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16234 if (el
->sym
->result
== el
->sym
16235 && el
->sym
->ts
.type
== BT_UNKNOWN
16236 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16237 && !el
->sym
->attr
.untyped
)
16239 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16240 el
->sym
->name
, &el
->sym
->declared_at
);
16241 el
->sym
->attr
.untyped
= 1;
16245 if (sym
->ts
.type
== BT_CHARACTER
)
16246 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, NULL
, flag_fn_result_spec
, 0);
16250 /* 12.3.2.1.1 Defined operators. */
16253 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16255 gfc_formal_arglist
*formal
;
16257 if (!sym
->attr
.function
)
16259 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16260 sym
->name
, &where
);
16264 if (sym
->ts
.type
== BT_CHARACTER
16265 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16266 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16267 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16269 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16270 "character length", sym
->name
, &where
);
16274 formal
= gfc_sym_get_dummy_args (sym
);
16275 if (!formal
|| !formal
->sym
)
16277 gfc_error ("User operator procedure %qs at %L must have at least "
16278 "one argument", sym
->name
, &where
);
16282 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16284 gfc_error ("First argument of operator interface at %L must be "
16285 "INTENT(IN)", &where
);
16289 if (formal
->sym
->attr
.optional
)
16291 gfc_error ("First argument of operator interface at %L cannot be "
16292 "optional", &where
);
16296 formal
= formal
->next
;
16297 if (!formal
|| !formal
->sym
)
16300 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16302 gfc_error ("Second argument of operator interface at %L must be "
16303 "INTENT(IN)", &where
);
16307 if (formal
->sym
->attr
.optional
)
16309 gfc_error ("Second argument of operator interface at %L cannot be "
16310 "optional", &where
);
16316 gfc_error ("Operator interface at %L must have, at most, two "
16317 "arguments", &where
);
16325 gfc_resolve_uops (gfc_symtree
*symtree
)
16327 gfc_interface
*itr
;
16329 if (symtree
== NULL
)
16332 gfc_resolve_uops (symtree
->left
);
16333 gfc_resolve_uops (symtree
->right
);
16335 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16336 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16340 /* Examine all of the expressions associated with a program unit,
16341 assign types to all intermediate expressions, make sure that all
16342 assignments are to compatible types and figure out which names
16343 refer to which functions or subroutines. It doesn't check code
16344 block, which is handled by gfc_resolve_code. */
16347 resolve_types (gfc_namespace
*ns
)
16353 gfc_namespace
* old_ns
= gfc_current_ns
;
16355 if (ns
->types_resolved
)
16358 /* Check that all IMPLICIT types are ok. */
16359 if (!ns
->seen_implicit_none
)
16362 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16363 if (ns
->set_flag
[letter
]
16364 && !resolve_typespec_used (&ns
->default_type
[letter
],
16365 &ns
->implicit_loc
[letter
], NULL
))
16369 gfc_current_ns
= ns
;
16371 resolve_entries (ns
);
16373 resolve_common_vars (&ns
->blank_common
, false);
16374 resolve_common_blocks (ns
->common_root
);
16376 resolve_contained_functions (ns
);
16378 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16379 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16380 resolve_formal_arglist (ns
->proc_name
);
16382 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16384 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16385 resolve_charlen (cl
);
16387 gfc_traverse_ns (ns
, resolve_symbol
);
16389 resolve_fntype (ns
);
16391 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16393 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16394 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16395 "also be PURE", n
->proc_name
->name
,
16396 &n
->proc_name
->declared_at
);
16402 gfc_do_concurrent_flag
= 0;
16403 gfc_check_interfaces (ns
);
16405 gfc_traverse_ns (ns
, resolve_values
);
16411 for (d
= ns
->data
; d
; d
= d
->next
)
16415 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16417 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16419 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16420 resolve_equivalence (eq
);
16422 /* Warn about unused labels. */
16423 if (warn_unused_label
)
16424 warn_unused_fortran_label (ns
->st_labels
);
16426 gfc_resolve_uops (ns
->uop_root
);
16428 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16430 gfc_resolve_omp_declare_simd (ns
);
16432 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16434 ns
->types_resolved
= 1;
16436 gfc_current_ns
= old_ns
;
16440 /* Call gfc_resolve_code recursively. */
16443 resolve_codes (gfc_namespace
*ns
)
16446 bitmap_obstack old_obstack
;
16448 if (ns
->resolved
== 1)
16451 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16454 gfc_current_ns
= ns
;
16456 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16457 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16460 /* Set to an out of range value. */
16461 current_entry_id
= -1;
16463 old_obstack
= labels_obstack
;
16464 bitmap_obstack_initialize (&labels_obstack
);
16466 gfc_resolve_oacc_declare (ns
);
16467 gfc_resolve_omp_local_vars (ns
);
16468 gfc_resolve_code (ns
->code
, ns
);
16470 bitmap_obstack_release (&labels_obstack
);
16471 labels_obstack
= old_obstack
;
16475 /* This function is called after a complete program unit has been compiled.
16476 Its purpose is to examine all of the expressions associated with a program
16477 unit, assign types to all intermediate expressions, make sure that all
16478 assignments are to compatible types and figure out which names refer to
16479 which functions or subroutines. */
16482 gfc_resolve (gfc_namespace
*ns
)
16484 gfc_namespace
*old_ns
;
16485 code_stack
*old_cs_base
;
16486 struct gfc_omp_saved_state old_omp_state
;
16492 old_ns
= gfc_current_ns
;
16493 old_cs_base
= cs_base
;
16495 /* As gfc_resolve can be called during resolution of an OpenMP construct
16496 body, we should clear any state associated to it, so that say NS's
16497 DO loops are not interpreted as OpenMP loops. */
16498 if (!ns
->construct_entities
)
16499 gfc_omp_save_and_clear_state (&old_omp_state
);
16501 resolve_types (ns
);
16502 component_assignment_level
= 0;
16503 resolve_codes (ns
);
16505 gfc_current_ns
= old_ns
;
16506 cs_base
= old_cs_base
;
16509 gfc_run_passes (ns
);
16511 if (!ns
->construct_entities
)
16512 gfc_omp_restore_state (&old_omp_state
);