1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag
= false;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
217 sym
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
218 sym
->attr
.pointer
= ifc
->result
->attr
.pointer
;
219 sym
->attr
.dimension
= ifc
->result
->attr
.dimension
;
220 sym
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
221 sym
->as
= gfc_copy_array_spec (ifc
->result
->as
);
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
231 sym
->as
= gfc_copy_array_spec (ifc
->as
);
233 sym
->ts
.interface
= ifc
;
234 sym
->attr
.function
= ifc
->attr
.function
;
235 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
237 sym
->attr
.pure
= ifc
->attr
.pure
;
238 sym
->attr
.elemental
= ifc
->attr
.elemental
;
239 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
240 sym
->attr
.recursive
= ifc
->attr
.recursive
;
241 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
242 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
243 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
244 /* Copy char length. */
245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
247 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
248 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
249 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
268 resolve_formal_arglist (gfc_symbol
*proc
)
270 gfc_formal_arglist
*f
;
272 bool saved_specification_expr
;
275 if (proc
->result
!= NULL
)
280 if (gfc_elemental (proc
)
281 || sym
->attr
.pointer
|| sym
->attr
.allocatable
282 || (sym
->as
&& sym
->as
->rank
!= 0))
284 proc
->attr
.always_explicit
= 1;
285 sym
->attr
.always_explicit
= 1;
288 formal_arg_flag
= true;
290 for (f
= proc
->formal
; f
; f
= f
->next
)
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc
))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc
->name
,
303 if (proc
->attr
.function
)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc
->name
,
309 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
310 && !resolve_procedure_interface (sym
))
313 if (strcmp (proc
->name
, sym
->name
) == 0)
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym
->name
,
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 saved_specification_expr
= specification_expr
;
340 specification_expr
= true;
341 gfc_resolve_array_spec (as
, 0);
342 specification_expr
= saved_specification_expr
;
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
347 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
348 && ((sym
->ts
.type
!= BT_CLASS
349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
350 || (sym
->ts
.type
== BT_CLASS
351 && !(CLASS_DATA (sym
)->attr
.class_pointer
352 || CLASS_DATA (sym
)->attr
.allocatable
)))
353 && sym
->attr
.flavor
!= FL_PROCEDURE
)
355 as
->type
= AS_ASSUMED_SHAPE
;
356 for (i
= 0; i
< as
->rank
; i
++)
357 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
360 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
361 || (as
&& as
->type
== AS_ASSUMED_RANK
)
362 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
364 && (CLASS_DATA (sym
)->attr
.class_pointer
365 || CLASS_DATA (sym
)->attr
.allocatable
366 || CLASS_DATA (sym
)->attr
.target
))
367 || sym
->attr
.optional
)
369 proc
->attr
.always_explicit
= 1;
371 proc
->result
->attr
.always_explicit
= 1;
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
377 if (sym
->attr
.flavor
== FL_UNKNOWN
)
378 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
382 if (sym
->attr
.flavor
== FL_PROCEDURE
)
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym
->name
, &sym
->declared_at
);
392 else if (!sym
->attr
.pointer
)
394 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
397 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym
->name
, proc
->name
, &sym
->declared_at
);
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
407 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
410 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym
->name
,
413 proc
->name
, &sym
->declared_at
);
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym
->name
, proc
->name
,
423 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym
->name
, proc
->name
,
432 if (proc
->attr
.implicit_pure
)
434 if (sym
->attr
.flavor
== FL_PROCEDURE
)
437 proc
->attr
.implicit_pure
= 0;
439 else if (!sym
->attr
.pointer
)
441 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
443 proc
->attr
.implicit_pure
= 0;
445 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
447 proc
->attr
.implicit_pure
= 0;
451 if (gfc_elemental (proc
))
454 if (sym
->attr
.codimension
455 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->attr
.codimension
))
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym
->name
, &sym
->declared_at
);
463 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
464 && CLASS_DATA (sym
)->as
))
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym
->name
, &sym
->declared_at
);
471 if (sym
->attr
.allocatable
472 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
473 && CLASS_DATA (sym
)->attr
.allocatable
))
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym
->name
,
481 if (sym
->attr
.pointer
482 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
483 && CLASS_DATA (sym
)->attr
.class_pointer
))
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym
->name
,
491 if (sym
->attr
.flavor
== FL_PROCEDURE
)
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym
->name
, proc
->name
,
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym
->name
, proc
->name
,
510 /* Each dummy shall be specified to be scalar. */
511 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
515 gfc_error ("Argument %qs of statement function at %L must "
516 "be scalar", sym
->name
, &sym
->declared_at
);
520 if (sym
->ts
.type
== BT_CHARACTER
)
522 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
523 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
525 gfc_error ("Character-valued argument %qs of statement "
526 "function at %L must have constant length",
527 sym
->name
, &sym
->declared_at
);
533 formal_arg_flag
= false;
537 /* Work function called when searching for symbols that have argument lists
538 associated with them. */
541 find_arglists (gfc_symbol
*sym
)
543 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
544 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
547 resolve_formal_arglist (sym
);
551 /* Given a namespace, resolve all formal argument lists within the namespace.
555 resolve_formal_arglists (gfc_namespace
*ns
)
560 gfc_traverse_ns (ns
, find_arglists
);
565 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
569 if (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
571 && sym
->ns
->parent
->proc_name
572 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
573 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
574 gfc_error ("Contained procedure %qs at %L has the same name as its "
575 "encompassing procedure", sym
->name
, &sym
->declared_at
);
577 /* If this namespace is not a function or an entry master function,
579 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
580 || sym
->attr
.entry_master
)
583 /* Try to find out of what the return type is. */
584 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
586 t
= gfc_set_default_type (sym
->result
, 0, ns
);
588 if (!t
&& !sym
->result
->attr
.untyped
)
590 if (sym
->result
== sym
)
591 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
592 sym
->name
, &sym
->declared_at
);
593 else if (!sym
->result
->attr
.proc_pointer
)
594 gfc_error ("Result %qs of contained function %qs at %L has "
595 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
596 &sym
->result
->declared_at
);
597 sym
->result
->attr
.untyped
= 1;
601 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
602 type, lists the only ways a character length value of * can be used:
603 dummy arguments of procedures, named constants, and function results
604 in external functions. Internal function results and results of module
605 procedures are not on this list, ergo, not permitted. */
607 if (sym
->result
->ts
.type
== BT_CHARACTER
)
609 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
610 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
612 /* See if this is a module-procedure and adapt error message
615 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
616 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
618 gfc_error (module_proc
619 ? G_("Character-valued module procedure %qs at %L"
620 " must not be assumed length")
621 : G_("Character-valued internal function %qs at %L"
622 " must not be assumed length"),
623 sym
->name
, &sym
->declared_at
);
629 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
630 introduce duplicates. */
633 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
635 gfc_formal_arglist
*f
, *new_arglist
;
638 for (; new_args
!= NULL
; new_args
= new_args
->next
)
640 new_sym
= new_args
->sym
;
641 /* See if this arg is already in the formal argument list. */
642 for (f
= proc
->formal
; f
; f
= f
->next
)
644 if (new_sym
== f
->sym
)
651 /* Add a new argument. Argument order is not important. */
652 new_arglist
= gfc_get_formal_arglist ();
653 new_arglist
->sym
= new_sym
;
654 new_arglist
->next
= proc
->formal
;
655 proc
->formal
= new_arglist
;
660 /* Flag the arguments that are not present in all entries. */
663 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
665 gfc_formal_arglist
*f
, *head
;
668 for (f
= proc
->formal
; f
; f
= f
->next
)
673 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
675 if (new_args
->sym
== f
->sym
)
682 f
->sym
->attr
.not_always_present
= 1;
687 /* Resolve alternate entry points. If a symbol has multiple entry points we
688 create a new master symbol for the main routine, and turn the existing
689 symbol into an entry point. */
692 resolve_entries (gfc_namespace
*ns
)
694 gfc_namespace
*old_ns
;
698 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
699 static int master_count
= 0;
701 if (ns
->proc_name
== NULL
)
704 /* No need to do anything if this procedure doesn't have alternate entry
709 /* We may already have resolved alternate entry points. */
710 if (ns
->proc_name
->attr
.entry_master
)
713 /* If this isn't a procedure something has gone horribly wrong. */
714 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
716 /* Remember the current namespace. */
717 old_ns
= gfc_current_ns
;
721 /* Add the main entry point to the list of entry points. */
722 el
= gfc_get_entry_list ();
723 el
->sym
= ns
->proc_name
;
725 el
->next
= ns
->entries
;
727 ns
->proc_name
->attr
.entry
= 1;
729 /* If it is a module function, it needs to be in the right namespace
730 so that gfc_get_fake_result_decl can gather up the results. The
731 need for this arose in get_proc_name, where these beasts were
732 left in their own namespace, to keep prior references linked to
733 the entry declaration.*/
734 if (ns
->proc_name
->attr
.function
735 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
738 /* Do the same for entries where the master is not a module
739 procedure. These are retained in the module namespace because
740 of the module procedure declaration. */
741 for (el
= el
->next
; el
; el
= el
->next
)
742 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
743 && el
->sym
->attr
.mod_proc
)
747 /* Add an entry statement for it. */
748 c
= gfc_get_code (EXEC_ENTRY
);
753 /* Create a new symbol for the master function. */
754 /* Give the internal function a unique name (within this file).
755 Also include the function name so the user has some hope of figuring
756 out what is going on. */
757 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
758 master_count
++, ns
->proc_name
->name
);
759 gfc_get_ha_symbol (name
, &proc
);
760 gcc_assert (proc
!= NULL
);
762 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
763 if (ns
->proc_name
->attr
.subroutine
)
764 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
768 gfc_typespec
*ts
, *fts
;
769 gfc_array_spec
*as
, *fas
;
770 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
772 fas
= ns
->entries
->sym
->as
;
773 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
774 fts
= &ns
->entries
->sym
->result
->ts
;
775 if (fts
->type
== BT_UNKNOWN
)
776 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
777 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
779 ts
= &el
->sym
->result
->ts
;
781 as
= as
? as
: el
->sym
->result
->as
;
782 if (ts
->type
== BT_UNKNOWN
)
783 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
785 if (! gfc_compare_types (ts
, fts
)
786 || (el
->sym
->result
->attr
.dimension
787 != ns
->entries
->sym
->result
->attr
.dimension
)
788 || (el
->sym
->result
->attr
.pointer
789 != ns
->entries
->sym
->result
->attr
.pointer
))
791 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
792 && gfc_compare_array_spec (as
, fas
) == 0)
793 gfc_error ("Function %s at %L has entries with mismatched "
794 "array specifications", ns
->entries
->sym
->name
,
795 &ns
->entries
->sym
->declared_at
);
796 /* The characteristics need to match and thus both need to have
797 the same string length, i.e. both len=*, or both len=4.
798 Having both len=<variable> is also possible, but difficult to
799 check at compile time. */
800 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
801 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
802 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
804 && ts
->u
.cl
->length
->expr_type
805 != fts
->u
.cl
->length
->expr_type
)
807 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
808 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
809 fts
->u
.cl
->length
->value
.integer
) != 0)))
810 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
811 "entries returning variables of different "
812 "string lengths", ns
->entries
->sym
->name
,
813 &ns
->entries
->sym
->declared_at
);
818 sym
= ns
->entries
->sym
->result
;
819 /* All result types the same. */
821 if (sym
->attr
.dimension
)
822 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
823 if (sym
->attr
.pointer
)
824 gfc_add_pointer (&proc
->attr
, NULL
);
828 /* Otherwise the result will be passed through a union by
830 proc
->attr
.mixed_entry_master
= 1;
831 for (el
= ns
->entries
; el
; el
= el
->next
)
833 sym
= el
->sym
->result
;
834 if (sym
->attr
.dimension
)
836 if (el
== ns
->entries
)
837 gfc_error ("FUNCTION result %s can't be an array in "
838 "FUNCTION %s at %L", sym
->name
,
839 ns
->entries
->sym
->name
, &sym
->declared_at
);
841 gfc_error ("ENTRY result %s can't be an array in "
842 "FUNCTION %s at %L", sym
->name
,
843 ns
->entries
->sym
->name
, &sym
->declared_at
);
845 else if (sym
->attr
.pointer
)
847 if (el
== ns
->entries
)
848 gfc_error ("FUNCTION result %s can't be a POINTER in "
849 "FUNCTION %s at %L", sym
->name
,
850 ns
->entries
->sym
->name
, &sym
->declared_at
);
852 gfc_error ("ENTRY result %s can't be a POINTER in "
853 "FUNCTION %s at %L", sym
->name
,
854 ns
->entries
->sym
->name
, &sym
->declared_at
);
859 if (ts
->type
== BT_UNKNOWN
)
860 ts
= gfc_get_default_type (sym
->name
, NULL
);
864 if (ts
->kind
== gfc_default_integer_kind
)
868 if (ts
->kind
== gfc_default_real_kind
869 || ts
->kind
== gfc_default_double_kind
)
873 if (ts
->kind
== gfc_default_complex_kind
)
877 if (ts
->kind
== gfc_default_logical_kind
)
881 /* We will issue error elsewhere. */
889 if (el
== ns
->entries
)
890 gfc_error ("FUNCTION result %s can't be of type %s "
891 "in FUNCTION %s at %L", sym
->name
,
892 gfc_typename (ts
), ns
->entries
->sym
->name
,
895 gfc_error ("ENTRY result %s can't be of type %s "
896 "in FUNCTION %s at %L", sym
->name
,
897 gfc_typename (ts
), ns
->entries
->sym
->name
,
904 proc
->attr
.access
= ACCESS_PRIVATE
;
905 proc
->attr
.entry_master
= 1;
907 /* Merge all the entry point arguments. */
908 for (el
= ns
->entries
; el
; el
= el
->next
)
909 merge_argument_lists (proc
, el
->sym
->formal
);
911 /* Check the master formal arguments for any that are not
912 present in all entry points. */
913 for (el
= ns
->entries
; el
; el
= el
->next
)
914 check_argument_lists (proc
, el
->sym
->formal
);
916 /* Use the master function for the function body. */
917 ns
->proc_name
= proc
;
919 /* Finalize the new symbols. */
920 gfc_commit_symbols ();
922 /* Restore the original namespace. */
923 gfc_current_ns
= old_ns
;
927 /* Resolve common variables. */
929 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
931 gfc_symbol
*csym
= common_block
->head
;
933 for (; csym
; csym
= csym
->common_next
)
935 /* gfc_add_in_common may have been called before, but the reported errors
936 have been ignored to continue parsing.
937 We do the checks again here. */
938 if (!csym
->attr
.use_assoc
)
939 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
941 if (csym
->value
|| csym
->attr
.data
)
943 if (!csym
->ns
->is_block_data
)
944 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
945 "but only in BLOCK DATA initialization is "
946 "allowed", csym
->name
, &csym
->declared_at
);
947 else if (!named_common
)
948 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
949 "in a blank COMMON but initialization is only "
950 "allowed in named common blocks", csym
->name
,
954 if (UNLIMITED_POLY (csym
))
955 gfc_error_now ("%qs in cannot appear in COMMON at %L "
956 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
958 if (csym
->ts
.type
!= BT_DERIVED
)
961 if (!(csym
->ts
.u
.derived
->attr
.sequence
962 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
963 gfc_error_now ("Derived type variable %qs in COMMON at %L "
964 "has neither the SEQUENCE nor the BIND(C) "
965 "attribute", csym
->name
, &csym
->declared_at
);
966 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
967 gfc_error_now ("Derived type variable %qs in COMMON at %L "
968 "has an ultimate component that is "
969 "allocatable", csym
->name
, &csym
->declared_at
);
970 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
971 gfc_error_now ("Derived type variable %qs in COMMON at %L "
972 "may not have default initializer", csym
->name
,
975 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
976 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
980 /* Resolve common blocks. */
982 resolve_common_blocks (gfc_symtree
*common_root
)
987 if (common_root
== NULL
)
990 if (common_root
->left
)
991 resolve_common_blocks (common_root
->left
);
992 if (common_root
->right
)
993 resolve_common_blocks (common_root
->right
);
995 resolve_common_vars (common_root
->n
.common
, true);
997 /* The common name is a global name - in Fortran 2003 also if it has a
998 C binding name, since Fortran 2008 only the C binding name is a global
1000 if (!common_root
->n
.common
->binding_label
1001 || gfc_notification_std (GFC_STD_F2008
))
1003 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1004 common_root
->n
.common
->name
);
1006 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1007 && gsym
->type
== GSYM_COMMON
1008 && ((common_root
->n
.common
->binding_label
1009 && (!gsym
->binding_label
1010 || strcmp (common_root
->n
.common
->binding_label
,
1011 gsym
->binding_label
) != 0))
1012 || (!common_root
->n
.common
->binding_label
1013 && gsym
->binding_label
)))
1015 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1016 "identifier and must thus have the same binding name "
1017 "as the same-named COMMON block at %L: %s vs %s",
1018 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1020 common_root
->n
.common
->binding_label
1021 ? common_root
->n
.common
->binding_label
: "(blank)",
1022 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1026 if (gsym
&& gsym
->type
!= GSYM_COMMON
1027 && !common_root
->n
.common
->binding_label
)
1029 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1031 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1035 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1037 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1038 "%L sharing the identifier with global non-COMMON-block "
1039 "entity at %L", common_root
->n
.common
->name
,
1040 &common_root
->n
.common
->where
, &gsym
->where
);
1045 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1046 gsym
->type
= GSYM_COMMON
;
1047 gsym
->where
= common_root
->n
.common
->where
;
1053 if (common_root
->n
.common
->binding_label
)
1055 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1056 common_root
->n
.common
->binding_label
);
1057 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1059 gfc_error ("COMMON block at %L with binding label %s uses the same "
1060 "global identifier as entity at %L",
1061 &common_root
->n
.common
->where
,
1062 common_root
->n
.common
->binding_label
, &gsym
->where
);
1067 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1068 gsym
->type
= GSYM_COMMON
;
1069 gsym
->where
= common_root
->n
.common
->where
;
1075 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1079 if (sym
->attr
.flavor
== FL_PARAMETER
)
1080 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1081 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1083 if (sym
->attr
.external
)
1084 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1085 sym
->name
, &common_root
->n
.common
->where
);
1087 if (sym
->attr
.intrinsic
)
1088 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1089 sym
->name
, &common_root
->n
.common
->where
);
1090 else if (sym
->attr
.result
1091 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1092 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1093 "that is also a function result", sym
->name
,
1094 &common_root
->n
.common
->where
);
1095 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1096 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1097 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1098 "that is also a global procedure", sym
->name
,
1099 &common_root
->n
.common
->where
);
1103 /* Resolve contained function types. Because contained functions can call one
1104 another, they have to be worked out before any of the contained procedures
1107 The good news is that if a function doesn't already have a type, the only
1108 way it can get one is through an IMPLICIT type or a RESULT variable, because
1109 by definition contained functions are contained namespace they're contained
1110 in, not in a sibling or parent namespace. */
1113 resolve_contained_functions (gfc_namespace
*ns
)
1115 gfc_namespace
*child
;
1118 resolve_formal_arglists (ns
);
1120 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1122 /* Resolve alternate entry points first. */
1123 resolve_entries (child
);
1125 /* Then check function return types. */
1126 resolve_contained_fntype (child
->proc_name
, child
);
1127 for (el
= child
->entries
; el
; el
= el
->next
)
1128 resolve_contained_fntype (el
->sym
, child
);
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 in the PDT constructor "
1165 "at %C has no value");
1174 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1175 gfc_symbol
*derived
)
1177 gfc_constructor
*cons
;
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
))
1191 if (cons
->expr
->expr_type
== EXPR_STRUCTURE
1192 && comp
->ts
.type
== BT_DERIVED
)
1194 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1198 else if (comp
->ts
.type
== BT_DERIVED
)
1200 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1204 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1205 && derived
->attr
.pdt_template
)
1207 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1216 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1217 static bool resolve_fl_struct (gfc_symbol
*sym
);
1220 /* Resolve all of the elements of a structure constructor and make sure that
1221 the types are correct. The 'init' flag indicates that the given
1222 constructor is an initializer. */
1225 resolve_structure_cons (gfc_expr
*expr
, int init
)
1227 gfc_constructor
*cons
;
1228 gfc_component
*comp
;
1234 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1236 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1237 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1239 resolve_fl_struct (expr
->ts
.u
.derived
);
1241 /* If this is a Parameterized Derived Type template, find the
1242 instance corresponding to the PDT kind parameters. */
1243 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1246 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1249 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1251 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1254 gfc_free_actual_arglist (param_list
);
1256 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1261 cons
= gfc_constructor_first (expr
->value
.constructor
);
1263 /* A constructor may have references if it is the result of substituting a
1264 parameter variable. In this case we just pull out the component we
1267 comp
= expr
->ref
->u
.c
.sym
->components
;
1269 comp
= expr
->ts
.u
.derived
->components
;
1271 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1278 /* Unions use an EXPR_NULL contrived expression to tell the translation
1279 phase to generate an initializer of the appropriate length.
1281 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1284 if (!gfc_resolve_expr (cons
->expr
))
1290 rank
= comp
->as
? comp
->as
->rank
: 0;
1291 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1292 rank
= CLASS_DATA (comp
)->as
->rank
;
1294 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1295 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1297 gfc_error ("The rank of the element in the structure "
1298 "constructor at %L does not match that of the "
1299 "component (%d/%d)", &cons
->expr
->where
,
1300 cons
->expr
->rank
, rank
);
1304 /* If we don't have the right type, try to convert it. */
1306 if (!comp
->attr
.proc_pointer
&&
1307 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1309 if (strcmp (comp
->name
, "_extends") == 0)
1311 /* Can afford to be brutal with the _extends initializer.
1312 The derived type can get lost because it is PRIVATE
1313 but it is not usage constrained by the standard. */
1314 cons
->expr
->ts
= comp
->ts
;
1316 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1318 gfc_error ("The element in the structure constructor at %L, "
1319 "for pointer component %qs, is %s but should be %s",
1320 &cons
->expr
->where
, comp
->name
,
1321 gfc_basic_typename (cons
->expr
->ts
.type
),
1322 gfc_basic_typename (comp
->ts
.type
));
1327 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1333 /* For strings, the length of the constructor should be the same as
1334 the one of the structure, ensure this if the lengths are known at
1335 compile time and when we are dealing with PARAMETER or structure
1337 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1338 && comp
->ts
.u
.cl
->length
1339 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1340 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1341 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1342 && cons
->expr
->rank
!= 0
1343 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1344 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1346 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1347 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1349 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1350 to make use of the gfc_resolve_character_array_constructor
1351 machinery. The expression is later simplified away to
1352 an array of string literals. */
1353 gfc_expr
*para
= cons
->expr
;
1354 cons
->expr
= gfc_get_expr ();
1355 cons
->expr
->ts
= para
->ts
;
1356 cons
->expr
->where
= para
->where
;
1357 cons
->expr
->expr_type
= EXPR_ARRAY
;
1358 cons
->expr
->rank
= para
->rank
;
1359 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1360 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1361 para
, &cons
->expr
->where
);
1364 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1366 /* Rely on the cleanup of the namespace to deal correctly with
1367 the old charlen. (There was a block here that attempted to
1368 remove the charlen but broke the chain in so doing.) */
1369 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1370 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1371 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1372 gfc_resolve_character_array_constructor (cons
->expr
);
1376 if (cons
->expr
->expr_type
== EXPR_NULL
1377 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1378 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1379 || (comp
->ts
.type
== BT_CLASS
1380 && (CLASS_DATA (comp
)->attr
.class_pointer
1381 || CLASS_DATA (comp
)->attr
.allocatable
))))
1384 gfc_error ("The NULL in the structure constructor at %L is "
1385 "being applied to component %qs, which is neither "
1386 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1390 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1392 /* Check procedure pointer interface. */
1393 gfc_symbol
*s2
= NULL
;
1398 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1401 s2
= c2
->ts
.interface
;
1404 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1406 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1407 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1409 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1411 s2
= cons
->expr
->symtree
->n
.sym
;
1412 name
= cons
->expr
->symtree
->n
.sym
->name
;
1415 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1416 err
, sizeof (err
), NULL
, NULL
))
1418 gfc_error_opt (OPT_Wargument_mismatch
,
1419 "Interface mismatch for procedure-pointer "
1420 "component %qs in structure constructor at %L:"
1421 " %s", comp
->name
, &cons
->expr
->where
, err
);
1426 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1427 || cons
->expr
->expr_type
== EXPR_NULL
)
1430 a
= gfc_expr_attr (cons
->expr
);
1432 if (!a
.pointer
&& !a
.target
)
1435 gfc_error ("The element in the structure constructor at %L, "
1436 "for pointer component %qs should be a POINTER or "
1437 "a TARGET", &cons
->expr
->where
, comp
->name
);
1442 /* F08:C461. Additional checks for pointer initialization. */
1446 gfc_error ("Pointer initialization target at %L "
1447 "must not be ALLOCATABLE", &cons
->expr
->where
);
1452 gfc_error ("Pointer initialization target at %L "
1453 "must have the SAVE attribute", &cons
->expr
->where
);
1457 /* F2003, C1272 (3). */
1458 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1459 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1460 || gfc_is_coindexed (cons
->expr
));
1461 if (impure
&& gfc_pure (NULL
))
1464 gfc_error ("Invalid expression in the structure constructor for "
1465 "pointer component %qs at %L in PURE procedure",
1466 comp
->name
, &cons
->expr
->where
);
1470 gfc_unset_implicit_pure (NULL
);
1477 /****************** Expression name resolution ******************/
1479 /* Returns 0 if a symbol was not declared with a type or
1480 attribute declaration statement, nonzero otherwise. */
1483 was_declared (gfc_symbol
*sym
)
1489 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1492 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1493 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1494 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1495 || a
.asynchronous
|| a
.codimension
)
1502 /* Determine if a symbol is generic or not. */
1505 generic_sym (gfc_symbol
*sym
)
1509 if (sym
->attr
.generic
||
1510 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1513 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1516 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1523 return generic_sym (s
);
1530 /* Determine if a symbol is specific or not. */
1533 specific_sym (gfc_symbol
*sym
)
1537 if (sym
->attr
.if_source
== IFSRC_IFBODY
1538 || sym
->attr
.proc
== PROC_MODULE
1539 || sym
->attr
.proc
== PROC_INTERNAL
1540 || sym
->attr
.proc
== PROC_ST_FUNCTION
1541 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1542 || sym
->attr
.external
)
1545 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1548 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1550 return (s
== NULL
) ? 0 : specific_sym (s
);
1554 /* Figure out if the procedure is specific, generic or unknown. */
1557 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1560 procedure_kind (gfc_symbol
*sym
)
1562 if (generic_sym (sym
))
1563 return PTYPE_GENERIC
;
1565 if (specific_sym (sym
))
1566 return PTYPE_SPECIFIC
;
1568 return PTYPE_UNKNOWN
;
1571 /* Check references to assumed size arrays. The flag need_full_assumed_size
1572 is nonzero when matching actual arguments. */
1574 static int need_full_assumed_size
= 0;
1577 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1579 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1582 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1583 What should it be? */
1584 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1585 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1586 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1588 gfc_error ("The upper bound in the last dimension must "
1589 "appear in the reference to the assumed size "
1590 "array %qs at %L", sym
->name
, &e
->where
);
1597 /* Look for bad assumed size array references in argument expressions
1598 of elemental and array valued intrinsic procedures. Since this is
1599 called from procedure resolution functions, it only recurses at
1603 resolve_assumed_size_actual (gfc_expr
*e
)
1608 switch (e
->expr_type
)
1611 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1616 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1617 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1628 /* Check a generic procedure, passed as an actual argument, to see if
1629 there is a matching specific name. If none, it is an error, and if
1630 more than one, the reference is ambiguous. */
1632 count_specific_procs (gfc_expr
*e
)
1639 sym
= e
->symtree
->n
.sym
;
1641 for (p
= sym
->generic
; p
; p
= p
->next
)
1642 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1644 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1650 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1654 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1655 "argument at %L", sym
->name
, &e
->where
);
1661 /* See if a call to sym could possibly be a not allowed RECURSION because of
1662 a missing RECURSIVE declaration. This means that either sym is the current
1663 context itself, or sym is the parent of a contained procedure calling its
1664 non-RECURSIVE containing procedure.
1665 This also works if sym is an ENTRY. */
1668 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1670 gfc_symbol
* proc_sym
;
1671 gfc_symbol
* context_proc
;
1672 gfc_namespace
* real_context
;
1674 if (sym
->attr
.flavor
== FL_PROGRAM
1675 || gfc_fl_struct (sym
->attr
.flavor
))
1678 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1680 /* If we've got an ENTRY, find real procedure. */
1681 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1682 proc_sym
= sym
->ns
->entries
->sym
;
1686 /* If sym is RECURSIVE, all is well of course. */
1687 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1690 /* Find the context procedure's "real" symbol if it has entries.
1691 We look for a procedure symbol, so recurse on the parents if we don't
1692 find one (like in case of a BLOCK construct). */
1693 for (real_context
= context
; ; real_context
= real_context
->parent
)
1695 /* We should find something, eventually! */
1696 gcc_assert (real_context
);
1698 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1699 : real_context
->proc_name
);
1701 /* In some special cases, there may not be a proc_name, like for this
1703 real(bad_kind()) function foo () ...
1704 when checking the call to bad_kind ().
1705 In these cases, we simply return here and assume that the
1710 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1714 /* A call from sym's body to itself is recursion, of course. */
1715 if (context_proc
== proc_sym
)
1718 /* The same is true if context is a contained procedure and sym the
1720 if (context_proc
->attr
.contained
)
1722 gfc_symbol
* parent_proc
;
1724 gcc_assert (context
->parent
);
1725 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1726 : context
->parent
->proc_name
);
1728 if (parent_proc
== proc_sym
)
1736 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1737 its typespec and formal argument list. */
1740 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1742 gfc_intrinsic_sym
* isym
= NULL
;
1748 /* Already resolved. */
1749 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1752 /* We already know this one is an intrinsic, so we don't call
1753 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1754 gfc_find_subroutine directly to check whether it is a function or
1757 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1759 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1760 isym
= gfc_intrinsic_subroutine_by_id (id
);
1762 else if (sym
->intmod_sym_id
)
1764 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1765 isym
= gfc_intrinsic_function_by_id (id
);
1767 else if (!sym
->attr
.subroutine
)
1768 isym
= gfc_find_function (sym
->name
);
1770 if (isym
&& !sym
->attr
.subroutine
)
1772 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1773 && !sym
->attr
.implicit_type
)
1774 gfc_warning (OPT_Wsurprising
,
1775 "Type specified for intrinsic function %qs at %L is"
1776 " ignored", sym
->name
, &sym
->declared_at
);
1778 if (!sym
->attr
.function
&&
1779 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1784 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1786 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1788 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1789 " specifier", sym
->name
, &sym
->declared_at
);
1793 if (!sym
->attr
.subroutine
&&
1794 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1799 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1804 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1806 sym
->attr
.pure
= isym
->pure
;
1807 sym
->attr
.elemental
= isym
->elemental
;
1809 /* Check it is actually available in the standard settings. */
1810 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1812 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1813 "available in the current standard settings but %s. Use "
1814 "an appropriate %<-std=*%> option or enable "
1815 "%<-fall-intrinsics%> in order to use it.",
1816 sym
->name
, &sym
->declared_at
, symstd
);
1824 /* Resolve a procedure expression, like passing it to a called procedure or as
1825 RHS for a procedure pointer assignment. */
1828 resolve_procedure_expression (gfc_expr
* expr
)
1832 if (expr
->expr_type
!= EXPR_VARIABLE
)
1834 gcc_assert (expr
->symtree
);
1836 sym
= expr
->symtree
->n
.sym
;
1838 if (sym
->attr
.intrinsic
)
1839 gfc_resolve_intrinsic (sym
, &expr
->where
);
1841 if (sym
->attr
.flavor
!= FL_PROCEDURE
1842 || (sym
->attr
.function
&& sym
->result
== sym
))
1845 /* A non-RECURSIVE procedure that is used as procedure expression within its
1846 own body is in danger of being called recursively. */
1847 if (is_illegal_recursion (sym
, gfc_current_ns
))
1848 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1849 " itself recursively. Declare it RECURSIVE or use"
1850 " %<-frecursive%>", sym
->name
, &expr
->where
);
1856 /* Resolve an actual argument list. Most of the time, this is just
1857 resolving the expressions in the list.
1858 The exception is that we sometimes have to decide whether arguments
1859 that look like procedure arguments are really simple variable
1863 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1864 bool no_formal_args
)
1867 gfc_symtree
*parent_st
;
1869 gfc_component
*comp
;
1870 int save_need_full_assumed_size
;
1871 bool return_value
= false;
1872 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1875 first_actual_arg
= true;
1877 for (; arg
; arg
= arg
->next
)
1882 /* Check the label is a valid branching target. */
1885 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1887 gfc_error ("Label %d referenced at %L is never defined",
1888 arg
->label
->value
, &arg
->label
->where
);
1892 first_actual_arg
= false;
1896 if (e
->expr_type
== EXPR_VARIABLE
1897 && e
->symtree
->n
.sym
->attr
.generic
1899 && count_specific_procs (e
) != 1)
1902 if (e
->ts
.type
!= BT_PROCEDURE
)
1904 save_need_full_assumed_size
= need_full_assumed_size
;
1905 if (e
->expr_type
!= EXPR_VARIABLE
)
1906 need_full_assumed_size
= 0;
1907 if (!gfc_resolve_expr (e
))
1909 need_full_assumed_size
= save_need_full_assumed_size
;
1913 /* See if the expression node should really be a variable reference. */
1915 sym
= e
->symtree
->n
.sym
;
1917 if (sym
->attr
.flavor
== FL_PROCEDURE
1918 || sym
->attr
.intrinsic
1919 || sym
->attr
.external
)
1923 /* If a procedure is not already determined to be something else
1924 check if it is intrinsic. */
1925 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1926 sym
->attr
.intrinsic
= 1;
1928 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1930 gfc_error ("Statement function %qs at %L is not allowed as an "
1931 "actual argument", sym
->name
, &e
->where
);
1934 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1935 sym
->attr
.subroutine
);
1936 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1938 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1939 "actual argument", sym
->name
, &e
->where
);
1942 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1943 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1945 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1946 " used as actual argument at %L",
1947 sym
->name
, &e
->where
))
1951 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1953 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1954 "allowed as an actual argument at %L", sym
->name
,
1958 /* Check if a generic interface has a specific procedure
1959 with the same name before emitting an error. */
1960 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1963 /* Just in case a specific was found for the expression. */
1964 sym
= e
->symtree
->n
.sym
;
1966 /* If the symbol is the function that names the current (or
1967 parent) scope, then we really have a variable reference. */
1969 if (gfc_is_function_return_value (sym
, sym
->ns
))
1972 /* If all else fails, see if we have a specific intrinsic. */
1973 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1975 gfc_intrinsic_sym
*isym
;
1977 isym
= gfc_find_function (sym
->name
);
1978 if (isym
== NULL
|| !isym
->specific
)
1980 gfc_error ("Unable to find a specific INTRINSIC procedure "
1981 "for the reference %qs at %L", sym
->name
,
1986 sym
->attr
.intrinsic
= 1;
1987 sym
->attr
.function
= 1;
1990 if (!gfc_resolve_expr (e
))
1995 /* See if the name is a module procedure in a parent unit. */
1997 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2000 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2002 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2006 if (parent_st
== NULL
)
2009 sym
= parent_st
->n
.sym
;
2010 e
->symtree
= parent_st
; /* Point to the right thing. */
2012 if (sym
->attr
.flavor
== FL_PROCEDURE
2013 || sym
->attr
.intrinsic
2014 || sym
->attr
.external
)
2016 if (!gfc_resolve_expr (e
))
2022 e
->expr_type
= EXPR_VARIABLE
;
2024 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2025 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2026 && CLASS_DATA (sym
)->as
))
2028 e
->rank
= sym
->ts
.type
== BT_CLASS
2029 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2030 e
->ref
= gfc_get_ref ();
2031 e
->ref
->type
= REF_ARRAY
;
2032 e
->ref
->u
.ar
.type
= AR_FULL
;
2033 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2034 ? CLASS_DATA (sym
)->as
: sym
->as
;
2037 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2038 primary.c (match_actual_arg). If above code determines that it
2039 is a variable instead, it needs to be resolved as it was not
2040 done at the beginning of this function. */
2041 save_need_full_assumed_size
= need_full_assumed_size
;
2042 if (e
->expr_type
!= EXPR_VARIABLE
)
2043 need_full_assumed_size
= 0;
2044 if (!gfc_resolve_expr (e
))
2046 need_full_assumed_size
= save_need_full_assumed_size
;
2049 /* Check argument list functions %VAL, %LOC and %REF. There is
2050 nothing to do for %REF. */
2051 if (arg
->name
&& arg
->name
[0] == '%')
2053 if (strncmp ("%VAL", arg
->name
, 4) == 0)
2055 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2057 gfc_error ("By-value argument at %L is not of numeric "
2064 gfc_error ("By-value argument at %L cannot be an array or "
2065 "an array section", &e
->where
);
2069 /* Intrinsics are still PROC_UNKNOWN here. However,
2070 since same file external procedures are not resolvable
2071 in gfortran, it is a good deal easier to leave them to
2073 if (ptype
!= PROC_UNKNOWN
2074 && ptype
!= PROC_DUMMY
2075 && ptype
!= PROC_EXTERNAL
2076 && ptype
!= PROC_MODULE
)
2078 gfc_error ("By-value argument at %L is not allowed "
2079 "in this context", &e
->where
);
2084 /* Statement functions have already been excluded above. */
2085 else if (strncmp ("%LOC", arg
->name
, 4) == 0
2086 && e
->ts
.type
== BT_PROCEDURE
)
2088 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2090 gfc_error ("Passing internal procedure at %L by location "
2091 "not allowed", &e
->where
);
2097 comp
= gfc_get_proc_ptr_comp(e
);
2098 if (e
->expr_type
== EXPR_VARIABLE
2099 && comp
&& comp
->attr
.elemental
)
2101 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2102 "allowed as an actual argument at %L", comp
->name
,
2106 /* Fortran 2008, C1237. */
2107 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2108 && gfc_has_ultimate_pointer (e
))
2110 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2111 "component", &e
->where
);
2115 first_actual_arg
= false;
2118 return_value
= true;
2121 actual_arg
= actual_arg_sav
;
2122 first_actual_arg
= first_actual_arg_sav
;
2124 return return_value
;
2128 /* Do the checks of the actual argument list that are specific to elemental
2129 procedures. If called with c == NULL, we have a function, otherwise if
2130 expr == NULL, we have a subroutine. */
2133 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2135 gfc_actual_arglist
*arg0
;
2136 gfc_actual_arglist
*arg
;
2137 gfc_symbol
*esym
= NULL
;
2138 gfc_intrinsic_sym
*isym
= NULL
;
2140 gfc_intrinsic_arg
*iformal
= NULL
;
2141 gfc_formal_arglist
*eformal
= NULL
;
2142 bool formal_optional
= false;
2143 bool set_by_optional
= false;
2147 /* Is this an elemental procedure? */
2148 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2150 if (expr
->value
.function
.esym
!= NULL
2151 && expr
->value
.function
.esym
->attr
.elemental
)
2153 arg0
= expr
->value
.function
.actual
;
2154 esym
= expr
->value
.function
.esym
;
2156 else if (expr
->value
.function
.isym
!= NULL
2157 && expr
->value
.function
.isym
->elemental
)
2159 arg0
= expr
->value
.function
.actual
;
2160 isym
= expr
->value
.function
.isym
;
2165 else if (c
&& c
->ext
.actual
!= NULL
)
2167 arg0
= c
->ext
.actual
;
2169 if (c
->resolved_sym
)
2170 esym
= c
->resolved_sym
;
2172 esym
= c
->symtree
->n
.sym
;
2175 if (!esym
->attr
.elemental
)
2181 /* The rank of an elemental is the rank of its array argument(s). */
2182 for (arg
= arg0
; arg
; arg
= arg
->next
)
2184 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2186 rank
= arg
->expr
->rank
;
2187 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2188 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2189 set_by_optional
= true;
2191 /* Function specific; set the result rank and shape. */
2195 if (!expr
->shape
&& arg
->expr
->shape
)
2197 expr
->shape
= gfc_get_shape (rank
);
2198 for (i
= 0; i
< rank
; i
++)
2199 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2206 /* If it is an array, it shall not be supplied as an actual argument
2207 to an elemental procedure unless an array of the same rank is supplied
2208 as an actual argument corresponding to a nonoptional dummy argument of
2209 that elemental procedure(12.4.1.5). */
2210 formal_optional
= false;
2212 iformal
= isym
->formal
;
2214 eformal
= esym
->formal
;
2216 for (arg
= arg0
; arg
; arg
= arg
->next
)
2220 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2221 formal_optional
= true;
2222 eformal
= eformal
->next
;
2224 else if (isym
&& iformal
)
2226 if (iformal
->optional
)
2227 formal_optional
= true;
2228 iformal
= iformal
->next
;
2231 formal_optional
= true;
2233 if (pedantic
&& arg
->expr
!= NULL
2234 && arg
->expr
->expr_type
== EXPR_VARIABLE
2235 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2238 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2239 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2241 gfc_warning (OPT_Wpedantic
,
2242 "%qs at %L is an array and OPTIONAL; IF IT IS "
2243 "MISSING, it cannot be the actual argument of an "
2244 "ELEMENTAL procedure unless there is a non-optional "
2245 "argument with the same rank (12.4.1.5)",
2246 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2250 for (arg
= arg0
; arg
; arg
= arg
->next
)
2252 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2255 /* Being elemental, the last upper bound of an assumed size array
2256 argument must be present. */
2257 if (resolve_assumed_size_actual (arg
->expr
))
2260 /* Elemental procedure's array actual arguments must conform. */
2263 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2270 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2271 is an array, the intent inout/out variable needs to be also an array. */
2272 if (rank
> 0 && esym
&& expr
== NULL
)
2273 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2274 arg
= arg
->next
, eformal
= eformal
->next
)
2275 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2276 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2277 && arg
->expr
&& arg
->expr
->rank
== 0)
2279 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2280 "ELEMENTAL subroutine %qs is a scalar, but another "
2281 "actual argument is an array", &arg
->expr
->where
,
2282 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2283 : "INOUT", eformal
->sym
->name
, esym
->name
);
2290 /* This function does the checking of references to global procedures
2291 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2292 77 and 95 standards. It checks for a gsymbol for the name, making
2293 one if it does not already exist. If it already exists, then the
2294 reference being resolved must correspond to the type of gsymbol.
2295 Otherwise, the new symbol is equipped with the attributes of the
2296 reference. The corresponding code that is called in creating
2297 global entities is parse.c.
2299 In addition, for all but -std=legacy, the gsymbols are used to
2300 check the interfaces of external procedures from the same file.
2301 The namespace of the gsymbol is resolved and then, once this is
2302 done the interface is checked. */
2306 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2308 if (!gsym_ns
->proc_name
->attr
.recursive
)
2311 if (sym
->ns
== gsym_ns
)
2314 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2321 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2323 if (gsym_ns
->entries
)
2325 gfc_entry_list
*entry
= gsym_ns
->entries
;
2327 for (; entry
; entry
= entry
->next
)
2329 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2331 if (strcmp (gsym_ns
->proc_name
->name
,
2332 sym
->ns
->proc_name
->name
) == 0)
2336 && strcmp (gsym_ns
->proc_name
->name
,
2337 sym
->ns
->parent
->proc_name
->name
) == 0)
2346 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2349 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2351 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2353 for ( ; arg
; arg
= arg
->next
)
2358 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2360 strncpy (errmsg
, _("allocatable argument"), err_len
);
2363 else if (arg
->sym
->attr
.asynchronous
)
2365 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2368 else if (arg
->sym
->attr
.optional
)
2370 strncpy (errmsg
, _("optional argument"), err_len
);
2373 else if (arg
->sym
->attr
.pointer
)
2375 strncpy (errmsg
, _("pointer argument"), err_len
);
2378 else if (arg
->sym
->attr
.target
)
2380 strncpy (errmsg
, _("target argument"), err_len
);
2383 else if (arg
->sym
->attr
.value
)
2385 strncpy (errmsg
, _("value argument"), err_len
);
2388 else if (arg
->sym
->attr
.volatile_
)
2390 strncpy (errmsg
, _("volatile argument"), err_len
);
2393 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2395 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2398 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2400 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2403 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2405 strncpy (errmsg
, _("coarray argument"), err_len
);
2408 else if (false) /* (2d) TODO: parametrized derived type */
2410 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2413 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2415 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2418 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2420 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2423 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2425 /* As assumed-type is unlimited polymorphic (cf. above).
2426 See also TS 29113, Note 6.1. */
2427 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2432 if (sym
->attr
.function
)
2434 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2436 if (res
->attr
.dimension
) /* (3a) */
2438 strncpy (errmsg
, _("array result"), err_len
);
2441 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2443 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2446 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2447 && res
->ts
.u
.cl
->length
2448 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2450 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2455 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2457 strncpy (errmsg
, _("elemental procedure"), err_len
);
2460 else if (sym
->attr
.is_bind_c
) /* (5) */
2462 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2471 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2472 gfc_actual_arglist
**actual
, int sub
)
2476 enum gfc_symbol_type type
;
2479 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2481 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2483 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2484 gfc_global_used (gsym
, where
);
2486 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2487 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2488 && gsym
->type
!= GSYM_UNKNOWN
2489 && !gsym
->binding_label
2491 && gsym
->ns
->resolved
!= -1
2492 && gsym
->ns
->proc_name
2493 && not_in_recursive (sym
, gsym
->ns
)
2494 && not_entry_self_reference (sym
, gsym
->ns
))
2496 gfc_symbol
*def_sym
;
2498 /* Resolve the gsymbol namespace if needed. */
2499 if (!gsym
->ns
->resolved
)
2501 gfc_dt_list
*old_dt_list
;
2503 /* Stash away derived types so that the backend_decls do not
2505 old_dt_list
= gfc_derived_types
;
2506 gfc_derived_types
= NULL
;
2508 gfc_resolve (gsym
->ns
);
2510 /* Store the new derived types with the global namespace. */
2511 if (gfc_derived_types
)
2512 gsym
->ns
->derived_types
= gfc_derived_types
;
2514 /* Restore the derived types of this namespace. */
2515 gfc_derived_types
= old_dt_list
;
2518 /* Make sure that translation for the gsymbol occurs before
2519 the procedure currently being resolved. */
2520 ns
= gfc_global_ns_list
;
2521 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2523 if (ns
->sibling
== gsym
->ns
)
2525 ns
->sibling
= gsym
->ns
->sibling
;
2526 gsym
->ns
->sibling
= gfc_global_ns_list
;
2527 gfc_global_ns_list
= gsym
->ns
;
2532 def_sym
= gsym
->ns
->proc_name
;
2534 /* This can happen if a binding name has been specified. */
2535 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2536 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2538 if (def_sym
->attr
.entry_master
)
2540 gfc_entry_list
*entry
;
2541 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2542 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2544 def_sym
= entry
->sym
;
2549 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2551 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2552 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2553 gfc_typename (&def_sym
->ts
));
2557 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2558 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2560 gfc_error ("Explicit interface required for %qs at %L: %s",
2561 sym
->name
, &sym
->declared_at
, reason
);
2565 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2566 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2567 gfc_errors_to_warnings (true);
2569 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2570 reason
, sizeof(reason
), NULL
, NULL
))
2572 gfc_error_opt (OPT_Wargument_mismatch
,
2573 "Interface mismatch in global procedure %qs at %L:"
2574 " %s", sym
->name
, &sym
->declared_at
, reason
);
2579 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2580 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2581 gfc_errors_to_warnings (true);
2583 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2584 gfc_procedure_use (def_sym
, actual
, where
);
2588 gfc_errors_to_warnings (false);
2590 if (gsym
->type
== GSYM_UNKNOWN
)
2593 gsym
->where
= *where
;
2600 /************* Function resolution *************/
2602 /* Resolve a function call known to be generic.
2603 Section 14.1.2.4.1. */
2606 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2610 if (sym
->attr
.generic
)
2612 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2615 expr
->value
.function
.name
= s
->name
;
2616 expr
->value
.function
.esym
= s
;
2618 if (s
->ts
.type
!= BT_UNKNOWN
)
2620 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2621 expr
->ts
= s
->result
->ts
;
2624 expr
->rank
= s
->as
->rank
;
2625 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2626 expr
->rank
= s
->result
->as
->rank
;
2628 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2633 /* TODO: Need to search for elemental references in generic
2637 if (sym
->attr
.intrinsic
)
2638 return gfc_intrinsic_func_interface (expr
, 0);
2645 resolve_generic_f (gfc_expr
*expr
)
2649 gfc_interface
*intr
= NULL
;
2651 sym
= expr
->symtree
->n
.sym
;
2655 m
= resolve_generic_f0 (expr
, sym
);
2658 else if (m
== MATCH_ERROR
)
2663 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2664 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2667 if (sym
->ns
->parent
== NULL
)
2669 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2673 if (!generic_sym (sym
))
2677 /* Last ditch attempt. See if the reference is to an intrinsic
2678 that possesses a matching interface. 14.1.2.4 */
2679 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2681 if (gfc_init_expr_flag
)
2682 gfc_error ("Function %qs in initialization expression at %L "
2683 "must be an intrinsic function",
2684 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2686 gfc_error ("There is no specific function for the generic %qs "
2687 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2693 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2696 return resolve_structure_cons (expr
, 0);
2699 m
= gfc_intrinsic_func_interface (expr
, 0);
2704 gfc_error ("Generic function %qs at %L is not consistent with a "
2705 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2712 /* Resolve a function call known to be specific. */
2715 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2719 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2721 if (sym
->attr
.dummy
)
2723 sym
->attr
.proc
= PROC_DUMMY
;
2727 sym
->attr
.proc
= PROC_EXTERNAL
;
2731 if (sym
->attr
.proc
== PROC_MODULE
2732 || sym
->attr
.proc
== PROC_ST_FUNCTION
2733 || sym
->attr
.proc
== PROC_INTERNAL
)
2736 if (sym
->attr
.intrinsic
)
2738 m
= gfc_intrinsic_func_interface (expr
, 1);
2742 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2743 "with an intrinsic", sym
->name
, &expr
->where
);
2751 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2754 expr
->ts
= sym
->result
->ts
;
2757 expr
->value
.function
.name
= sym
->name
;
2758 expr
->value
.function
.esym
= sym
;
2759 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2761 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2763 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2764 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2765 else if (sym
->as
!= NULL
)
2766 expr
->rank
= sym
->as
->rank
;
2773 resolve_specific_f (gfc_expr
*expr
)
2778 sym
= expr
->symtree
->n
.sym
;
2782 m
= resolve_specific_f0 (sym
, expr
);
2785 if (m
== MATCH_ERROR
)
2788 if (sym
->ns
->parent
== NULL
)
2791 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2797 gfc_error ("Unable to resolve the specific function %qs at %L",
2798 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2804 /* Resolve a procedure call not known to be generic nor specific. */
2807 resolve_unknown_f (gfc_expr
*expr
)
2812 sym
= expr
->symtree
->n
.sym
;
2814 if (sym
->attr
.dummy
)
2816 sym
->attr
.proc
= PROC_DUMMY
;
2817 expr
->value
.function
.name
= sym
->name
;
2821 /* See if we have an intrinsic function reference. */
2823 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2825 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2830 /* The reference is to an external name. */
2832 sym
->attr
.proc
= PROC_EXTERNAL
;
2833 expr
->value
.function
.name
= sym
->name
;
2834 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2836 if (sym
->as
!= NULL
)
2837 expr
->rank
= sym
->as
->rank
;
2839 /* Type of the expression is either the type of the symbol or the
2840 default type of the symbol. */
2843 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2845 if (sym
->ts
.type
!= BT_UNKNOWN
)
2849 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2851 if (ts
->type
== BT_UNKNOWN
)
2853 gfc_error ("Function %qs at %L has no IMPLICIT type",
2854 sym
->name
, &expr
->where
);
2865 /* Return true, if the symbol is an external procedure. */
2867 is_external_proc (gfc_symbol
*sym
)
2869 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2870 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2871 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2872 && !sym
->attr
.proc_pointer
2873 && !sym
->attr
.use_assoc
2881 /* Figure out if a function reference is pure or not. Also set the name
2882 of the function for a potential error message. Return nonzero if the
2883 function is PURE, zero if not. */
2885 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2888 pure_function (gfc_expr
*e
, const char **name
)
2891 gfc_component
*comp
;
2895 if (e
->symtree
!= NULL
2896 && e
->symtree
->n
.sym
!= NULL
2897 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2898 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2900 comp
= gfc_get_proc_ptr_comp (e
);
2903 pure
= gfc_pure (comp
->ts
.interface
);
2906 else if (e
->value
.function
.esym
)
2908 pure
= gfc_pure (e
->value
.function
.esym
);
2909 *name
= e
->value
.function
.esym
->name
;
2911 else if (e
->value
.function
.isym
)
2913 pure
= e
->value
.function
.isym
->pure
2914 || e
->value
.function
.isym
->elemental
;
2915 *name
= e
->value
.function
.isym
->name
;
2919 /* Implicit functions are not pure. */
2921 *name
= e
->value
.function
.name
;
2929 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2930 int *f ATTRIBUTE_UNUSED
)
2934 /* Don't bother recursing into other statement functions
2935 since they will be checked individually for purity. */
2936 if (e
->expr_type
!= EXPR_FUNCTION
2938 || e
->symtree
->n
.sym
== sym
2939 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2942 return pure_function (e
, &name
) ? false : true;
2947 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2949 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2953 /* Check if an impure function is allowed in the current context. */
2955 static bool check_pure_function (gfc_expr
*e
)
2957 const char *name
= NULL
;
2958 if (!pure_function (e
, &name
) && name
)
2962 gfc_error ("Reference to impure function %qs at %L inside a "
2963 "FORALL %s", name
, &e
->where
,
2964 forall_flag
== 2 ? "mask" : "block");
2967 else if (gfc_do_concurrent_flag
)
2969 gfc_error ("Reference to impure function %qs at %L inside a "
2970 "DO CONCURRENT %s", name
, &e
->where
,
2971 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2974 else if (gfc_pure (NULL
))
2976 gfc_error ("Reference to impure function %qs at %L "
2977 "within a PURE procedure", name
, &e
->where
);
2980 gfc_unset_implicit_pure (NULL
);
2986 /* Update current procedure's array_outer_dependency flag, considering
2987 a call to procedure SYM. */
2990 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2992 /* Check to see if this is a sibling function that has not yet
2994 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2995 for (; sibling
; sibling
= sibling
->sibling
)
2997 if (sibling
->proc_name
== sym
)
2999 gfc_resolve (sibling
);
3004 /* If SYM has references to outer arrays, so has the procedure calling
3005 SYM. If SYM is a procedure pointer, we can assume the worst. */
3006 if (sym
->attr
.array_outer_dependency
3007 || sym
->attr
.proc_pointer
)
3008 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3012 /* Resolve a function call, which means resolving the arguments, then figuring
3013 out which entity the name refers to. */
3016 resolve_function (gfc_expr
*expr
)
3018 gfc_actual_arglist
*arg
;
3022 procedure_type p
= PROC_INTRINSIC
;
3023 bool no_formal_args
;
3027 sym
= expr
->symtree
->n
.sym
;
3029 /* If this is a procedure pointer component, it has already been resolved. */
3030 if (gfc_is_proc_ptr_comp (expr
))
3033 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3035 if (sym
&& sym
->attr
.intrinsic
3036 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3037 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3040 if (sym
&& sym
->attr
.intrinsic
3041 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3044 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3046 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3050 /* If this ia a deferred TBP with an abstract interface (which may
3051 of course be referenced), expr->value.function.esym will be set. */
3052 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3054 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3055 sym
->name
, &expr
->where
);
3059 /* Switch off assumed size checking and do this again for certain kinds
3060 of procedure, once the procedure itself is resolved. */
3061 need_full_assumed_size
++;
3063 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3064 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3066 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3067 inquiry_argument
= true;
3068 no_formal_args
= sym
&& is_external_proc (sym
)
3069 && gfc_sym_get_dummy_args (sym
) == NULL
;
3071 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3074 inquiry_argument
= false;
3078 inquiry_argument
= false;
3080 /* Resume assumed_size checking. */
3081 need_full_assumed_size
--;
3083 /* If the procedure is external, check for usage. */
3084 if (sym
&& is_external_proc (sym
))
3085 resolve_global_procedure (sym
, &expr
->where
,
3086 &expr
->value
.function
.actual
, 0);
3088 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3090 && sym
->ts
.u
.cl
->length
== NULL
3092 && !sym
->ts
.deferred
3093 && expr
->value
.function
.esym
== NULL
3094 && !sym
->attr
.contained
)
3096 /* Internal procedures are taken care of in resolve_contained_fntype. */
3097 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3098 "be used at %L since it is not a dummy argument",
3099 sym
->name
, &expr
->where
);
3103 /* See if function is already resolved. */
3105 if (expr
->value
.function
.name
!= NULL
3106 || expr
->value
.function
.isym
!= NULL
)
3108 if (expr
->ts
.type
== BT_UNKNOWN
)
3114 /* Apply the rules of section 14.1.2. */
3116 switch (procedure_kind (sym
))
3119 t
= resolve_generic_f (expr
);
3122 case PTYPE_SPECIFIC
:
3123 t
= resolve_specific_f (expr
);
3127 t
= resolve_unknown_f (expr
);
3131 gfc_internal_error ("resolve_function(): bad function type");
3135 /* If the expression is still a function (it might have simplified),
3136 then we check to see if we are calling an elemental function. */
3138 if (expr
->expr_type
!= EXPR_FUNCTION
)
3141 temp
= need_full_assumed_size
;
3142 need_full_assumed_size
= 0;
3144 if (!resolve_elemental_actual (expr
, NULL
))
3147 if (omp_workshare_flag
3148 && expr
->value
.function
.esym
3149 && ! gfc_elemental (expr
->value
.function
.esym
))
3151 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3152 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3157 #define GENERIC_ID expr->value.function.isym->id
3158 else if (expr
->value
.function
.actual
!= NULL
3159 && expr
->value
.function
.isym
!= NULL
3160 && GENERIC_ID
!= GFC_ISYM_LBOUND
3161 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3162 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3163 && GENERIC_ID
!= GFC_ISYM_LEN
3164 && GENERIC_ID
!= GFC_ISYM_LOC
3165 && GENERIC_ID
!= GFC_ISYM_C_LOC
3166 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3168 /* Array intrinsics must also have the last upper bound of an
3169 assumed size array argument. UBOUND and SIZE have to be
3170 excluded from the check if the second argument is anything
3173 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3175 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3176 && arg
== expr
->value
.function
.actual
3177 && arg
->next
!= NULL
&& arg
->next
->expr
)
3179 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3182 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3185 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3190 if (arg
->expr
!= NULL
3191 && arg
->expr
->rank
> 0
3192 && resolve_assumed_size_actual (arg
->expr
))
3198 need_full_assumed_size
= temp
;
3200 if (!check_pure_function(expr
))
3203 /* Functions without the RECURSIVE attribution are not allowed to
3204 * call themselves. */
3205 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3208 esym
= expr
->value
.function
.esym
;
3210 if (is_illegal_recursion (esym
, gfc_current_ns
))
3212 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3213 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3214 " function %qs is not RECURSIVE",
3215 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3217 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3218 " is not RECURSIVE", esym
->name
, &expr
->where
);
3224 /* Character lengths of use associated functions may contains references to
3225 symbols not referenced from the current program unit otherwise. Make sure
3226 those symbols are marked as referenced. */
3228 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3229 && expr
->value
.function
.esym
->attr
.use_assoc
)
3231 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3234 /* Make sure that the expression has a typespec that works. */
3235 if (expr
->ts
.type
== BT_UNKNOWN
)
3237 if (expr
->symtree
->n
.sym
->result
3238 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3239 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3240 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3243 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3245 if (expr
->value
.function
.esym
)
3246 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3248 update_current_proc_array_outer_dependency (sym
);
3251 /* typebound procedure: Assume the worst. */
3252 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3258 /************* Subroutine resolution *************/
3261 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3268 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3272 else if (gfc_do_concurrent_flag
)
3274 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3278 else if (gfc_pure (NULL
))
3280 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3284 gfc_unset_implicit_pure (NULL
);
3290 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3294 if (sym
->attr
.generic
)
3296 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3299 c
->resolved_sym
= s
;
3300 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3305 /* TODO: Need to search for elemental references in generic interface. */
3308 if (sym
->attr
.intrinsic
)
3309 return gfc_intrinsic_sub_interface (c
, 0);
3316 resolve_generic_s (gfc_code
*c
)
3321 sym
= c
->symtree
->n
.sym
;
3325 m
= resolve_generic_s0 (c
, sym
);
3328 else if (m
== MATCH_ERROR
)
3332 if (sym
->ns
->parent
== NULL
)
3334 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3338 if (!generic_sym (sym
))
3342 /* Last ditch attempt. See if the reference is to an intrinsic
3343 that possesses a matching interface. 14.1.2.4 */
3344 sym
= c
->symtree
->n
.sym
;
3346 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3348 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3349 sym
->name
, &c
->loc
);
3353 m
= gfc_intrinsic_sub_interface (c
, 0);
3357 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3358 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3364 /* Resolve a subroutine call known to be specific. */
3367 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3371 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3373 if (sym
->attr
.dummy
)
3375 sym
->attr
.proc
= PROC_DUMMY
;
3379 sym
->attr
.proc
= PROC_EXTERNAL
;
3383 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3386 if (sym
->attr
.intrinsic
)
3388 m
= gfc_intrinsic_sub_interface (c
, 1);
3392 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3393 "with an intrinsic", sym
->name
, &c
->loc
);
3401 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3403 c
->resolved_sym
= sym
;
3404 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3412 resolve_specific_s (gfc_code
*c
)
3417 sym
= c
->symtree
->n
.sym
;
3421 m
= resolve_specific_s0 (c
, sym
);
3424 if (m
== MATCH_ERROR
)
3427 if (sym
->ns
->parent
== NULL
)
3430 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3436 sym
= c
->symtree
->n
.sym
;
3437 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3438 sym
->name
, &c
->loc
);
3444 /* Resolve a subroutine call not known to be generic nor specific. */
3447 resolve_unknown_s (gfc_code
*c
)
3451 sym
= c
->symtree
->n
.sym
;
3453 if (sym
->attr
.dummy
)
3455 sym
->attr
.proc
= PROC_DUMMY
;
3459 /* See if we have an intrinsic function reference. */
3461 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3463 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3468 /* The reference is to an external name. */
3471 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3473 c
->resolved_sym
= sym
;
3475 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3479 /* Resolve a subroutine call. Although it was tempting to use the same code
3480 for functions, subroutines and functions are stored differently and this
3481 makes things awkward. */
3484 resolve_call (gfc_code
*c
)
3487 procedure_type ptype
= PROC_INTRINSIC
;
3488 gfc_symbol
*csym
, *sym
;
3489 bool no_formal_args
;
3491 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3493 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3495 gfc_error ("%qs at %L has a type, which is not consistent with "
3496 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3500 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3503 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3504 sym
= st
? st
->n
.sym
: NULL
;
3505 if (sym
&& csym
!= sym
3506 && sym
->ns
== gfc_current_ns
3507 && sym
->attr
.flavor
== FL_PROCEDURE
3508 && sym
->attr
.contained
)
3511 if (csym
->attr
.generic
)
3512 c
->symtree
->n
.sym
= sym
;
3515 csym
= c
->symtree
->n
.sym
;
3519 /* If this ia a deferred TBP, c->expr1 will be set. */
3520 if (!c
->expr1
&& csym
)
3522 if (csym
->attr
.abstract
)
3524 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3525 csym
->name
, &c
->loc
);
3529 /* Subroutines without the RECURSIVE attribution are not allowed to
3531 if (is_illegal_recursion (csym
, gfc_current_ns
))
3533 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3534 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3535 "as subroutine %qs is not RECURSIVE",
3536 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3538 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3539 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3545 /* Switch off assumed size checking and do this again for certain kinds
3546 of procedure, once the procedure itself is resolved. */
3547 need_full_assumed_size
++;
3550 ptype
= csym
->attr
.proc
;
3552 no_formal_args
= csym
&& is_external_proc (csym
)
3553 && gfc_sym_get_dummy_args (csym
) == NULL
;
3554 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3557 /* Resume assumed_size checking. */
3558 need_full_assumed_size
--;
3560 /* If external, check for usage. */
3561 if (csym
&& is_external_proc (csym
))
3562 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3565 if (c
->resolved_sym
== NULL
)
3567 c
->resolved_isym
= NULL
;
3568 switch (procedure_kind (csym
))
3571 t
= resolve_generic_s (c
);
3574 case PTYPE_SPECIFIC
:
3575 t
= resolve_specific_s (c
);
3579 t
= resolve_unknown_s (c
);
3583 gfc_internal_error ("resolve_subroutine(): bad function type");
3587 /* Some checks of elemental subroutine actual arguments. */
3588 if (!resolve_elemental_actual (NULL
, c
))
3592 update_current_proc_array_outer_dependency (csym
);
3594 /* Typebound procedure: Assume the worst. */
3595 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3601 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3602 op1->shape and op2->shape are non-NULL return true if their shapes
3603 match. If both op1->shape and op2->shape are non-NULL return false
3604 if their shapes do not match. If either op1->shape or op2->shape is
3605 NULL, return true. */
3608 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3615 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3617 for (i
= 0; i
< op1
->rank
; i
++)
3619 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3621 gfc_error ("Shapes for operands at %L and %L are not conformable",
3622 &op1
->where
, &op2
->where
);
3632 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3633 For example A .AND. B becomes IAND(A, B). */
3635 logical_to_bitwise (gfc_expr
*e
)
3637 gfc_expr
*tmp
, *op1
, *op2
;
3639 gfc_actual_arglist
*args
= NULL
;
3641 gcc_assert (e
->expr_type
== EXPR_OP
);
3643 isym
= GFC_ISYM_NONE
;
3644 op1
= e
->value
.op
.op1
;
3645 op2
= e
->value
.op
.op2
;
3647 switch (e
->value
.op
.op
)
3650 isym
= GFC_ISYM_NOT
;
3653 isym
= GFC_ISYM_IAND
;
3656 isym
= GFC_ISYM_IOR
;
3658 case INTRINSIC_NEQV
:
3659 isym
= GFC_ISYM_IEOR
;
3662 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3663 Change the old expression to NEQV, which will get replaced by IEOR,
3664 and wrap it in NOT. */
3665 tmp
= gfc_copy_expr (e
);
3666 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3667 tmp
= logical_to_bitwise (tmp
);
3668 isym
= GFC_ISYM_NOT
;
3673 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3676 /* Inherit the original operation's operands as arguments. */
3677 args
= gfc_get_actual_arglist ();
3681 args
->next
= gfc_get_actual_arglist ();
3682 args
->next
->expr
= op2
;
3685 /* Convert the expression to a function call. */
3686 e
->expr_type
= EXPR_FUNCTION
;
3687 e
->value
.function
.actual
= args
;
3688 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3689 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3690 e
->value
.function
.esym
= NULL
;
3692 /* Make up a pre-resolved function call symtree if we need to. */
3693 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3696 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3697 sym
= e
->symtree
->n
.sym
;
3699 sym
->attr
.flavor
= FL_PROCEDURE
;
3700 sym
->attr
.function
= 1;
3701 sym
->attr
.elemental
= 1;
3703 sym
->attr
.referenced
= 1;
3704 gfc_intrinsic_symbol (sym
);
3705 gfc_commit_symbol (sym
);
3708 args
->name
= e
->value
.function
.isym
->formal
->name
;
3709 if (e
->value
.function
.isym
->formal
->next
)
3710 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3715 /* Resolve an operator expression node. This can involve replacing the
3716 operation with a user defined function call. */
3719 resolve_operator (gfc_expr
*e
)
3721 gfc_expr
*op1
, *op2
;
3723 bool dual_locus_error
;
3726 /* Resolve all subnodes-- give them types. */
3728 switch (e
->value
.op
.op
)
3731 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3737 case INTRINSIC_UPLUS
:
3738 case INTRINSIC_UMINUS
:
3739 case INTRINSIC_PARENTHESES
:
3740 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3745 /* Typecheck the new node. */
3747 op1
= e
->value
.op
.op1
;
3748 op2
= e
->value
.op
.op2
;
3749 dual_locus_error
= false;
3751 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3752 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3754 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3758 switch (e
->value
.op
.op
)
3760 case INTRINSIC_UPLUS
:
3761 case INTRINSIC_UMINUS
:
3762 if (op1
->ts
.type
== BT_INTEGER
3763 || op1
->ts
.type
== BT_REAL
3764 || op1
->ts
.type
== BT_COMPLEX
)
3770 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3771 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3774 case INTRINSIC_PLUS
:
3775 case INTRINSIC_MINUS
:
3776 case INTRINSIC_TIMES
:
3777 case INTRINSIC_DIVIDE
:
3778 case INTRINSIC_POWER
:
3779 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3781 gfc_type_convert_binary (e
, 1);
3786 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3787 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3788 gfc_typename (&op2
->ts
));
3791 case INTRINSIC_CONCAT
:
3792 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3793 && op1
->ts
.kind
== op2
->ts
.kind
)
3795 e
->ts
.type
= BT_CHARACTER
;
3796 e
->ts
.kind
= op1
->ts
.kind
;
3801 _("Operands of string concatenation operator at %%L are %s/%s"),
3802 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3808 case INTRINSIC_NEQV
:
3809 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3811 e
->ts
.type
= BT_LOGICAL
;
3812 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3813 if (op1
->ts
.kind
< e
->ts
.kind
)
3814 gfc_convert_type (op1
, &e
->ts
, 2);
3815 else if (op2
->ts
.kind
< e
->ts
.kind
)
3816 gfc_convert_type (op2
, &e
->ts
, 2);
3820 /* Logical ops on integers become bitwise ops with -fdec. */
3822 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
3824 e
->ts
.type
= BT_INTEGER
;
3825 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3826 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
3827 gfc_convert_type (op1
, &e
->ts
, 1);
3828 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
3829 gfc_convert_type (op2
, &e
->ts
, 1);
3830 e
= logical_to_bitwise (e
);
3831 return resolve_function (e
);
3834 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3835 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3836 gfc_typename (&op2
->ts
));
3841 /* Logical ops on integers become bitwise ops with -fdec. */
3842 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
3844 e
->ts
.type
= BT_INTEGER
;
3845 e
->ts
.kind
= op1
->ts
.kind
;
3846 e
= logical_to_bitwise (e
);
3847 return resolve_function (e
);
3850 if (op1
->ts
.type
== BT_LOGICAL
)
3852 e
->ts
.type
= BT_LOGICAL
;
3853 e
->ts
.kind
= op1
->ts
.kind
;
3857 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3858 gfc_typename (&op1
->ts
));
3862 case INTRINSIC_GT_OS
:
3864 case INTRINSIC_GE_OS
:
3866 case INTRINSIC_LT_OS
:
3868 case INTRINSIC_LE_OS
:
3869 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3871 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3878 case INTRINSIC_EQ_OS
:
3880 case INTRINSIC_NE_OS
:
3881 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3882 && op1
->ts
.kind
== op2
->ts
.kind
)
3884 e
->ts
.type
= BT_LOGICAL
;
3885 e
->ts
.kind
= gfc_default_logical_kind
;
3889 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3891 gfc_type_convert_binary (e
, 1);
3893 e
->ts
.type
= BT_LOGICAL
;
3894 e
->ts
.kind
= gfc_default_logical_kind
;
3896 if (warn_compare_reals
)
3898 gfc_intrinsic_op op
= e
->value
.op
.op
;
3900 /* Type conversion has made sure that the types of op1 and op2
3901 agree, so it is only necessary to check the first one. */
3902 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3903 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3904 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3908 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3909 msg
= "Equality comparison for %s at %L";
3911 msg
= "Inequality comparison for %s at %L";
3913 gfc_warning (OPT_Wcompare_reals
, msg
,
3914 gfc_typename (&op1
->ts
), &op1
->where
);
3921 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3923 _("Logicals at %%L must be compared with %s instead of %s"),
3924 (e
->value
.op
.op
== INTRINSIC_EQ
3925 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3926 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3929 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
3930 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3931 gfc_typename (&op2
->ts
));
3935 case INTRINSIC_USER
:
3936 if (e
->value
.op
.uop
->op
== NULL
)
3937 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"),
3938 e
->value
.op
.uop
->name
);
3939 else if (op2
== NULL
)
3940 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
3941 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3944 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
3945 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3946 gfc_typename (&op2
->ts
));
3947 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3952 case INTRINSIC_PARENTHESES
:
3954 if (e
->ts
.type
== BT_CHARACTER
)
3955 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3959 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3962 /* Deal with arrayness of an operand through an operator. */
3966 switch (e
->value
.op
.op
)
3968 case INTRINSIC_PLUS
:
3969 case INTRINSIC_MINUS
:
3970 case INTRINSIC_TIMES
:
3971 case INTRINSIC_DIVIDE
:
3972 case INTRINSIC_POWER
:
3973 case INTRINSIC_CONCAT
:
3977 case INTRINSIC_NEQV
:
3979 case INTRINSIC_EQ_OS
:
3981 case INTRINSIC_NE_OS
:
3983 case INTRINSIC_GT_OS
:
3985 case INTRINSIC_GE_OS
:
3987 case INTRINSIC_LT_OS
:
3989 case INTRINSIC_LE_OS
:
3991 if (op1
->rank
== 0 && op2
->rank
== 0)
3994 if (op1
->rank
== 0 && op2
->rank
!= 0)
3996 e
->rank
= op2
->rank
;
3998 if (e
->shape
== NULL
)
3999 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4002 if (op1
->rank
!= 0 && op2
->rank
== 0)
4004 e
->rank
= op1
->rank
;
4006 if (e
->shape
== NULL
)
4007 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4010 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4012 if (op1
->rank
== op2
->rank
)
4014 e
->rank
= op1
->rank
;
4015 if (e
->shape
== NULL
)
4017 t
= compare_shapes (op1
, op2
);
4021 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4026 /* Allow higher level expressions to work. */
4029 /* Try user-defined operators, and otherwise throw an error. */
4030 dual_locus_error
= true;
4032 _("Inconsistent ranks for operator at %%L and %%L"));
4039 case INTRINSIC_PARENTHESES
:
4041 case INTRINSIC_UPLUS
:
4042 case INTRINSIC_UMINUS
:
4043 /* Simply copy arrayness attribute */
4044 e
->rank
= op1
->rank
;
4046 if (e
->shape
== NULL
)
4047 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4055 /* Attempt to simplify the expression. */
4058 t
= gfc_simplify_expr (e
, 0);
4059 /* Some calls do not succeed in simplification and return false
4060 even though there is no error; e.g. variable references to
4061 PARAMETER arrays. */
4062 if (!gfc_is_constant_expr (e
))
4070 match m
= gfc_extend_expr (e
);
4073 if (m
== MATCH_ERROR
)
4077 if (dual_locus_error
)
4078 gfc_error (msg
, &op1
->where
, &op2
->where
);
4080 gfc_error (msg
, &e
->where
);
4086 /************** Array resolution subroutines **************/
4089 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4091 /* Compare two integer expressions. */
4093 static compare_result
4094 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4098 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4099 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4102 /* If either of the types isn't INTEGER, we must have
4103 raised an error earlier. */
4105 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4108 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4118 /* Compare an integer expression with an integer. */
4120 static compare_result
4121 compare_bound_int (gfc_expr
*a
, int b
)
4125 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4128 if (a
->ts
.type
!= BT_INTEGER
)
4129 gfc_internal_error ("compare_bound_int(): Bad expression");
4131 i
= mpz_cmp_si (a
->value
.integer
, b
);
4141 /* Compare an integer expression with a mpz_t. */
4143 static compare_result
4144 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4148 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4151 if (a
->ts
.type
!= BT_INTEGER
)
4152 gfc_internal_error ("compare_bound_int(): Bad expression");
4154 i
= mpz_cmp (a
->value
.integer
, b
);
4164 /* Compute the last value of a sequence given by a triplet.
4165 Return 0 if it wasn't able to compute the last value, or if the
4166 sequence if empty, and 1 otherwise. */
4169 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4170 gfc_expr
*stride
, mpz_t last
)
4174 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4175 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4176 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4179 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4180 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4183 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4185 if (compare_bound (start
, end
) == CMP_GT
)
4187 mpz_set (last
, end
->value
.integer
);
4191 if (compare_bound_int (stride
, 0) == CMP_GT
)
4193 /* Stride is positive */
4194 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4199 /* Stride is negative */
4200 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4205 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4206 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4207 mpz_sub (last
, end
->value
.integer
, rem
);
4214 /* Compare a single dimension of an array reference to the array
4218 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4222 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4224 gcc_assert (ar
->stride
[i
] == NULL
);
4225 /* This implies [*] as [*:] and [*:3] are not possible. */
4226 if (ar
->start
[i
] == NULL
)
4228 gcc_assert (ar
->end
[i
] == NULL
);
4233 /* Given start, end and stride values, calculate the minimum and
4234 maximum referenced indexes. */
4236 switch (ar
->dimen_type
[i
])
4239 case DIMEN_THIS_IMAGE
:
4244 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4247 gfc_warning (0, "Array reference at %L is out of bounds "
4248 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4249 mpz_get_si (ar
->start
[i
]->value
.integer
),
4250 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4252 gfc_warning (0, "Array reference at %L is out of bounds "
4253 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4254 mpz_get_si (ar
->start
[i
]->value
.integer
),
4255 mpz_get_si (as
->lower
[i
]->value
.integer
),
4259 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4262 gfc_warning (0, "Array reference at %L is out of bounds "
4263 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4264 mpz_get_si (ar
->start
[i
]->value
.integer
),
4265 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4267 gfc_warning (0, "Array reference at %L is out of bounds "
4268 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4269 mpz_get_si (ar
->start
[i
]->value
.integer
),
4270 mpz_get_si (as
->upper
[i
]->value
.integer
),
4279 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4280 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4282 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4284 /* Check for zero stride, which is not allowed. */
4285 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4287 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4291 /* if start == len || (stride > 0 && start < len)
4292 || (stride < 0 && start > len),
4293 then the array section contains at least one element. In this
4294 case, there is an out-of-bounds access if
4295 (start < lower || start > upper). */
4296 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4297 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4298 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4299 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4300 && comp_start_end
== CMP_GT
))
4302 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4304 gfc_warning (0, "Lower array reference at %L is out of bounds "
4305 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4306 mpz_get_si (AR_START
->value
.integer
),
4307 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4310 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4312 gfc_warning (0, "Lower array reference at %L is out of bounds "
4313 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4314 mpz_get_si (AR_START
->value
.integer
),
4315 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4320 /* If we can compute the highest index of the array section,
4321 then it also has to be between lower and upper. */
4322 mpz_init (last_value
);
4323 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4326 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4328 gfc_warning (0, "Upper array reference at %L is out of bounds "
4329 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4330 mpz_get_si (last_value
),
4331 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4332 mpz_clear (last_value
);
4335 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4337 gfc_warning (0, "Upper array reference at %L is out of bounds "
4338 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4339 mpz_get_si (last_value
),
4340 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4341 mpz_clear (last_value
);
4345 mpz_clear (last_value
);
4353 gfc_internal_error ("check_dimension(): Bad array reference");
4360 /* Compare an array reference with an array specification. */
4363 compare_spec_to_ref (gfc_array_ref
*ar
)
4370 /* TODO: Full array sections are only allowed as actual parameters. */
4371 if (as
->type
== AS_ASSUMED_SIZE
4372 && (/*ar->type == AR_FULL
4373 ||*/ (ar
->type
== AR_SECTION
4374 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4376 gfc_error ("Rightmost upper bound of assumed size array section "
4377 "not specified at %L", &ar
->where
);
4381 if (ar
->type
== AR_FULL
)
4384 if (as
->rank
!= ar
->dimen
)
4386 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4387 &ar
->where
, ar
->dimen
, as
->rank
);
4391 /* ar->codimen == 0 is a local array. */
4392 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4394 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4395 &ar
->where
, ar
->codimen
, as
->corank
);
4399 for (i
= 0; i
< as
->rank
; i
++)
4400 if (!check_dimension (i
, ar
, as
))
4403 /* Local access has no coarray spec. */
4404 if (ar
->codimen
!= 0)
4405 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4407 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4408 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4410 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4411 i
+ 1 - as
->rank
, &ar
->where
);
4414 if (!check_dimension (i
, ar
, as
))
4422 /* Resolve one part of an array index. */
4425 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4426 int force_index_integer_kind
)
4433 if (!gfc_resolve_expr (index
))
4436 if (check_scalar
&& index
->rank
!= 0)
4438 gfc_error ("Array index at %L must be scalar", &index
->where
);
4442 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4444 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4445 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4449 if (index
->ts
.type
== BT_REAL
)
4450 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4454 if ((index
->ts
.kind
!= gfc_index_integer_kind
4455 && force_index_integer_kind
)
4456 || index
->ts
.type
!= BT_INTEGER
)
4459 ts
.type
= BT_INTEGER
;
4460 ts
.kind
= gfc_index_integer_kind
;
4462 gfc_convert_type_warn (index
, &ts
, 2, 0);
4468 /* Resolve one part of an array index. */
4471 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4473 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4476 /* Resolve a dim argument to an intrinsic function. */
4479 gfc_resolve_dim_arg (gfc_expr
*dim
)
4484 if (!gfc_resolve_expr (dim
))
4489 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4494 if (dim
->ts
.type
!= BT_INTEGER
)
4496 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4500 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4505 ts
.type
= BT_INTEGER
;
4506 ts
.kind
= gfc_index_integer_kind
;
4508 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4514 /* Given an expression that contains array references, update those array
4515 references to point to the right array specifications. While this is
4516 filled in during matching, this information is difficult to save and load
4517 in a module, so we take care of it here.
4519 The idea here is that the original array reference comes from the
4520 base symbol. We traverse the list of reference structures, setting
4521 the stored reference to references. Component references can
4522 provide an additional array specification. */
4525 find_array_spec (gfc_expr
*e
)
4531 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4532 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4534 as
= e
->symtree
->n
.sym
->as
;
4536 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4541 gfc_internal_error ("find_array_spec(): Missing spec");
4548 c
= ref
->u
.c
.component
;
4549 if (c
->attr
.dimension
)
4552 gfc_internal_error ("find_array_spec(): unused as(1)");
4563 gfc_internal_error ("find_array_spec(): unused as(2)");
4567 /* Resolve an array reference. */
4570 resolve_array_ref (gfc_array_ref
*ar
)
4572 int i
, check_scalar
;
4575 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4577 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4579 /* Do not force gfc_index_integer_kind for the start. We can
4580 do fine with any integer kind. This avoids temporary arrays
4581 created for indexing with a vector. */
4582 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4584 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4586 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4591 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4595 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4599 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4600 if (e
->expr_type
== EXPR_VARIABLE
4601 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4602 ar
->start
[i
] = gfc_get_parentheses (e
);
4606 gfc_error ("Array index at %L is an array of rank %d",
4607 &ar
->c_where
[i
], e
->rank
);
4611 /* Fill in the upper bound, which may be lower than the
4612 specified one for something like a(2:10:5), which is
4613 identical to a(2:7:5). Only relevant for strides not equal
4614 to one. Don't try a division by zero. */
4615 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4616 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4617 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4618 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4622 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4624 if (ar
->end
[i
] == NULL
)
4627 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4629 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4631 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4632 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4634 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4645 if (ar
->type
== AR_FULL
)
4647 if (ar
->as
->rank
== 0)
4648 ar
->type
= AR_ELEMENT
;
4650 /* Make sure array is the same as array(:,:), this way
4651 we don't need to special case all the time. */
4652 ar
->dimen
= ar
->as
->rank
;
4653 for (i
= 0; i
< ar
->dimen
; i
++)
4655 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4657 gcc_assert (ar
->start
[i
] == NULL
);
4658 gcc_assert (ar
->end
[i
] == NULL
);
4659 gcc_assert (ar
->stride
[i
] == NULL
);
4663 /* If the reference type is unknown, figure out what kind it is. */
4665 if (ar
->type
== AR_UNKNOWN
)
4667 ar
->type
= AR_ELEMENT
;
4668 for (i
= 0; i
< ar
->dimen
; i
++)
4669 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4670 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4672 ar
->type
= AR_SECTION
;
4677 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4680 if (ar
->as
->corank
&& ar
->codimen
== 0)
4683 ar
->codimen
= ar
->as
->corank
;
4684 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4685 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4693 resolve_substring (gfc_ref
*ref
)
4695 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4697 if (ref
->u
.ss
.start
!= NULL
)
4699 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4702 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4704 gfc_error ("Substring start index at %L must be of type INTEGER",
4705 &ref
->u
.ss
.start
->where
);
4709 if (ref
->u
.ss
.start
->rank
!= 0)
4711 gfc_error ("Substring start index at %L must be scalar",
4712 &ref
->u
.ss
.start
->where
);
4716 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4717 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4718 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4720 gfc_error ("Substring start index at %L is less than one",
4721 &ref
->u
.ss
.start
->where
);
4726 if (ref
->u
.ss
.end
!= NULL
)
4728 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4731 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4733 gfc_error ("Substring end index at %L must be of type INTEGER",
4734 &ref
->u
.ss
.end
->where
);
4738 if (ref
->u
.ss
.end
->rank
!= 0)
4740 gfc_error ("Substring end index at %L must be scalar",
4741 &ref
->u
.ss
.end
->where
);
4745 if (ref
->u
.ss
.length
!= NULL
4746 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4747 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4748 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4750 gfc_error ("Substring end index at %L exceeds the string length",
4751 &ref
->u
.ss
.start
->where
);
4755 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4756 gfc_integer_kinds
[k
].huge
) == CMP_GT
4757 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4758 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4760 gfc_error ("Substring end index at %L is too large",
4761 &ref
->u
.ss
.end
->where
);
4770 /* This function supplies missing substring charlens. */
4773 gfc_resolve_substring_charlen (gfc_expr
*e
)
4776 gfc_expr
*start
, *end
;
4777 gfc_typespec
*ts
= NULL
;
4779 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4781 if (char_ref
->type
== REF_SUBSTRING
)
4783 if (char_ref
->type
== REF_COMPONENT
)
4784 ts
= &char_ref
->u
.c
.component
->ts
;
4790 gcc_assert (char_ref
->next
== NULL
);
4794 if (e
->ts
.u
.cl
->length
)
4795 gfc_free_expr (e
->ts
.u
.cl
->length
);
4796 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4800 e
->ts
.type
= BT_CHARACTER
;
4801 e
->ts
.kind
= gfc_default_character_kind
;
4804 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4806 if (char_ref
->u
.ss
.start
)
4807 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4809 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4811 if (char_ref
->u
.ss
.end
)
4812 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4813 else if (e
->expr_type
== EXPR_VARIABLE
)
4816 ts
= &e
->symtree
->n
.sym
->ts
;
4817 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4824 gfc_free_expr (start
);
4825 gfc_free_expr (end
);
4829 /* Length = (end - start + 1). */
4830 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4831 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4832 gfc_get_int_expr (gfc_default_integer_kind
,
4835 /* F2008, 6.4.1: Both the starting point and the ending point shall
4836 be within the range 1, 2, ..., n unless the starting point exceeds
4837 the ending point, in which case the substring has length zero. */
4839 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4840 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4842 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4843 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4845 /* Make sure that the length is simplified. */
4846 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4847 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4851 /* Resolve subtype references. */
4854 resolve_ref (gfc_expr
*expr
)
4856 int current_part_dimension
, n_components
, seen_part_dimension
;
4859 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4860 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4862 find_array_spec (expr
);
4866 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4870 if (!resolve_array_ref (&ref
->u
.ar
))
4878 if (!resolve_substring (ref
))
4883 /* Check constraints on part references. */
4885 current_part_dimension
= 0;
4886 seen_part_dimension
= 0;
4889 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4894 switch (ref
->u
.ar
.type
)
4897 /* Coarray scalar. */
4898 if (ref
->u
.ar
.as
->rank
== 0)
4900 current_part_dimension
= 0;
4905 current_part_dimension
= 1;
4909 current_part_dimension
= 0;
4913 gfc_internal_error ("resolve_ref(): Bad array reference");
4919 if (current_part_dimension
|| seen_part_dimension
)
4922 if (ref
->u
.c
.component
->attr
.pointer
4923 || ref
->u
.c
.component
->attr
.proc_pointer
4924 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4925 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4927 gfc_error ("Component to the right of a part reference "
4928 "with nonzero rank must not have the POINTER "
4929 "attribute at %L", &expr
->where
);
4932 else if (ref
->u
.c
.component
->attr
.allocatable
4933 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4934 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4937 gfc_error ("Component to the right of a part reference "
4938 "with nonzero rank must not have the ALLOCATABLE "
4939 "attribute at %L", &expr
->where
);
4951 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4952 || ref
->next
== NULL
)
4953 && current_part_dimension
4954 && seen_part_dimension
)
4956 gfc_error ("Two or more part references with nonzero rank must "
4957 "not be specified at %L", &expr
->where
);
4961 if (ref
->type
== REF_COMPONENT
)
4963 if (current_part_dimension
)
4964 seen_part_dimension
= 1;
4966 /* reset to make sure */
4967 current_part_dimension
= 0;
4975 /* Given an expression, determine its shape. This is easier than it sounds.
4976 Leaves the shape array NULL if it is not possible to determine the shape. */
4979 expression_shape (gfc_expr
*e
)
4981 mpz_t array
[GFC_MAX_DIMENSIONS
];
4984 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4987 for (i
= 0; i
< e
->rank
; i
++)
4988 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4991 e
->shape
= gfc_get_shape (e
->rank
);
4993 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4998 for (i
--; i
>= 0; i
--)
4999 mpz_clear (array
[i
]);
5003 /* Given a variable expression node, compute the rank of the expression by
5004 examining the base symbol and any reference structures it may have. */
5007 expression_rank (gfc_expr
*e
)
5012 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5013 could lead to serious confusion... */
5014 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5018 if (e
->expr_type
== EXPR_ARRAY
)
5020 /* Constructors can have a rank different from one via RESHAPE(). */
5022 if (e
->symtree
== NULL
)
5028 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5029 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5035 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5037 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5038 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5039 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5041 if (ref
->type
!= REF_ARRAY
)
5044 if (ref
->u
.ar
.type
== AR_FULL
)
5046 rank
= ref
->u
.ar
.as
->rank
;
5050 if (ref
->u
.ar
.type
== AR_SECTION
)
5052 /* Figure out the rank of the section. */
5054 gfc_internal_error ("expression_rank(): Two array specs");
5056 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5057 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5058 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5068 expression_shape (e
);
5073 add_caf_get_intrinsic (gfc_expr
*e
)
5075 gfc_expr
*wrapper
, *tmp_expr
;
5079 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5080 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5085 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5086 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5089 tmp_expr
= XCNEW (gfc_expr
);
5091 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5092 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5093 wrapper
->ts
= e
->ts
;
5094 wrapper
->rank
= e
->rank
;
5096 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5103 remove_caf_get_intrinsic (gfc_expr
*e
)
5105 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5106 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5107 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5108 e
->value
.function
.actual
->expr
= NULL
;
5109 gfc_free_actual_arglist (e
->value
.function
.actual
);
5110 gfc_free_shape (&e
->shape
, e
->rank
);
5116 /* Resolve a variable expression. */
5119 resolve_variable (gfc_expr
*e
)
5126 if (e
->symtree
== NULL
)
5128 sym
= e
->symtree
->n
.sym
;
5130 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5131 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5132 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5134 if (!actual_arg
|| inquiry_argument
)
5136 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5137 "be used as actual argument", sym
->name
, &e
->where
);
5141 /* TS 29113, 407b. */
5142 else if (e
->ts
.type
== BT_ASSUMED
)
5146 gfc_error ("Assumed-type variable %s at %L may only be used "
5147 "as actual argument", sym
->name
, &e
->where
);
5150 else if (inquiry_argument
&& !first_actual_arg
)
5152 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5153 for all inquiry functions in resolve_function; the reason is
5154 that the function-name resolution happens too late in that
5156 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5157 "an inquiry function shall be the first argument",
5158 sym
->name
, &e
->where
);
5162 /* TS 29113, C535b. */
5163 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5164 && CLASS_DATA (sym
)->as
5165 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5166 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5167 && sym
->as
->type
== AS_ASSUMED_RANK
))
5171 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5172 "actual argument", sym
->name
, &e
->where
);
5175 else if (inquiry_argument
&& !first_actual_arg
)
5177 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5178 for all inquiry functions in resolve_function; the reason is
5179 that the function-name resolution happens too late in that
5181 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5182 "to an inquiry function shall be the first argument",
5183 sym
->name
, &e
->where
);
5188 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5189 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5190 && e
->ref
->next
== NULL
))
5192 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5193 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5196 /* TS 29113, 407b. */
5197 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5198 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5199 && e
->ref
->next
== NULL
))
5201 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5202 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5206 /* TS 29113, C535b. */
5207 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5208 && CLASS_DATA (sym
)->as
5209 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5210 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5211 && sym
->as
->type
== AS_ASSUMED_RANK
))
5213 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5214 && e
->ref
->next
== NULL
))
5216 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5217 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5221 /* For variables that are used in an associate (target => object) where
5222 the object's basetype is array valued while the target is scalar,
5223 the ts' type of the component refs is still array valued, which
5224 can't be translated that way. */
5225 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5226 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5227 && CLASS_DATA (sym
->assoc
->target
)->as
)
5229 gfc_ref
*ref
= e
->ref
;
5235 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5236 /* Stop the loop. */
5246 /* If this is an associate-name, it may be parsed with an array reference
5247 in error even though the target is scalar. Fail directly in this case.
5248 TODO Understand why class scalar expressions must be excluded. */
5249 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5251 if (sym
->ts
.type
== BT_CLASS
)
5252 gfc_fix_class_refs (e
);
5253 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5257 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5258 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5260 /* On the other hand, the parser may not have known this is an array;
5261 in this case, we have to add a FULL reference. */
5262 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5264 e
->ref
= gfc_get_ref ();
5265 e
->ref
->type
= REF_ARRAY
;
5266 e
->ref
->u
.ar
.type
= AR_FULL
;
5267 e
->ref
->u
.ar
.dimen
= 0;
5270 /* Like above, but for class types, where the checking whether an array
5271 ref is present is more complicated. Furthermore make sure not to add
5272 the full array ref to _vptr or _len refs. */
5273 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5274 && CLASS_DATA (sym
)->attr
.dimension
5275 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5277 gfc_ref
*ref
, *newref
;
5279 newref
= gfc_get_ref ();
5280 newref
->type
= REF_ARRAY
;
5281 newref
->u
.ar
.type
= AR_FULL
;
5282 newref
->u
.ar
.dimen
= 0;
5283 /* Because this is an associate var and the first ref either is a ref to
5284 the _data component or not, no traversal of the ref chain is
5285 needed. The array ref needs to be inserted after the _data ref,
5286 or when that is not present, which may happend for polymorphic
5287 types, then at the first position. */
5291 else if (ref
->type
== REF_COMPONENT
5292 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5294 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5296 newref
->next
= ref
->next
;
5300 /* Array ref present already. */
5301 gfc_free_ref_list (newref
);
5303 else if (ref
->type
== REF_ARRAY
)
5304 /* Array ref present already. */
5305 gfc_free_ref_list (newref
);
5313 if (e
->ref
&& !resolve_ref (e
))
5316 if (sym
->attr
.flavor
== FL_PROCEDURE
5317 && (!sym
->attr
.function
5318 || (sym
->attr
.function
&& sym
->result
5319 && sym
->result
->attr
.proc_pointer
5320 && !sym
->result
->attr
.function
)))
5322 e
->ts
.type
= BT_PROCEDURE
;
5323 goto resolve_procedure
;
5326 if (sym
->ts
.type
!= BT_UNKNOWN
)
5327 gfc_variable_attr (e
, &e
->ts
);
5328 else if (sym
->attr
.flavor
== FL_PROCEDURE
5329 && sym
->attr
.function
&& sym
->result
5330 && sym
->result
->ts
.type
!= BT_UNKNOWN
5331 && sym
->result
->attr
.proc_pointer
)
5332 e
->ts
= sym
->result
->ts
;
5335 /* Must be a simple variable reference. */
5336 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5341 if (check_assumed_size_reference (sym
, e
))
5344 /* Deal with forward references to entries during gfc_resolve_code, to
5345 satisfy, at least partially, 12.5.2.5. */
5346 if (gfc_current_ns
->entries
5347 && current_entry_id
== sym
->entry_id
5350 && cs_base
->current
->op
!= EXEC_ENTRY
)
5352 gfc_entry_list
*entry
;
5353 gfc_formal_arglist
*formal
;
5355 bool seen
, saved_specification_expr
;
5357 /* If the symbol is a dummy... */
5358 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5360 entry
= gfc_current_ns
->entries
;
5363 /* ...test if the symbol is a parameter of previous entries. */
5364 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5365 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5367 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5374 /* If it has not been seen as a dummy, this is an error. */
5377 if (specification_expr
)
5378 gfc_error ("Variable %qs, used in a specification expression"
5379 ", is referenced at %L before the ENTRY statement "
5380 "in which it is a parameter",
5381 sym
->name
, &cs_base
->current
->loc
);
5383 gfc_error ("Variable %qs is used at %L before the ENTRY "
5384 "statement in which it is a parameter",
5385 sym
->name
, &cs_base
->current
->loc
);
5390 /* Now do the same check on the specification expressions. */
5391 saved_specification_expr
= specification_expr
;
5392 specification_expr
= true;
5393 if (sym
->ts
.type
== BT_CHARACTER
5394 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5398 for (n
= 0; n
< sym
->as
->rank
; n
++)
5400 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5402 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5405 specification_expr
= saved_specification_expr
;
5408 /* Update the symbol's entry level. */
5409 sym
->entry_id
= current_entry_id
+ 1;
5412 /* If a symbol has been host_associated mark it. This is used latter,
5413 to identify if aliasing is possible via host association. */
5414 if (sym
->attr
.flavor
== FL_VARIABLE
5415 && gfc_current_ns
->parent
5416 && (gfc_current_ns
->parent
== sym
->ns
5417 || (gfc_current_ns
->parent
->parent
5418 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5419 sym
->attr
.host_assoc
= 1;
5421 if (gfc_current_ns
->proc_name
5422 && sym
->attr
.dimension
5423 && (sym
->ns
!= gfc_current_ns
5424 || sym
->attr
.use_assoc
5425 || sym
->attr
.in_common
))
5426 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5429 if (t
&& !resolve_procedure_expression (e
))
5432 /* F2008, C617 and C1229. */
5433 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5434 && gfc_is_coindexed (e
))
5436 gfc_ref
*ref
, *ref2
= NULL
;
5438 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5440 if (ref
->type
== REF_COMPONENT
)
5442 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5446 for ( ; ref
; ref
= ref
->next
)
5447 if (ref
->type
== REF_COMPONENT
)
5450 /* Expression itself is not coindexed object. */
5451 if (ref
&& e
->ts
.type
== BT_CLASS
)
5453 gfc_error ("Polymorphic subobject of coindexed object at %L",
5458 /* Expression itself is coindexed object. */
5462 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5463 for ( ; c
; c
= c
->next
)
5464 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5466 gfc_error ("Coindexed object with polymorphic allocatable "
5467 "subcomponent at %L", &e
->where
);
5475 expression_rank (e
);
5477 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5478 add_caf_get_intrinsic (e
);
5484 /* Checks to see that the correct symbol has been host associated.
5485 The only situation where this arises is that in which a twice
5486 contained function is parsed after the host association is made.
5487 Therefore, on detecting this, change the symbol in the expression
5488 and convert the array reference into an actual arglist if the old
5489 symbol is a variable. */
5491 check_host_association (gfc_expr
*e
)
5493 gfc_symbol
*sym
, *old_sym
;
5497 gfc_actual_arglist
*arg
, *tail
= NULL
;
5498 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5500 /* If the expression is the result of substitution in
5501 interface.c(gfc_extend_expr) because there is no way in
5502 which the host association can be wrong. */
5503 if (e
->symtree
== NULL
5504 || e
->symtree
->n
.sym
== NULL
5505 || e
->user_operator
)
5508 old_sym
= e
->symtree
->n
.sym
;
5510 if (gfc_current_ns
->parent
5511 && old_sym
->ns
!= gfc_current_ns
)
5513 /* Use the 'USE' name so that renamed module symbols are
5514 correctly handled. */
5515 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5517 if (sym
&& old_sym
!= sym
5518 && sym
->ts
.type
== old_sym
->ts
.type
5519 && sym
->attr
.flavor
== FL_PROCEDURE
5520 && sym
->attr
.contained
)
5522 /* Clear the shape, since it might not be valid. */
5523 gfc_free_shape (&e
->shape
, e
->rank
);
5525 /* Give the expression the right symtree! */
5526 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5527 gcc_assert (st
!= NULL
);
5529 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5530 || e
->expr_type
== EXPR_FUNCTION
)
5532 /* Original was function so point to the new symbol, since
5533 the actual argument list is already attached to the
5535 e
->value
.function
.esym
= NULL
;
5540 /* Original was variable so convert array references into
5541 an actual arglist. This does not need any checking now
5542 since resolve_function will take care of it. */
5543 e
->value
.function
.actual
= NULL
;
5544 e
->expr_type
= EXPR_FUNCTION
;
5547 /* Ambiguity will not arise if the array reference is not
5548 the last reference. */
5549 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5550 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5553 gcc_assert (ref
->type
== REF_ARRAY
);
5555 /* Grab the start expressions from the array ref and
5556 copy them into actual arguments. */
5557 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5559 arg
= gfc_get_actual_arglist ();
5560 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5561 if (e
->value
.function
.actual
== NULL
)
5562 tail
= e
->value
.function
.actual
= arg
;
5570 /* Dump the reference list and set the rank. */
5571 gfc_free_ref_list (e
->ref
);
5573 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5576 gfc_resolve_expr (e
);
5580 /* This might have changed! */
5581 return e
->expr_type
== EXPR_FUNCTION
;
5586 gfc_resolve_character_operator (gfc_expr
*e
)
5588 gfc_expr
*op1
= e
->value
.op
.op1
;
5589 gfc_expr
*op2
= e
->value
.op
.op2
;
5590 gfc_expr
*e1
= NULL
;
5591 gfc_expr
*e2
= NULL
;
5593 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5595 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5596 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5597 else if (op1
->expr_type
== EXPR_CONSTANT
)
5598 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5599 op1
->value
.character
.length
);
5601 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5602 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5603 else if (op2
->expr_type
== EXPR_CONSTANT
)
5604 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5605 op2
->value
.character
.length
);
5607 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5617 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5618 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5619 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5620 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5621 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5627 /* Ensure that an character expression has a charlen and, if possible, a
5628 length expression. */
5631 fixup_charlen (gfc_expr
*e
)
5633 /* The cases fall through so that changes in expression type and the need
5634 for multiple fixes are picked up. In all circumstances, a charlen should
5635 be available for the middle end to hang a backend_decl on. */
5636 switch (e
->expr_type
)
5639 gfc_resolve_character_operator (e
);
5643 if (e
->expr_type
== EXPR_ARRAY
)
5644 gfc_resolve_character_array_constructor (e
);
5647 case EXPR_SUBSTRING
:
5648 if (!e
->ts
.u
.cl
&& e
->ref
)
5649 gfc_resolve_substring_charlen (e
);
5654 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5661 /* Update an actual argument to include the passed-object for type-bound
5662 procedures at the right position. */
5664 static gfc_actual_arglist
*
5665 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5668 gcc_assert (argpos
> 0);
5672 gfc_actual_arglist
* result
;
5674 result
= gfc_get_actual_arglist ();
5678 result
->name
= name
;
5684 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5686 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5691 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5694 extract_compcall_passed_object (gfc_expr
* e
)
5698 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5700 if (e
->value
.compcall
.base_object
)
5701 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5704 po
= gfc_get_expr ();
5705 po
->expr_type
= EXPR_VARIABLE
;
5706 po
->symtree
= e
->symtree
;
5707 po
->ref
= gfc_copy_ref (e
->ref
);
5708 po
->where
= e
->where
;
5711 if (!gfc_resolve_expr (po
))
5718 /* Update the arglist of an EXPR_COMPCALL expression to include the
5722 update_compcall_arglist (gfc_expr
* e
)
5725 gfc_typebound_proc
* tbp
;
5727 tbp
= e
->value
.compcall
.tbp
;
5732 po
= extract_compcall_passed_object (e
);
5736 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5742 gcc_assert (tbp
->pass_arg_num
> 0);
5743 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5751 /* Extract the passed object from a PPC call (a copy of it). */
5754 extract_ppc_passed_object (gfc_expr
*e
)
5759 po
= gfc_get_expr ();
5760 po
->expr_type
= EXPR_VARIABLE
;
5761 po
->symtree
= e
->symtree
;
5762 po
->ref
= gfc_copy_ref (e
->ref
);
5763 po
->where
= e
->where
;
5765 /* Remove PPC reference. */
5767 while ((*ref
)->next
)
5768 ref
= &(*ref
)->next
;
5769 gfc_free_ref_list (*ref
);
5772 if (!gfc_resolve_expr (po
))
5779 /* Update the actual arglist of a procedure pointer component to include the
5783 update_ppc_arglist (gfc_expr
* e
)
5787 gfc_typebound_proc
* tb
;
5789 ppc
= gfc_get_proc_ptr_comp (e
);
5797 else if (tb
->nopass
)
5800 po
= extract_ppc_passed_object (e
);
5807 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5812 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5814 gfc_error ("Base object for procedure-pointer component call at %L is of"
5815 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5819 gcc_assert (tb
->pass_arg_num
> 0);
5820 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5828 /* Check that the object a TBP is called on is valid, i.e. it must not be
5829 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5832 check_typebound_baseobject (gfc_expr
* e
)
5835 bool return_value
= false;
5837 base
= extract_compcall_passed_object (e
);
5841 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5843 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5847 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5849 gfc_error ("Base object for type-bound procedure call at %L is of"
5850 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5854 /* F08:C1230. If the procedure called is NOPASS,
5855 the base object must be scalar. */
5856 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5858 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5859 " be scalar", &e
->where
);
5863 return_value
= true;
5866 gfc_free_expr (base
);
5867 return return_value
;
5871 /* Resolve a call to a type-bound procedure, either function or subroutine,
5872 statically from the data in an EXPR_COMPCALL expression. The adapted
5873 arglist and the target-procedure symtree are returned. */
5876 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5877 gfc_actual_arglist
** actual
)
5879 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5880 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5882 /* Update the actual arglist for PASS. */
5883 if (!update_compcall_arglist (e
))
5886 *actual
= e
->value
.compcall
.actual
;
5887 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5889 gfc_free_ref_list (e
->ref
);
5891 e
->value
.compcall
.actual
= NULL
;
5893 /* If we find a deferred typebound procedure, check for derived types
5894 that an overriding typebound procedure has not been missed. */
5895 if (e
->value
.compcall
.name
5896 && !e
->value
.compcall
.tbp
->non_overridable
5897 && e
->value
.compcall
.base_object
5898 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5901 gfc_symbol
*derived
;
5903 /* Use the derived type of the base_object. */
5904 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5907 /* If necessary, go through the inheritance chain. */
5908 while (!st
&& derived
)
5910 /* Look for the typebound procedure 'name'. */
5911 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5912 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5913 e
->value
.compcall
.name
);
5915 derived
= gfc_get_derived_super_type (derived
);
5918 /* Now find the specific name in the derived type namespace. */
5919 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5920 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5921 derived
->ns
, 1, &st
);
5929 /* Get the ultimate declared type from an expression. In addition,
5930 return the last class/derived type reference and the copy of the
5931 reference list. If check_types is set true, derived types are
5932 identified as well as class references. */
5934 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5935 gfc_expr
*e
, bool check_types
)
5937 gfc_symbol
*declared
;
5944 *new_ref
= gfc_copy_ref (e
->ref
);
5946 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5948 if (ref
->type
!= REF_COMPONENT
)
5951 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5952 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
5953 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5955 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5961 if (declared
== NULL
)
5962 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5968 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5969 which of the specific bindings (if any) matches the arglist and transform
5970 the expression into a call of that binding. */
5973 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5975 gfc_typebound_proc
* genproc
;
5976 const char* genname
;
5978 gfc_symbol
*derived
;
5980 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5981 genname
= e
->value
.compcall
.name
;
5982 genproc
= e
->value
.compcall
.tbp
;
5984 if (!genproc
->is_generic
)
5987 /* Try the bindings on this type and in the inheritance hierarchy. */
5988 for (; genproc
; genproc
= genproc
->overridden
)
5992 gcc_assert (genproc
->is_generic
);
5993 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5996 gfc_actual_arglist
* args
;
5999 gcc_assert (g
->specific
);
6001 if (g
->specific
->error
)
6004 target
= g
->specific
->u
.specific
->n
.sym
;
6006 /* Get the right arglist by handling PASS/NOPASS. */
6007 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6008 if (!g
->specific
->nopass
)
6011 po
= extract_compcall_passed_object (e
);
6014 gfc_free_actual_arglist (args
);
6018 gcc_assert (g
->specific
->pass_arg_num
> 0);
6019 gcc_assert (!g
->specific
->error
);
6020 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6021 g
->specific
->pass_arg
);
6023 resolve_actual_arglist (args
, target
->attr
.proc
,
6024 is_external_proc (target
)
6025 && gfc_sym_get_dummy_args (target
) == NULL
);
6027 /* Check if this arglist matches the formal. */
6028 matches
= gfc_arglist_matches_symbol (&args
, target
);
6030 /* Clean up and break out of the loop if we've found it. */
6031 gfc_free_actual_arglist (args
);
6034 e
->value
.compcall
.tbp
= g
->specific
;
6035 genname
= g
->specific_st
->name
;
6036 /* Pass along the name for CLASS methods, where the vtab
6037 procedure pointer component has to be referenced. */
6045 /* Nothing matching found! */
6046 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6047 " %qs at %L", genname
, &e
->where
);
6051 /* Make sure that we have the right specific instance for the name. */
6052 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6054 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6056 e
->value
.compcall
.tbp
= st
->n
.tb
;
6062 /* Resolve a call to a type-bound subroutine. */
6065 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6067 gfc_actual_arglist
* newactual
;
6068 gfc_symtree
* target
;
6070 /* Check that's really a SUBROUTINE. */
6071 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6073 gfc_error ("%qs at %L should be a SUBROUTINE",
6074 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6078 if (!check_typebound_baseobject (c
->expr1
))
6081 /* Pass along the name for CLASS methods, where the vtab
6082 procedure pointer component has to be referenced. */
6084 *name
= c
->expr1
->value
.compcall
.name
;
6086 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6089 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6091 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6093 /* Transform into an ordinary EXEC_CALL for now. */
6095 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6098 c
->ext
.actual
= newactual
;
6099 c
->symtree
= target
;
6100 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6102 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6104 gfc_free_expr (c
->expr1
);
6105 c
->expr1
= gfc_get_expr ();
6106 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6107 c
->expr1
->symtree
= target
;
6108 c
->expr1
->where
= c
->loc
;
6110 return resolve_call (c
);
6114 /* Resolve a component-call expression. */
6116 resolve_compcall (gfc_expr
* e
, const char **name
)
6118 gfc_actual_arglist
* newactual
;
6119 gfc_symtree
* target
;
6121 /* Check that's really a FUNCTION. */
6122 if (!e
->value
.compcall
.tbp
->function
)
6124 gfc_error ("%qs at %L should be a FUNCTION",
6125 e
->value
.compcall
.name
, &e
->where
);
6129 /* These must not be assign-calls! */
6130 gcc_assert (!e
->value
.compcall
.assign
);
6132 if (!check_typebound_baseobject (e
))
6135 /* Pass along the name for CLASS methods, where the vtab
6136 procedure pointer component has to be referenced. */
6138 *name
= e
->value
.compcall
.name
;
6140 if (!resolve_typebound_generic_call (e
, name
))
6142 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6144 /* Take the rank from the function's symbol. */
6145 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6146 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6148 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6149 arglist to the TBP's binding target. */
6151 if (!resolve_typebound_static (e
, &target
, &newactual
))
6154 e
->value
.function
.actual
= newactual
;
6155 e
->value
.function
.name
= NULL
;
6156 e
->value
.function
.esym
= target
->n
.sym
;
6157 e
->value
.function
.isym
= NULL
;
6158 e
->symtree
= target
;
6159 e
->ts
= target
->n
.sym
->ts
;
6160 e
->expr_type
= EXPR_FUNCTION
;
6162 /* Resolution is not necessary if this is a class subroutine; this
6163 function only has to identify the specific proc. Resolution of
6164 the call will be done next in resolve_typebound_call. */
6165 return gfc_resolve_expr (e
);
6169 static bool resolve_fl_derived (gfc_symbol
*sym
);
6172 /* Resolve a typebound function, or 'method'. First separate all
6173 the non-CLASS references by calling resolve_compcall directly. */
6176 resolve_typebound_function (gfc_expr
* e
)
6178 gfc_symbol
*declared
;
6190 /* Deal with typebound operators for CLASS objects. */
6191 expr
= e
->value
.compcall
.base_object
;
6192 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6193 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6195 /* If the base_object is not a variable, the corresponding actual
6196 argument expression must be stored in e->base_expression so
6197 that the corresponding tree temporary can be used as the base
6198 object in gfc_conv_procedure_call. */
6199 if (expr
->expr_type
!= EXPR_VARIABLE
)
6201 gfc_actual_arglist
*args
;
6203 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6205 if (expr
== args
->expr
)
6210 /* Since the typebound operators are generic, we have to ensure
6211 that any delays in resolution are corrected and that the vtab
6214 declared
= ts
.u
.derived
;
6215 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6216 if (c
->ts
.u
.derived
== NULL
)
6217 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6219 if (!resolve_compcall (e
, &name
))
6222 /* Use the generic name if it is there. */
6223 name
= name
? name
: e
->value
.function
.esym
->name
;
6224 e
->symtree
= expr
->symtree
;
6225 e
->ref
= gfc_copy_ref (expr
->ref
);
6226 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6228 /* Trim away the extraneous references that emerge from nested
6229 use of interface.c (extend_expr). */
6230 if (class_ref
&& class_ref
->next
)
6232 gfc_free_ref_list (class_ref
->next
);
6233 class_ref
->next
= NULL
;
6235 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6237 gfc_free_ref_list (e
->ref
);
6241 gfc_add_vptr_component (e
);
6242 gfc_add_component_ref (e
, name
);
6243 e
->value
.function
.esym
= NULL
;
6244 if (expr
->expr_type
!= EXPR_VARIABLE
)
6245 e
->base_expr
= expr
;
6250 return resolve_compcall (e
, NULL
);
6252 if (!resolve_ref (e
))
6255 /* Get the CLASS declared type. */
6256 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6258 if (!resolve_fl_derived (declared
))
6261 /* Weed out cases of the ultimate component being a derived type. */
6262 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6263 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6265 gfc_free_ref_list (new_ref
);
6266 return resolve_compcall (e
, NULL
);
6269 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6270 declared
= c
->ts
.u
.derived
;
6272 /* Treat the call as if it is a typebound procedure, in order to roll
6273 out the correct name for the specific function. */
6274 if (!resolve_compcall (e
, &name
))
6276 gfc_free_ref_list (new_ref
);
6283 /* Convert the expression to a procedure pointer component call. */
6284 e
->value
.function
.esym
= NULL
;
6290 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6291 gfc_add_vptr_component (e
);
6292 gfc_add_component_ref (e
, name
);
6294 /* Recover the typespec for the expression. This is really only
6295 necessary for generic procedures, where the additional call
6296 to gfc_add_component_ref seems to throw the collection of the
6297 correct typespec. */
6301 gfc_free_ref_list (new_ref
);
6306 /* Resolve a typebound subroutine, or 'method'. First separate all
6307 the non-CLASS references by calling resolve_typebound_call
6311 resolve_typebound_subroutine (gfc_code
*code
)
6313 gfc_symbol
*declared
;
6323 st
= code
->expr1
->symtree
;
6325 /* Deal with typebound operators for CLASS objects. */
6326 expr
= code
->expr1
->value
.compcall
.base_object
;
6327 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6328 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6330 /* If the base_object is not a variable, the corresponding actual
6331 argument expression must be stored in e->base_expression so
6332 that the corresponding tree temporary can be used as the base
6333 object in gfc_conv_procedure_call. */
6334 if (expr
->expr_type
!= EXPR_VARIABLE
)
6336 gfc_actual_arglist
*args
;
6338 args
= code
->expr1
->value
.function
.actual
;
6339 for (; args
; args
= args
->next
)
6340 if (expr
== args
->expr
)
6344 /* Since the typebound operators are generic, we have to ensure
6345 that any delays in resolution are corrected and that the vtab
6347 declared
= expr
->ts
.u
.derived
;
6348 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6349 if (c
->ts
.u
.derived
== NULL
)
6350 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6352 if (!resolve_typebound_call (code
, &name
, NULL
))
6355 /* Use the generic name if it is there. */
6356 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6357 code
->expr1
->symtree
= expr
->symtree
;
6358 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6360 /* Trim away the extraneous references that emerge from nested
6361 use of interface.c (extend_expr). */
6362 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6363 if (class_ref
&& class_ref
->next
)
6365 gfc_free_ref_list (class_ref
->next
);
6366 class_ref
->next
= NULL
;
6368 else if (code
->expr1
->ref
&& !class_ref
)
6370 gfc_free_ref_list (code
->expr1
->ref
);
6371 code
->expr1
->ref
= NULL
;
6374 /* Now use the procedure in the vtable. */
6375 gfc_add_vptr_component (code
->expr1
);
6376 gfc_add_component_ref (code
->expr1
, name
);
6377 code
->expr1
->value
.function
.esym
= NULL
;
6378 if (expr
->expr_type
!= EXPR_VARIABLE
)
6379 code
->expr1
->base_expr
= expr
;
6384 return resolve_typebound_call (code
, NULL
, NULL
);
6386 if (!resolve_ref (code
->expr1
))
6389 /* Get the CLASS declared type. */
6390 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6392 /* Weed out cases of the ultimate component being a derived type. */
6393 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6394 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6396 gfc_free_ref_list (new_ref
);
6397 return resolve_typebound_call (code
, NULL
, NULL
);
6400 if (!resolve_typebound_call (code
, &name
, &overridable
))
6402 gfc_free_ref_list (new_ref
);
6405 ts
= code
->expr1
->ts
;
6409 /* Convert the expression to a procedure pointer component call. */
6410 code
->expr1
->value
.function
.esym
= NULL
;
6411 code
->expr1
->symtree
= st
;
6414 code
->expr1
->ref
= new_ref
;
6416 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6417 gfc_add_vptr_component (code
->expr1
);
6418 gfc_add_component_ref (code
->expr1
, name
);
6420 /* Recover the typespec for the expression. This is really only
6421 necessary for generic procedures, where the additional call
6422 to gfc_add_component_ref seems to throw the collection of the
6423 correct typespec. */
6424 code
->expr1
->ts
= ts
;
6427 gfc_free_ref_list (new_ref
);
6433 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6436 resolve_ppc_call (gfc_code
* c
)
6438 gfc_component
*comp
;
6440 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6441 gcc_assert (comp
!= NULL
);
6443 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6444 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6446 if (!comp
->attr
.subroutine
)
6447 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6449 if (!resolve_ref (c
->expr1
))
6452 if (!update_ppc_arglist (c
->expr1
))
6455 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6457 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6458 !(comp
->ts
.interface
6459 && comp
->ts
.interface
->formal
)))
6462 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6465 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6471 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6474 resolve_expr_ppc (gfc_expr
* e
)
6476 gfc_component
*comp
;
6478 comp
= gfc_get_proc_ptr_comp (e
);
6479 gcc_assert (comp
!= NULL
);
6481 /* Convert to EXPR_FUNCTION. */
6482 e
->expr_type
= EXPR_FUNCTION
;
6483 e
->value
.function
.isym
= NULL
;
6484 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6486 if (comp
->as
!= NULL
)
6487 e
->rank
= comp
->as
->rank
;
6489 if (!comp
->attr
.function
)
6490 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6492 if (!resolve_ref (e
))
6495 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6496 !(comp
->ts
.interface
6497 && comp
->ts
.interface
->formal
)))
6500 if (!update_ppc_arglist (e
))
6503 if (!check_pure_function(e
))
6506 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6513 gfc_is_expandable_expr (gfc_expr
*e
)
6515 gfc_constructor
*con
;
6517 if (e
->expr_type
== EXPR_ARRAY
)
6519 /* Traverse the constructor looking for variables that are flavor
6520 parameter. Parameters must be expanded since they are fully used at
6522 con
= gfc_constructor_first (e
->value
.constructor
);
6523 for (; con
; con
= gfc_constructor_next (con
))
6525 if (con
->expr
->expr_type
== EXPR_VARIABLE
6526 && con
->expr
->symtree
6527 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6528 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6530 if (con
->expr
->expr_type
== EXPR_ARRAY
6531 && gfc_is_expandable_expr (con
->expr
))
6540 /* Sometimes variables in specification expressions of the result
6541 of module procedures in submodules wind up not being the 'real'
6542 dummy. Find this, if possible, in the namespace of the first
6546 fixup_unique_dummy (gfc_expr
*e
)
6548 gfc_symtree
*st
= NULL
;
6549 gfc_symbol
*s
= NULL
;
6551 if (e
->symtree
->n
.sym
->ns
->proc_name
6552 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6553 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6556 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6559 && st
->n
.sym
!= NULL
6560 && st
->n
.sym
->attr
.dummy
)
6564 /* Resolve an expression. That is, make sure that types of operands agree
6565 with their operators, intrinsic operators are converted to function calls
6566 for overloaded types and unresolved function references are resolved. */
6569 gfc_resolve_expr (gfc_expr
*e
)
6572 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6577 /* inquiry_argument only applies to variables. */
6578 inquiry_save
= inquiry_argument
;
6579 actual_arg_save
= actual_arg
;
6580 first_actual_arg_save
= first_actual_arg
;
6582 if (e
->expr_type
!= EXPR_VARIABLE
)
6584 inquiry_argument
= false;
6586 first_actual_arg
= false;
6588 else if (e
->symtree
!= NULL
6589 && *e
->symtree
->name
== '@'
6590 && e
->symtree
->n
.sym
->attr
.dummy
)
6592 /* Deal with submodule specification expressions that are not
6593 found to be referenced in module.c(read_cleanup). */
6594 fixup_unique_dummy (e
);
6597 switch (e
->expr_type
)
6600 t
= resolve_operator (e
);
6606 if (check_host_association (e
))
6607 t
= resolve_function (e
);
6609 t
= resolve_variable (e
);
6611 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6612 && e
->ref
->type
!= REF_SUBSTRING
)
6613 gfc_resolve_substring_charlen (e
);
6618 t
= resolve_typebound_function (e
);
6621 case EXPR_SUBSTRING
:
6622 t
= resolve_ref (e
);
6631 t
= resolve_expr_ppc (e
);
6636 if (!resolve_ref (e
))
6639 t
= gfc_resolve_array_constructor (e
);
6640 /* Also try to expand a constructor. */
6643 expression_rank (e
);
6644 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6645 gfc_expand_constructor (e
, false);
6648 /* This provides the opportunity for the length of constructors with
6649 character valued function elements to propagate the string length
6650 to the expression. */
6651 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6653 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6654 here rather then add a duplicate test for it above. */
6655 gfc_expand_constructor (e
, false);
6656 t
= gfc_resolve_character_array_constructor (e
);
6661 case EXPR_STRUCTURE
:
6662 t
= resolve_ref (e
);
6666 t
= resolve_structure_cons (e
, 0);
6670 t
= gfc_simplify_expr (e
, 0);
6674 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6677 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6680 inquiry_argument
= inquiry_save
;
6681 actual_arg
= actual_arg_save
;
6682 first_actual_arg
= first_actual_arg_save
;
6688 /* Resolve an expression from an iterator. They must be scalar and have
6689 INTEGER or (optionally) REAL type. */
6692 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6693 const char *name_msgid
)
6695 if (!gfc_resolve_expr (expr
))
6698 if (expr
->rank
!= 0)
6700 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6704 if (expr
->ts
.type
!= BT_INTEGER
)
6706 if (expr
->ts
.type
== BT_REAL
)
6709 return gfc_notify_std (GFC_STD_F95_DEL
,
6710 "%s at %L must be integer",
6711 _(name_msgid
), &expr
->where
);
6714 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6721 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6729 /* Resolve the expressions in an iterator structure. If REAL_OK is
6730 false allow only INTEGER type iterators, otherwise allow REAL types.
6731 Set own_scope to true for ac-implied-do and data-implied-do as those
6732 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6735 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6737 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6740 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6741 _("iterator variable")))
6744 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6745 "Start expression in DO loop"))
6748 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6749 "End expression in DO loop"))
6752 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6753 "Step expression in DO loop"))
6756 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6758 if ((iter
->step
->ts
.type
== BT_INTEGER
6759 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6760 || (iter
->step
->ts
.type
== BT_REAL
6761 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6763 gfc_error ("Step expression in DO loop at %L cannot be zero",
6764 &iter
->step
->where
);
6769 /* Convert start, end, and step to the same type as var. */
6770 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6771 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6772 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6774 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6775 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6776 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6778 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6779 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6780 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
6782 if (iter
->start
->expr_type
== EXPR_CONSTANT
6783 && iter
->end
->expr_type
== EXPR_CONSTANT
6784 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6787 if (iter
->start
->ts
.type
== BT_INTEGER
)
6789 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6790 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6794 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6795 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6797 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6798 gfc_warning (OPT_Wzerotrip
,
6799 "DO loop at %L will be executed zero times",
6800 &iter
->step
->where
);
6803 if (iter
->end
->expr_type
== EXPR_CONSTANT
6804 && iter
->end
->ts
.type
== BT_INTEGER
6805 && iter
->step
->expr_type
== EXPR_CONSTANT
6806 && iter
->step
->ts
.type
== BT_INTEGER
6807 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
6808 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
6810 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
6811 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
6813 if (is_step_positive
6814 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
6815 gfc_warning (OPT_Wundefined_do_loop
,
6816 "DO loop at %L is undefined as it overflows",
6817 &iter
->step
->where
);
6818 else if (!is_step_positive
6819 && mpz_cmp (iter
->end
->value
.integer
,
6820 gfc_integer_kinds
[k
].min_int
) == 0)
6821 gfc_warning (OPT_Wundefined_do_loop
,
6822 "DO loop at %L is undefined as it underflows",
6823 &iter
->step
->where
);
6830 /* Traversal function for find_forall_index. f == 2 signals that
6831 that variable itself is not to be checked - only the references. */
6834 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6836 if (expr
->expr_type
!= EXPR_VARIABLE
)
6839 /* A scalar assignment */
6840 if (!expr
->ref
|| *f
== 1)
6842 if (expr
->symtree
->n
.sym
== sym
)
6854 /* Check whether the FORALL index appears in the expression or not.
6855 Returns true if SYM is found in EXPR. */
6858 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6860 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6867 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6868 to be a scalar INTEGER variable. The subscripts and stride are scalar
6869 INTEGERs, and if stride is a constant it must be nonzero.
6870 Furthermore "A subscript or stride in a forall-triplet-spec shall
6871 not contain a reference to any index-name in the
6872 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6875 resolve_forall_iterators (gfc_forall_iterator
*it
)
6877 gfc_forall_iterator
*iter
, *iter2
;
6879 for (iter
= it
; iter
; iter
= iter
->next
)
6881 if (gfc_resolve_expr (iter
->var
)
6882 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6883 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6886 if (gfc_resolve_expr (iter
->start
)
6887 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6888 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6889 &iter
->start
->where
);
6890 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6891 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6893 if (gfc_resolve_expr (iter
->end
)
6894 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6895 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6897 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6898 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6900 if (gfc_resolve_expr (iter
->stride
))
6902 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6903 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6904 &iter
->stride
->where
, "INTEGER");
6906 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6907 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6908 gfc_error ("FORALL stride expression at %L cannot be zero",
6909 &iter
->stride
->where
);
6911 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6912 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6915 for (iter
= it
; iter
; iter
= iter
->next
)
6916 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6918 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6919 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6920 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6921 gfc_error ("FORALL index %qs may not appear in triplet "
6922 "specification at %L", iter
->var
->symtree
->name
,
6923 &iter2
->start
->where
);
6928 /* Given a pointer to a symbol that is a derived type, see if it's
6929 inaccessible, i.e. if it's defined in another module and the components are
6930 PRIVATE. The search is recursive if necessary. Returns zero if no
6931 inaccessible components are found, nonzero otherwise. */
6934 derived_inaccessible (gfc_symbol
*sym
)
6938 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6941 for (c
= sym
->components
; c
; c
= c
->next
)
6943 /* Prevent an infinite loop through this function. */
6944 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
6945 && sym
== c
->ts
.u
.derived
)
6948 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6956 /* Resolve the argument of a deallocate expression. The expression must be
6957 a pointer or a full array. */
6960 resolve_deallocate_expr (gfc_expr
*e
)
6962 symbol_attribute attr
;
6963 int allocatable
, pointer
;
6969 if (!gfc_resolve_expr (e
))
6972 if (e
->expr_type
!= EXPR_VARIABLE
)
6975 sym
= e
->symtree
->n
.sym
;
6976 unlimited
= UNLIMITED_POLY(sym
);
6978 if (sym
->ts
.type
== BT_CLASS
)
6980 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6981 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6985 allocatable
= sym
->attr
.allocatable
;
6986 pointer
= sym
->attr
.pointer
;
6988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6993 if (ref
->u
.ar
.type
!= AR_FULL
6994 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6995 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7000 c
= ref
->u
.c
.component
;
7001 if (c
->ts
.type
== BT_CLASS
)
7003 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7004 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7008 allocatable
= c
->attr
.allocatable
;
7009 pointer
= c
->attr
.pointer
;
7019 attr
= gfc_expr_attr (e
);
7021 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7024 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7030 if (gfc_is_coindexed (e
))
7032 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7037 && !gfc_check_vardef_context (e
, true, true, false,
7038 _("DEALLOCATE object")))
7040 if (!gfc_check_vardef_context (e
, false, true, false,
7041 _("DEALLOCATE object")))
7048 /* Returns true if the expression e contains a reference to the symbol sym. */
7050 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7052 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7059 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7061 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7065 /* Given the expression node e for an allocatable/pointer of derived type to be
7066 allocated, get the expression node to be initialized afterwards (needed for
7067 derived types with default initializers, and derived types with allocatable
7068 components that need nullification.) */
7071 gfc_expr_to_initialize (gfc_expr
*e
)
7077 result
= gfc_copy_expr (e
);
7079 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7080 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7081 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7083 ref
->u
.ar
.type
= AR_FULL
;
7085 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7086 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7091 gfc_free_shape (&result
->shape
, result
->rank
);
7093 /* Recalculate rank, shape, etc. */
7094 gfc_resolve_expr (result
);
7099 /* If the last ref of an expression is an array ref, return a copy of the
7100 expression with that one removed. Otherwise, a copy of the original
7101 expression. This is used for allocate-expressions and pointer assignment
7102 LHS, where there may be an array specification that needs to be stripped
7103 off when using gfc_check_vardef_context. */
7106 remove_last_array_ref (gfc_expr
* e
)
7111 e2
= gfc_copy_expr (e
);
7112 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7113 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7115 gfc_free_ref_list (*r
);
7124 /* Used in resolve_allocate_expr to check that a allocation-object and
7125 a source-expr are conformable. This does not catch all possible
7126 cases; in particular a runtime checking is needed. */
7129 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7132 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7134 /* First compare rank. */
7135 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7136 || (!tail
&& e1
->rank
!= e2
->rank
))
7138 gfc_error ("Source-expr at %L must be scalar or have the "
7139 "same rank as the allocate-object at %L",
7140 &e1
->where
, &e2
->where
);
7151 for (i
= 0; i
< e1
->rank
; i
++)
7153 if (tail
->u
.ar
.start
[i
] == NULL
)
7156 if (tail
->u
.ar
.end
[i
])
7158 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7159 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7160 mpz_add_ui (s
, s
, 1);
7164 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7167 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7169 gfc_error ("Source-expr at %L and allocate-object at %L must "
7170 "have the same shape", &e1
->where
, &e2
->where
);
7183 /* Resolve the expression in an ALLOCATE statement, doing the additional
7184 checks to see whether the expression is OK or not. The expression must
7185 have a trailing array reference that gives the size of the array. */
7188 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7190 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7194 symbol_attribute attr
;
7195 gfc_ref
*ref
, *ref2
;
7198 gfc_symbol
*sym
= NULL
;
7203 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7204 checking of coarrays. */
7205 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7206 if (ref
->next
== NULL
)
7209 if (ref
&& ref
->type
== REF_ARRAY
)
7210 ref
->u
.ar
.in_allocate
= true;
7212 if (!gfc_resolve_expr (e
))
7215 /* Make sure the expression is allocatable or a pointer. If it is
7216 pointer, the next-to-last reference must be a pointer. */
7220 sym
= e
->symtree
->n
.sym
;
7222 /* Check whether ultimate component is abstract and CLASS. */
7225 /* Is the allocate-object unlimited polymorphic? */
7226 unlimited
= UNLIMITED_POLY(e
);
7228 if (e
->expr_type
!= EXPR_VARIABLE
)
7231 attr
= gfc_expr_attr (e
);
7232 pointer
= attr
.pointer
;
7233 dimension
= attr
.dimension
;
7234 codimension
= attr
.codimension
;
7238 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7240 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7241 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7242 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7243 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7244 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7248 allocatable
= sym
->attr
.allocatable
;
7249 pointer
= sym
->attr
.pointer
;
7250 dimension
= sym
->attr
.dimension
;
7251 codimension
= sym
->attr
.codimension
;
7256 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7261 if (ref
->u
.ar
.codimen
> 0)
7264 for (n
= ref
->u
.ar
.dimen
;
7265 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7266 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7273 if (ref
->next
!= NULL
)
7281 gfc_error ("Coindexed allocatable object at %L",
7286 c
= ref
->u
.c
.component
;
7287 if (c
->ts
.type
== BT_CLASS
)
7289 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7290 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7291 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7292 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7293 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7297 allocatable
= c
->attr
.allocatable
;
7298 pointer
= c
->attr
.pointer
;
7299 dimension
= c
->attr
.dimension
;
7300 codimension
= c
->attr
.codimension
;
7301 is_abstract
= c
->attr
.abstract
;
7313 /* Check for F08:C628. */
7314 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7316 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7321 /* Some checks for the SOURCE tag. */
7324 /* Check F03:C631. */
7325 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7327 gfc_error ("Type of entity at %L is type incompatible with "
7328 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7332 /* Check F03:C632 and restriction following Note 6.18. */
7333 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7336 /* Check F03:C633. */
7337 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7339 gfc_error ("The allocate-object at %L and the source-expr at %L "
7340 "shall have the same kind type parameter",
7341 &e
->where
, &code
->expr3
->where
);
7345 /* Check F2008, C642. */
7346 if (code
->expr3
->ts
.type
== BT_DERIVED
7347 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7348 || (code
->expr3
->ts
.u
.derived
->from_intmod
7349 == INTMOD_ISO_FORTRAN_ENV
7350 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7351 == ISOFORTRAN_LOCK_TYPE
)))
7353 gfc_error ("The source-expr at %L shall neither be of type "
7354 "LOCK_TYPE nor have a LOCK_TYPE component if "
7355 "allocate-object at %L is a coarray",
7356 &code
->expr3
->where
, &e
->where
);
7360 /* Check TS18508, C702/C703. */
7361 if (code
->expr3
->ts
.type
== BT_DERIVED
7362 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7363 || (code
->expr3
->ts
.u
.derived
->from_intmod
7364 == INTMOD_ISO_FORTRAN_ENV
7365 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7366 == ISOFORTRAN_EVENT_TYPE
)))
7368 gfc_error ("The source-expr at %L shall neither be of type "
7369 "EVENT_TYPE nor have a EVENT_TYPE component if "
7370 "allocate-object at %L is a coarray",
7371 &code
->expr3
->where
, &e
->where
);
7376 /* Check F08:C629. */
7377 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7380 gcc_assert (e
->ts
.type
== BT_CLASS
);
7381 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7382 "type-spec or source-expr", sym
->name
, &e
->where
);
7386 /* Check F08:C632. */
7387 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7388 && !UNLIMITED_POLY (e
))
7390 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7391 code
->ext
.alloc
.ts
.u
.cl
->length
);
7392 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7394 gfc_error ("Allocating %s at %L with type-spec requires the same "
7395 "character-length parameter as in the declaration",
7396 sym
->name
, &e
->where
);
7401 /* In the variable definition context checks, gfc_expr_attr is used
7402 on the expression. This is fooled by the array specification
7403 present in e, thus we have to eliminate that one temporarily. */
7404 e2
= remove_last_array_ref (e
);
7407 t
= gfc_check_vardef_context (e2
, true, true, false,
7408 _("ALLOCATE object"));
7410 t
= gfc_check_vardef_context (e2
, false, true, false,
7411 _("ALLOCATE object"));
7416 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7417 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7419 /* For class arrays, the initialization with SOURCE is done
7420 using _copy and trans_call. It is convenient to exploit that
7421 when the allocated type is different from the declared type but
7422 no SOURCE exists by setting expr3. */
7423 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7425 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7426 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7427 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7429 /* We have to zero initialize the integer variable. */
7430 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7433 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7435 /* Make sure the vtab symbol is present when
7436 the module variables are generated. */
7437 gfc_typespec ts
= e
->ts
;
7439 ts
= code
->expr3
->ts
;
7440 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7441 ts
= code
->ext
.alloc
.ts
;
7443 /* Finding the vtab also publishes the type's symbol. Therefore this
7444 statement is necessary. */
7445 gfc_find_derived_vtab (ts
.u
.derived
);
7447 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7449 /* Again, make sure the vtab symbol is present when
7450 the module variables are generated. */
7451 gfc_typespec
*ts
= NULL
;
7453 ts
= &code
->expr3
->ts
;
7455 ts
= &code
->ext
.alloc
.ts
;
7459 /* Finding the vtab also publishes the type's symbol. Therefore this
7460 statement is necessary. */
7464 if (dimension
== 0 && codimension
== 0)
7467 /* Make sure the last reference node is an array specification. */
7469 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7470 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7475 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7476 "in ALLOCATE statement at %L", &e
->where
))
7478 if (code
->expr3
->rank
!= 0)
7479 *array_alloc_wo_spec
= true;
7482 gfc_error ("Array specification or array-valued SOURCE= "
7483 "expression required in ALLOCATE statement at %L",
7490 gfc_error ("Array specification required in ALLOCATE statement "
7491 "at %L", &e
->where
);
7496 /* Make sure that the array section reference makes sense in the
7497 context of an ALLOCATE specification. */
7502 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7503 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7505 gfc_error ("Coarray specification required in ALLOCATE statement "
7506 "at %L", &e
->where
);
7510 for (i
= 0; i
< ar
->dimen
; i
++)
7512 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7515 switch (ar
->dimen_type
[i
])
7521 if (ar
->start
[i
] != NULL
7522 && ar
->end
[i
] != NULL
7523 && ar
->stride
[i
] == NULL
)
7531 case DIMEN_THIS_IMAGE
:
7532 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7538 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7540 sym
= a
->expr
->symtree
->n
.sym
;
7542 /* TODO - check derived type components. */
7543 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7546 if ((ar
->start
[i
] != NULL
7547 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7548 || (ar
->end
[i
] != NULL
7549 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7551 gfc_error ("%qs must not appear in the array specification at "
7552 "%L in the same ALLOCATE statement where it is "
7553 "itself allocated", sym
->name
, &ar
->where
);
7559 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7561 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7562 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7564 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7566 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7567 "statement at %L", &e
->where
);
7573 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7574 && ar
->stride
[i
] == NULL
)
7577 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7591 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7593 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7594 gfc_alloc
*a
, *p
, *q
;
7597 errmsg
= code
->expr2
;
7599 /* Check the stat variable. */
7602 gfc_check_vardef_context (stat
, false, false, false,
7603 _("STAT variable"));
7605 if ((stat
->ts
.type
!= BT_INTEGER
7606 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7607 || stat
->ref
->type
== REF_COMPONENT
)))
7609 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7610 "variable", &stat
->where
);
7612 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7613 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7615 gfc_ref
*ref1
, *ref2
;
7618 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7619 ref1
= ref1
->next
, ref2
= ref2
->next
)
7621 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7623 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7632 gfc_error ("Stat-variable at %L shall not be %sd within "
7633 "the same %s statement", &stat
->where
, fcn
, fcn
);
7639 /* Check the errmsg variable. */
7643 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7646 gfc_check_vardef_context (errmsg
, false, false, false,
7647 _("ERRMSG variable"));
7649 if ((errmsg
->ts
.type
!= BT_CHARACTER
7651 && (errmsg
->ref
->type
== REF_ARRAY
7652 || errmsg
->ref
->type
== REF_COMPONENT
)))
7653 || errmsg
->rank
> 0 )
7654 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7655 "variable", &errmsg
->where
);
7657 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7658 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7660 gfc_ref
*ref1
, *ref2
;
7663 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7664 ref1
= ref1
->next
, ref2
= ref2
->next
)
7666 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7668 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7677 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7678 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7684 /* Check that an allocate-object appears only once in the statement. */
7686 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7689 for (q
= p
->next
; q
; q
= q
->next
)
7692 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7694 /* This is a potential collision. */
7695 gfc_ref
*pr
= pe
->ref
;
7696 gfc_ref
*qr
= qe
->ref
;
7698 /* Follow the references until
7699 a) They start to differ, in which case there is no error;
7700 you can deallocate a%b and a%c in a single statement
7701 b) Both of them stop, which is an error
7702 c) One of them stops, which is also an error. */
7705 if (pr
== NULL
&& qr
== NULL
)
7707 gfc_error ("Allocate-object at %L also appears at %L",
7708 &pe
->where
, &qe
->where
);
7711 else if (pr
!= NULL
&& qr
== NULL
)
7713 gfc_error ("Allocate-object at %L is subobject of"
7714 " object at %L", &pe
->where
, &qe
->where
);
7717 else if (pr
== NULL
&& qr
!= NULL
)
7719 gfc_error ("Allocate-object at %L is subobject of"
7720 " object at %L", &qe
->where
, &pe
->where
);
7723 /* Here, pr != NULL && qr != NULL */
7724 gcc_assert(pr
->type
== qr
->type
);
7725 if (pr
->type
== REF_ARRAY
)
7727 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7729 gcc_assert (qr
->type
== REF_ARRAY
);
7731 if (pr
->next
&& qr
->next
)
7734 gfc_array_ref
*par
= &(pr
->u
.ar
);
7735 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7737 for (i
=0; i
<par
->dimen
; i
++)
7739 if ((par
->start
[i
] != NULL
7740 || qar
->start
[i
] != NULL
)
7741 && gfc_dep_compare_expr (par
->start
[i
],
7742 qar
->start
[i
]) != 0)
7749 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7762 if (strcmp (fcn
, "ALLOCATE") == 0)
7764 bool arr_alloc_wo_spec
= false;
7766 /* Resolving the expr3 in the loop over all objects to allocate would
7767 execute loop invariant code for each loop item. Therefore do it just
7769 if (code
->expr3
&& code
->expr3
->mold
7770 && code
->expr3
->ts
.type
== BT_DERIVED
)
7772 /* Default initialization via MOLD (non-polymorphic). */
7773 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7776 gfc_resolve_expr (rhs
);
7777 gfc_free_expr (code
->expr3
);
7781 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7782 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7784 if (arr_alloc_wo_spec
&& code
->expr3
)
7786 /* Mark the allocate to have to take the array specification
7788 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7793 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7794 resolve_deallocate_expr (a
->expr
);
7799 /************ SELECT CASE resolution subroutines ************/
7801 /* Callback function for our mergesort variant. Determines interval
7802 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7803 op1 > op2. Assumes we're not dealing with the default case.
7804 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7805 There are nine situations to check. */
7808 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7812 if (op1
->low
== NULL
) /* op1 = (:L) */
7814 /* op2 = (:N), so overlap. */
7816 /* op2 = (M:) or (M:N), L < M */
7817 if (op2
->low
!= NULL
7818 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7821 else if (op1
->high
== NULL
) /* op1 = (K:) */
7823 /* op2 = (M:), so overlap. */
7825 /* op2 = (:N) or (M:N), K > N */
7826 if (op2
->high
!= NULL
7827 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7830 else /* op1 = (K:L) */
7832 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7833 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7835 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7836 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7838 else /* op2 = (M:N) */
7842 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7845 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7854 /* Merge-sort a double linked case list, detecting overlap in the
7855 process. LIST is the head of the double linked case list before it
7856 is sorted. Returns the head of the sorted list if we don't see any
7857 overlap, or NULL otherwise. */
7860 check_case_overlap (gfc_case
*list
)
7862 gfc_case
*p
, *q
, *e
, *tail
;
7863 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7865 /* If the passed list was empty, return immediately. */
7872 /* Loop unconditionally. The only exit from this loop is a return
7873 statement, when we've finished sorting the case list. */
7880 /* Count the number of merges we do in this pass. */
7883 /* Loop while there exists a merge to be done. */
7888 /* Count this merge. */
7891 /* Cut the list in two pieces by stepping INSIZE places
7892 forward in the list, starting from P. */
7895 for (i
= 0; i
< insize
; i
++)
7904 /* Now we have two lists. Merge them! */
7905 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7907 /* See from which the next case to merge comes from. */
7910 /* P is empty so the next case must come from Q. */
7915 else if (qsize
== 0 || q
== NULL
)
7924 cmp
= compare_cases (p
, q
);
7927 /* The whole case range for P is less than the
7935 /* The whole case range for Q is greater than
7936 the case range for P. */
7943 /* The cases overlap, or they are the same
7944 element in the list. Either way, we must
7945 issue an error and get the next case from P. */
7946 /* FIXME: Sort P and Q by line number. */
7947 gfc_error ("CASE label at %L overlaps with CASE "
7948 "label at %L", &p
->where
, &q
->where
);
7956 /* Add the next element to the merged list. */
7965 /* P has now stepped INSIZE places along, and so has Q. So
7966 they're the same. */
7971 /* If we have done only one merge or none at all, we've
7972 finished sorting the cases. */
7981 /* Otherwise repeat, merging lists twice the size. */
7987 /* Check to see if an expression is suitable for use in a CASE statement.
7988 Makes sure that all case expressions are scalar constants of the same
7989 type. Return false if anything is wrong. */
7992 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7994 if (e
== NULL
) return true;
7996 if (e
->ts
.type
!= case_expr
->ts
.type
)
7998 gfc_error ("Expression in CASE statement at %L must be of type %s",
7999 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8003 /* C805 (R808) For a given case-construct, each case-value shall be of
8004 the same type as case-expr. For character type, length differences
8005 are allowed, but the kind type parameters shall be the same. */
8007 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8009 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8010 &e
->where
, case_expr
->ts
.kind
);
8014 /* Convert the case value kind to that of case expression kind,
8017 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8018 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8022 gfc_error ("Expression in CASE statement at %L must be scalar",
8031 /* Given a completely parsed select statement, we:
8033 - Validate all expressions and code within the SELECT.
8034 - Make sure that the selection expression is not of the wrong type.
8035 - Make sure that no case ranges overlap.
8036 - Eliminate unreachable cases and unreachable code resulting from
8037 removing case labels.
8039 The standard does allow unreachable cases, e.g. CASE (5:3). But
8040 they are a hassle for code generation, and to prevent that, we just
8041 cut them out here. This is not necessary for overlapping cases
8042 because they are illegal and we never even try to generate code.
8044 We have the additional caveat that a SELECT construct could have
8045 been a computed GOTO in the source code. Fortunately we can fairly
8046 easily work around that here: The case_expr for a "real" SELECT CASE
8047 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8048 we have to do is make sure that the case_expr is a scalar integer
8052 resolve_select (gfc_code
*code
, bool select_type
)
8055 gfc_expr
*case_expr
;
8056 gfc_case
*cp
, *default_case
, *tail
, *head
;
8057 int seen_unreachable
;
8063 if (code
->expr1
== NULL
)
8065 /* This was actually a computed GOTO statement. */
8066 case_expr
= code
->expr2
;
8067 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8068 gfc_error ("Selection expression in computed GOTO statement "
8069 "at %L must be a scalar integer expression",
8072 /* Further checking is not necessary because this SELECT was built
8073 by the compiler, so it should always be OK. Just move the
8074 case_expr from expr2 to expr so that we can handle computed
8075 GOTOs as normal SELECTs from here on. */
8076 code
->expr1
= code
->expr2
;
8081 case_expr
= code
->expr1
;
8082 type
= case_expr
->ts
.type
;
8085 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8087 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8088 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8090 /* Punt. Going on here just produce more garbage error messages. */
8095 if (!select_type
&& case_expr
->rank
!= 0)
8097 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8098 "expression", &case_expr
->where
);
8104 /* Raise a warning if an INTEGER case value exceeds the range of
8105 the case-expr. Later, all expressions will be promoted to the
8106 largest kind of all case-labels. */
8108 if (type
== BT_INTEGER
)
8109 for (body
= code
->block
; body
; body
= body
->block
)
8110 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8113 && gfc_check_integer_range (cp
->low
->value
.integer
,
8114 case_expr
->ts
.kind
) != ARITH_OK
)
8115 gfc_warning (0, "Expression in CASE statement at %L is "
8116 "not in the range of %s", &cp
->low
->where
,
8117 gfc_typename (&case_expr
->ts
));
8120 && cp
->low
!= cp
->high
8121 && gfc_check_integer_range (cp
->high
->value
.integer
,
8122 case_expr
->ts
.kind
) != ARITH_OK
)
8123 gfc_warning (0, "Expression in CASE statement at %L is "
8124 "not in the range of %s", &cp
->high
->where
,
8125 gfc_typename (&case_expr
->ts
));
8128 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8129 of the SELECT CASE expression and its CASE values. Walk the lists
8130 of case values, and if we find a mismatch, promote case_expr to
8131 the appropriate kind. */
8133 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8135 for (body
= code
->block
; body
; body
= body
->block
)
8137 /* Walk the case label list. */
8138 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8140 /* Intercept the DEFAULT case. It does not have a kind. */
8141 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8144 /* Unreachable case ranges are discarded, so ignore. */
8145 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8146 && cp
->low
!= cp
->high
8147 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8151 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8152 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8154 if (cp
->high
!= NULL
8155 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8156 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8161 /* Assume there is no DEFAULT case. */
8162 default_case
= NULL
;
8167 for (body
= code
->block
; body
; body
= body
->block
)
8169 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8171 seen_unreachable
= 0;
8173 /* Walk the case label list, making sure that all case labels
8175 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8177 /* Count the number of cases in the whole construct. */
8180 /* Intercept the DEFAULT case. */
8181 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8183 if (default_case
!= NULL
)
8185 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8186 "by a second DEFAULT CASE at %L",
8187 &default_case
->where
, &cp
->where
);
8198 /* Deal with single value cases and case ranges. Errors are
8199 issued from the validation function. */
8200 if (!validate_case_label_expr (cp
->low
, case_expr
)
8201 || !validate_case_label_expr (cp
->high
, case_expr
))
8207 if (type
== BT_LOGICAL
8208 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8209 || cp
->low
!= cp
->high
))
8211 gfc_error ("Logical range in CASE statement at %L is not "
8212 "allowed", &cp
->low
->where
);
8217 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8220 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8221 if (value
& seen_logical
)
8223 gfc_error ("Constant logical value in CASE statement "
8224 "is repeated at %L",
8229 seen_logical
|= value
;
8232 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8233 && cp
->low
!= cp
->high
8234 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8236 if (warn_surprising
)
8237 gfc_warning (OPT_Wsurprising
,
8238 "Range specification at %L can never be matched",
8241 cp
->unreachable
= 1;
8242 seen_unreachable
= 1;
8246 /* If the case range can be matched, it can also overlap with
8247 other cases. To make sure it does not, we put it in a
8248 double linked list here. We sort that with a merge sort
8249 later on to detect any overlapping cases. */
8253 head
->right
= head
->left
= NULL
;
8258 tail
->right
->left
= tail
;
8265 /* It there was a failure in the previous case label, give up
8266 for this case label list. Continue with the next block. */
8270 /* See if any case labels that are unreachable have been seen.
8271 If so, we eliminate them. This is a bit of a kludge because
8272 the case lists for a single case statement (label) is a
8273 single forward linked lists. */
8274 if (seen_unreachable
)
8276 /* Advance until the first case in the list is reachable. */
8277 while (body
->ext
.block
.case_list
!= NULL
8278 && body
->ext
.block
.case_list
->unreachable
)
8280 gfc_case
*n
= body
->ext
.block
.case_list
;
8281 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8283 gfc_free_case_list (n
);
8286 /* Strip all other unreachable cases. */
8287 if (body
->ext
.block
.case_list
)
8289 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8291 if (cp
->next
->unreachable
)
8293 gfc_case
*n
= cp
->next
;
8294 cp
->next
= cp
->next
->next
;
8296 gfc_free_case_list (n
);
8303 /* See if there were overlapping cases. If the check returns NULL,
8304 there was overlap. In that case we don't do anything. If head
8305 is non-NULL, we prepend the DEFAULT case. The sorted list can
8306 then used during code generation for SELECT CASE constructs with
8307 a case expression of a CHARACTER type. */
8310 head
= check_case_overlap (head
);
8312 /* Prepend the default_case if it is there. */
8313 if (head
!= NULL
&& default_case
)
8315 default_case
->left
= NULL
;
8316 default_case
->right
= head
;
8317 head
->left
= default_case
;
8321 /* Eliminate dead blocks that may be the result if we've seen
8322 unreachable case labels for a block. */
8323 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8325 if (body
->block
->ext
.block
.case_list
== NULL
)
8327 /* Cut the unreachable block from the code chain. */
8328 gfc_code
*c
= body
->block
;
8329 body
->block
= c
->block
;
8331 /* Kill the dead block, but not the blocks below it. */
8333 gfc_free_statements (c
);
8337 /* More than two cases is legal but insane for logical selects.
8338 Issue a warning for it. */
8339 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8340 gfc_warning (OPT_Wsurprising
,
8341 "Logical SELECT CASE block at %L has more that two cases",
8346 /* Check if a derived type is extensible. */
8349 gfc_type_is_extensible (gfc_symbol
*sym
)
8351 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8352 || (sym
->attr
.is_class
8353 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8358 resolve_types (gfc_namespace
*ns
);
8360 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8361 correct as well as possibly the array-spec. */
8364 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8368 gcc_assert (sym
->assoc
);
8369 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8371 /* If this is for SELECT TYPE, the target may not yet be set. In that
8372 case, return. Resolution will be called later manually again when
8374 target
= sym
->assoc
->target
;
8377 gcc_assert (!sym
->assoc
->dangling
);
8379 if (resolve_target
&& !gfc_resolve_expr (target
))
8382 /* For variable targets, we get some attributes from the target. */
8383 if (target
->expr_type
== EXPR_VARIABLE
)
8387 gcc_assert (target
->symtree
);
8388 tsym
= target
->symtree
->n
.sym
;
8390 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8391 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8393 sym
->attr
.target
= tsym
->attr
.target
8394 || gfc_expr_attr (target
).pointer
;
8395 if (is_subref_array (target
))
8396 sym
->attr
.subref_array_pointer
= 1;
8399 if (target
->expr_type
== EXPR_NULL
)
8401 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8404 else if (target
->ts
.type
== BT_UNKNOWN
)
8406 gfc_error ("Selector at %L has no type", &target
->where
);
8410 /* Get type if this was not already set. Note that it can be
8411 some other type than the target in case this is a SELECT TYPE
8412 selector! So we must not update when the type is already there. */
8413 if (sym
->ts
.type
== BT_UNKNOWN
)
8414 sym
->ts
= target
->ts
;
8416 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8418 /* See if this is a valid association-to-variable. */
8419 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8420 && !gfc_has_vector_subscript (target
));
8422 /* Finally resolve if this is an array or not. */
8423 if (sym
->attr
.dimension
&& target
->rank
== 0)
8425 /* primary.c makes the assumption that a reference to an associate
8426 name followed by a left parenthesis is an array reference. */
8427 if (sym
->ts
.type
!= BT_CHARACTER
)
8428 gfc_error ("Associate-name %qs at %L is used as array",
8429 sym
->name
, &sym
->declared_at
);
8430 sym
->attr
.dimension
= 0;
8435 /* We cannot deal with class selectors that need temporaries. */
8436 if (target
->ts
.type
== BT_CLASS
8437 && gfc_ref_needs_temporary_p (target
->ref
))
8439 gfc_error ("CLASS selector at %L needs a temporary which is not "
8440 "yet implemented", &target
->where
);
8444 if (target
->ts
.type
== BT_CLASS
)
8445 gfc_fix_class_refs (target
);
8447 if (target
->rank
!= 0)
8450 /* The rank may be incorrectly guessed at parsing, therefore make sure
8451 it is corrected now. */
8452 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8455 sym
->as
= gfc_get_array_spec ();
8457 as
->rank
= target
->rank
;
8458 as
->type
= AS_DEFERRED
;
8459 as
->corank
= gfc_get_corank (target
);
8460 sym
->attr
.dimension
= 1;
8461 if (as
->corank
!= 0)
8462 sym
->attr
.codimension
= 1;
8467 /* target's rank is 0, but the type of the sym is still array valued,
8468 which has to be corrected. */
8469 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8472 symbol_attribute attr
;
8473 /* The associated variable's type is still the array type
8474 correct this now. */
8475 gfc_typespec
*ts
= &target
->ts
;
8478 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8483 ts
= &ref
->u
.c
.component
->ts
;
8486 if (ts
->type
== BT_CLASS
)
8487 ts
= &ts
->u
.derived
->components
->ts
;
8493 /* Create a scalar instance of the current class type. Because the
8494 rank of a class array goes into its name, the type has to be
8495 rebuild. The alternative of (re-)setting just the attributes
8496 and as in the current type, destroys the type also in other
8500 sym
->ts
.type
= BT_CLASS
;
8501 attr
= CLASS_DATA (sym
)->attr
;
8503 attr
.associate_var
= 1;
8504 attr
.dimension
= attr
.codimension
= 0;
8505 attr
.class_pointer
= 1;
8506 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8508 /* Make sure the _vptr is set. */
8509 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8510 if (c
->ts
.u
.derived
== NULL
)
8511 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8512 CLASS_DATA (sym
)->attr
.pointer
= 1;
8513 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8514 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8515 gfc_commit_symbol (sym
->ts
.u
.derived
);
8516 /* _vptr now has the _vtab in it, change it to the _vtype. */
8517 if (c
->ts
.u
.derived
->attr
.vtab
)
8518 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8519 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8520 resolve_types (c
->ts
.u
.derived
->ns
);
8524 /* Mark this as an associate variable. */
8525 sym
->attr
.associate_var
= 1;
8527 /* Fix up the type-spec for CHARACTER types. */
8528 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8531 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8533 if (!sym
->ts
.u
.cl
->length
)
8534 sym
->ts
.u
.cl
->length
8535 = gfc_get_int_expr (gfc_default_integer_kind
,
8536 NULL
, target
->value
.character
.length
);
8539 /* If the target is a good class object, so is the associate variable. */
8540 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8541 sym
->attr
.class_ok
= 1;
8545 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8546 array reference, where necessary. The symbols are artificial and so
8547 the dimension attribute and arrayspec can also be set. In addition,
8548 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8549 This is corrected here as well.*/
8552 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8553 int rank
, gfc_ref
*ref
)
8555 gfc_ref
*nref
= (*expr1
)->ref
;
8556 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8557 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8558 (*expr1
)->rank
= rank
;
8559 if (sym1
->ts
.type
== BT_CLASS
)
8561 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8562 (*expr1
)->ts
= sym1
->ts
;
8564 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8565 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8566 CLASS_DATA (sym1
)->as
8567 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8571 sym1
->attr
.dimension
= 1;
8572 if (sym1
->as
== NULL
&& sym2
)
8573 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8576 for (; nref
; nref
= nref
->next
)
8577 if (nref
->next
== NULL
)
8580 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8581 nref
->next
= gfc_copy_ref (ref
);
8582 else if (ref
&& !nref
)
8583 (*expr1
)->ref
= gfc_copy_ref (ref
);
8588 build_loc_call (gfc_expr
*sym_expr
)
8591 loc_call
= gfc_get_expr ();
8592 loc_call
->expr_type
= EXPR_FUNCTION
;
8593 gfc_get_sym_tree ("loc", gfc_current_ns
, &loc_call
->symtree
, false);
8594 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8595 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8596 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8597 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8598 loc_call
->ts
.type
= BT_INTEGER
;
8599 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8600 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8601 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8602 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8603 loc_call
->where
= sym_expr
->where
;
8607 /* Resolve a SELECT TYPE statement. */
8610 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8612 gfc_symbol
*selector_type
;
8613 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8614 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8617 char name
[GFC_MAX_SYMBOL_LEN
];
8622 gfc_ref
* ref
= NULL
;
8623 gfc_expr
*selector_expr
= NULL
;
8625 ns
= code
->ext
.block
.ns
;
8628 /* Check for F03:C813. */
8629 if (code
->expr1
->ts
.type
!= BT_CLASS
8630 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8632 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8633 "at %L", &code
->loc
);
8637 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8642 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8643 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8644 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8646 /* F2008: C803 The selector expression must not be coindexed. */
8647 if (gfc_is_coindexed (code
->expr2
))
8649 gfc_error ("Selector at %L must not be coindexed",
8650 &code
->expr2
->where
);
8657 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8659 if (gfc_is_coindexed (code
->expr1
))
8661 gfc_error ("Selector at %L must not be coindexed",
8662 &code
->expr1
->where
);
8667 /* Loop over TYPE IS / CLASS IS cases. */
8668 for (body
= code
->block
; body
; body
= body
->block
)
8670 c
= body
->ext
.block
.case_list
;
8674 /* Check for repeated cases. */
8675 for (tail
= code
->block
; tail
; tail
= tail
->block
)
8677 gfc_case
*d
= tail
->ext
.block
.case_list
;
8681 if (c
->ts
.type
== d
->ts
.type
8682 && ((c
->ts
.type
== BT_DERIVED
8683 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
8684 && !strcmp (c
->ts
.u
.derived
->name
,
8685 d
->ts
.u
.derived
->name
))
8686 || c
->ts
.type
== BT_UNKNOWN
8687 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8688 && c
->ts
.kind
== d
->ts
.kind
)))
8690 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8691 &c
->where
, &d
->where
);
8697 /* Check F03:C815. */
8698 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8699 && !selector_type
->attr
.unlimited_polymorphic
8700 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8702 gfc_error ("Derived type %qs at %L must be extensible",
8703 c
->ts
.u
.derived
->name
, &c
->where
);
8708 /* Check F03:C816. */
8709 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8710 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8711 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8713 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8714 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8715 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8717 gfc_error ("Unexpected intrinsic type %qs at %L",
8718 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8723 /* Check F03:C814. */
8724 if (c
->ts
.type
== BT_CHARACTER
8725 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
8727 gfc_error ("The type-spec at %L shall specify that each length "
8728 "type parameter is assumed", &c
->where
);
8733 /* Intercept the DEFAULT case. */
8734 if (c
->ts
.type
== BT_UNKNOWN
)
8736 /* Check F03:C818. */
8739 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8740 "by a second DEFAULT CASE at %L",
8741 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8746 default_case
= body
;
8753 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8754 target if present. If there are any EXIT statements referring to the
8755 SELECT TYPE construct, this is no problem because the gfc_code
8756 reference stays the same and EXIT is equally possible from the BLOCK
8757 it is changed to. */
8758 code
->op
= EXEC_BLOCK
;
8761 gfc_association_list
* assoc
;
8763 assoc
= gfc_get_association_list ();
8764 assoc
->st
= code
->expr1
->symtree
;
8765 assoc
->target
= gfc_copy_expr (code
->expr2
);
8766 assoc
->target
->where
= code
->expr2
->where
;
8767 /* assoc->variable will be set by resolve_assoc_var. */
8769 code
->ext
.block
.assoc
= assoc
;
8770 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8772 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8775 code
->ext
.block
.assoc
= NULL
;
8777 /* Ensure that the selector rank and arrayspec are available to
8778 correct expressions in which they might be missing. */
8779 if (code
->expr2
&& code
->expr2
->rank
)
8781 rank
= code
->expr2
->rank
;
8782 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
8783 if (ref
->next
== NULL
)
8785 if (ref
&& ref
->type
== REF_ARRAY
)
8786 ref
= gfc_copy_ref (ref
);
8788 /* Fixup expr1 if necessary. */
8790 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
8792 else if (code
->expr1
->rank
)
8794 rank
= code
->expr1
->rank
;
8795 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
8796 if (ref
->next
== NULL
)
8798 if (ref
&& ref
->type
== REF_ARRAY
)
8799 ref
= gfc_copy_ref (ref
);
8802 /* Add EXEC_SELECT to switch on type. */
8803 new_st
= gfc_get_code (code
->op
);
8804 new_st
->expr1
= code
->expr1
;
8805 new_st
->expr2
= code
->expr2
;
8806 new_st
->block
= code
->block
;
8807 code
->expr1
= code
->expr2
= NULL
;
8812 ns
->code
->next
= new_st
;
8814 code
->op
= EXEC_SELECT_TYPE
;
8816 /* Use the intrinsic LOC function to generate an integer expression
8817 for the vtable of the selector. Note that the rank of the selector
8818 expression has to be set to zero. */
8819 gfc_add_vptr_component (code
->expr1
);
8820 code
->expr1
->rank
= 0;
8821 code
->expr1
= build_loc_call (code
->expr1
);
8822 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
8824 /* Loop over TYPE IS / CLASS IS cases. */
8825 for (body
= code
->block
; body
; body
= body
->block
)
8829 c
= body
->ext
.block
.case_list
;
8831 /* Generate an index integer expression for address of the
8832 TYPE/CLASS vtable and store it in c->low. The hash expression
8833 is stored in c->high and is used to resolve intrinsic cases. */
8834 if (c
->ts
.type
!= BT_UNKNOWN
)
8836 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8838 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8840 c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8841 c
->ts
.u
.derived
->hash_value
);
8845 vtab
= gfc_find_vtab (&c
->ts
);
8846 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
8847 e
= CLASS_DATA (vtab
)->initializer
;
8848 c
->high
= gfc_copy_expr (e
);
8851 e
= gfc_lval_expr_from_sym (vtab
);
8852 c
->low
= build_loc_call (e
);
8857 /* Associate temporary to selector. This should only be done
8858 when this case is actually true, so build a new ASSOCIATE
8859 that does precisely this here (instead of using the
8862 if (c
->ts
.type
== BT_CLASS
)
8863 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8864 else if (c
->ts
.type
== BT_DERIVED
)
8865 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8866 else if (c
->ts
.type
== BT_CHARACTER
)
8868 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8869 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8870 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8871 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8872 charlen
, c
->ts
.kind
);
8875 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8878 st
= gfc_find_symtree (ns
->sym_root
, name
);
8879 gcc_assert (st
->n
.sym
->assoc
);
8880 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
8881 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
8882 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8884 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8885 /* Fixup the target expression if necessary. */
8887 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
8890 new_st
= gfc_get_code (EXEC_BLOCK
);
8891 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8892 new_st
->ext
.block
.ns
->code
= body
->next
;
8893 body
->next
= new_st
;
8895 /* Chain in the new list only if it is marked as dangling. Otherwise
8896 there is a CASE label overlap and this is already used. Just ignore,
8897 the error is diagnosed elsewhere. */
8898 if (st
->n
.sym
->assoc
->dangling
)
8900 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8901 st
->n
.sym
->assoc
->dangling
= 0;
8904 resolve_assoc_var (st
->n
.sym
, false);
8907 /* Take out CLASS IS cases for separate treatment. */
8909 while (body
&& body
->block
)
8911 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8913 /* Add to class_is list. */
8914 if (class_is
== NULL
)
8916 class_is
= body
->block
;
8921 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8922 tail
->block
= body
->block
;
8925 /* Remove from EXEC_SELECT list. */
8926 body
->block
= body
->block
->block
;
8939 /* Add a default case to hold the CLASS IS cases. */
8940 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8941 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8943 tail
->ext
.block
.case_list
= gfc_get_case ();
8944 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8946 default_case
= tail
;
8949 /* More than one CLASS IS block? */
8950 if (class_is
->block
)
8954 /* Sort CLASS IS blocks by extension level. */
8958 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8961 /* F03:C817 (check for doubles). */
8962 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8963 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8965 gfc_error ("Double CLASS IS block in SELECT TYPE "
8967 &c2
->ext
.block
.case_list
->where
);
8970 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8971 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8974 (*c1
)->block
= c2
->block
;
8984 /* Generate IF chain. */
8985 if_st
= gfc_get_code (EXEC_IF
);
8987 for (body
= class_is
; body
; body
= body
->block
)
8989 new_st
->block
= gfc_get_code (EXEC_IF
);
8990 new_st
= new_st
->block
;
8991 /* Set up IF condition: Call _gfortran_is_extension_of. */
8992 new_st
->expr1
= gfc_get_expr ();
8993 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8994 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8995 new_st
->expr1
->ts
.kind
= 4;
8996 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8997 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8998 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8999 /* Set up arguments. */
9000 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9001 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9002 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9003 new_st
->expr1
->where
= code
->loc
;
9004 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9005 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9006 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9007 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9008 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9009 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9010 new_st
->next
= body
->next
;
9012 if (default_case
->next
)
9014 new_st
->block
= gfc_get_code (EXEC_IF
);
9015 new_st
= new_st
->block
;
9016 new_st
->next
= default_case
->next
;
9019 /* Replace CLASS DEFAULT code by the IF chain. */
9020 default_case
->next
= if_st
;
9023 /* Resolve the internal code. This can not be done earlier because
9024 it requires that the sym->assoc of selectors is set already. */
9025 gfc_current_ns
= ns
;
9026 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9027 gfc_current_ns
= old_ns
;
9034 /* Resolve a transfer statement. This is making sure that:
9035 -- a derived type being transferred has only non-pointer components
9036 -- a derived type being transferred doesn't have private components, unless
9037 it's being transferred from the module where the type was defined
9038 -- we're not trying to transfer a whole assumed size array. */
9041 resolve_transfer (gfc_code
*code
)
9044 gfc_symbol
*sym
, *derived
;
9048 bool formatted
= false;
9049 gfc_dt
*dt
= code
->ext
.dt
;
9050 gfc_symbol
*dtio_sub
= NULL
;
9054 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9055 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9056 exp
= exp
->value
.op
.op1
;
9058 if (exp
&& exp
->expr_type
== EXPR_NULL
9061 gfc_error ("Invalid context for NULL () intrinsic at %L",
9066 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9067 && exp
->expr_type
!= EXPR_FUNCTION
9068 && exp
->expr_type
!= EXPR_STRUCTURE
))
9071 /* If we are reading, the variable will be changed. Note that
9072 code->ext.dt may be NULL if the TRANSFER is related to
9073 an INQUIRE statement -- but in this case, we are not reading, either. */
9074 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9075 && !gfc_check_vardef_context (exp
, false, false, false,
9079 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9081 /* Go to actual component transferred. */
9082 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9083 if (ref
->type
== REF_COMPONENT
)
9084 ts
= &ref
->u
.c
.component
->ts
;
9086 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9087 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9089 if (ts
->type
== BT_DERIVED
)
9090 derived
= ts
->u
.derived
;
9092 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
9094 if (dt
->format_expr
)
9097 fmt
= gfc_widechar_to_char (dt
->format_expr
->value
.character
.string
,
9099 if (strtok (fmt
, "DT") != NULL
)
9102 else if (dt
->format_label
== &format_asterisk
)
9104 /* List directed io must call the formatted DTIO procedure. */
9108 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9109 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9110 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9112 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9115 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9116 /* Check to see if this is a nested DTIO call, with the
9117 dummy as the io-list object. */
9118 if (sym
&& sym
== dtio_sub
&& sym
->formal
9119 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9120 && exp
->ref
== NULL
)
9122 if (!sym
->attr
.recursive
)
9124 gfc_error ("DTIO %s procedure at %L must be recursive",
9125 sym
->name
, &sym
->declared_at
);
9132 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9134 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9135 "it is processed by a defined input/output procedure",
9140 if (ts
->type
== BT_DERIVED
)
9142 /* Check that transferred derived type doesn't contain POINTER
9143 components unless it is processed by a defined input/output
9145 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9147 gfc_error ("Data transfer element at %L cannot have POINTER "
9148 "components unless it is processed by a defined "
9149 "input/output procedure", &code
->loc
);
9154 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9156 gfc_error ("Data transfer element at %L cannot have "
9157 "procedure pointer components", &code
->loc
);
9161 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9163 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9164 "components unless it is processed by a defined "
9165 "input/output procedure", &code
->loc
);
9169 /* C_PTR and C_FUNPTR have private components which means they can not
9170 be printed. However, if -std=gnu and not -pedantic, allow
9171 the component to be printed to help debugging. */
9172 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9174 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9175 "cannot have PRIVATE components", &code
->loc
))
9178 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9180 gfc_error ("Data transfer element at %L cannot have "
9181 "PRIVATE components unless it is processed by "
9182 "a defined input/output procedure", &code
->loc
);
9187 if (exp
->expr_type
== EXPR_STRUCTURE
)
9190 sym
= exp
->symtree
->n
.sym
;
9192 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9193 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9195 gfc_error ("Data transfer element at %L cannot be a full reference to "
9196 "an assumed-size array", &code
->loc
);
9202 /*********** Toplevel code resolution subroutines ***********/
9204 /* Find the set of labels that are reachable from this block. We also
9205 record the last statement in each block. */
9208 find_reachable_labels (gfc_code
*block
)
9215 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9217 /* Collect labels in this block. We don't keep those corresponding
9218 to END {IF|SELECT}, these are checked in resolve_branch by going
9219 up through the code_stack. */
9220 for (c
= block
; c
; c
= c
->next
)
9222 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9223 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9226 /* Merge with labels from parent block. */
9229 gcc_assert (cs_base
->prev
->reachable_labels
);
9230 bitmap_ior_into (cs_base
->reachable_labels
,
9231 cs_base
->prev
->reachable_labels
);
9237 resolve_lock_unlock_event (gfc_code
*code
)
9239 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9240 && code
->expr1
->value
.function
.isym
9241 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9242 remove_caf_get_intrinsic (code
->expr1
);
9244 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9245 && (code
->expr1
->ts
.type
!= BT_DERIVED
9246 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9247 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9248 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9249 || code
->expr1
->rank
!= 0
9250 || (!gfc_is_coarray (code
->expr1
) &&
9251 !gfc_is_coindexed (code
->expr1
))))
9252 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9253 &code
->expr1
->where
);
9254 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9255 && (code
->expr1
->ts
.type
!= BT_DERIVED
9256 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9257 || code
->expr1
->ts
.u
.derived
->from_intmod
9258 != INTMOD_ISO_FORTRAN_ENV
9259 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9260 != ISOFORTRAN_EVENT_TYPE
9261 || code
->expr1
->rank
!= 0))
9262 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9263 &code
->expr1
->where
);
9264 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9265 && !gfc_is_coindexed (code
->expr1
))
9266 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9267 &code
->expr1
->where
);
9268 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9269 gfc_error ("Event variable argument at %L must be a coarray but not "
9270 "coindexed", &code
->expr1
->where
);
9274 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9275 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9276 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9277 &code
->expr2
->where
);
9280 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9281 _("STAT variable")))
9286 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9287 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9288 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9289 &code
->expr3
->where
);
9292 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9293 _("ERRMSG variable")))
9296 /* Check for LOCK the ACQUIRED_LOCK. */
9297 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9298 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9299 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9300 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9301 "variable", &code
->expr4
->where
);
9303 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9304 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9305 _("ACQUIRED_LOCK variable")))
9308 /* Check for EVENT WAIT the UNTIL_COUNT. */
9309 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9311 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9312 || code
->expr4
->rank
!= 0)
9313 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9314 "expression", &code
->expr4
->where
);
9320 resolve_critical (gfc_code
*code
)
9322 gfc_symtree
*symtree
;
9323 gfc_symbol
*lock_type
;
9324 char name
[GFC_MAX_SYMBOL_LEN
];
9325 static int serial
= 0;
9327 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9330 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9331 GFC_PREFIX ("lock_type"));
9333 lock_type
= symtree
->n
.sym
;
9336 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9339 lock_type
= symtree
->n
.sym
;
9340 lock_type
->attr
.flavor
= FL_DERIVED
;
9341 lock_type
->attr
.zero_comp
= 1;
9342 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9343 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9346 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9347 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9350 code
->resolved_sym
= symtree
->n
.sym
;
9351 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9352 symtree
->n
.sym
->attr
.referenced
= 1;
9353 symtree
->n
.sym
->attr
.artificial
= 1;
9354 symtree
->n
.sym
->attr
.codimension
= 1;
9355 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9356 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9357 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9358 symtree
->n
.sym
->as
->corank
= 1;
9359 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9360 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9361 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9363 gfc_commit_symbols();
9368 resolve_sync (gfc_code
*code
)
9370 /* Check imageset. The * case matches expr1 == NULL. */
9373 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9374 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9375 "INTEGER expression", &code
->expr1
->where
);
9376 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9377 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9378 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9379 &code
->expr1
->where
);
9380 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9381 && gfc_simplify_expr (code
->expr1
, 0))
9383 gfc_constructor
*cons
;
9384 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9385 for (; cons
; cons
= gfc_constructor_next (cons
))
9386 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9387 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9388 gfc_error ("Imageset argument at %L must between 1 and "
9389 "num_images()", &cons
->expr
->where
);
9395 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9396 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9397 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9398 &code
->expr2
->where
);
9402 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9403 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9404 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9405 &code
->expr3
->where
);
9409 /* Given a branch to a label, see if the branch is conforming.
9410 The code node describes where the branch is located. */
9413 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9420 /* Step one: is this a valid branching target? */
9422 if (label
->defined
== ST_LABEL_UNKNOWN
)
9424 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9429 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9431 gfc_error ("Statement at %L is not a valid branch target statement "
9432 "for the branch statement at %L", &label
->where
, &code
->loc
);
9436 /* Step two: make sure this branch is not a branch to itself ;-) */
9438 if (code
->here
== label
)
9441 "Branch at %L may result in an infinite loop", &code
->loc
);
9445 /* Step three: See if the label is in the same block as the
9446 branching statement. The hard work has been done by setting up
9447 the bitmap reachable_labels. */
9449 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9451 /* Check now whether there is a CRITICAL construct; if so, check
9452 whether the label is still visible outside of the CRITICAL block,
9453 which is invalid. */
9454 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9456 if (stack
->current
->op
== EXEC_CRITICAL
9457 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9458 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9459 "label at %L", &code
->loc
, &label
->where
);
9460 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9461 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9462 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9463 "for label at %L", &code
->loc
, &label
->where
);
9469 /* Step four: If we haven't found the label in the bitmap, it may
9470 still be the label of the END of the enclosing block, in which
9471 case we find it by going up the code_stack. */
9473 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9475 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9477 if (stack
->current
->op
== EXEC_CRITICAL
)
9479 /* Note: A label at END CRITICAL does not leave the CRITICAL
9480 construct as END CRITICAL is still part of it. */
9481 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9482 " at %L", &code
->loc
, &label
->where
);
9485 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9487 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9488 "label at %L", &code
->loc
, &label
->where
);
9495 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9499 /* The label is not in an enclosing block, so illegal. This was
9500 allowed in Fortran 66, so we allow it as extension. No
9501 further checks are necessary in this case. */
9502 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9503 "as the GOTO statement at %L", &label
->where
,
9509 /* Check whether EXPR1 has the same shape as EXPR2. */
9512 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9514 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9515 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9516 bool result
= false;
9519 /* Compare the rank. */
9520 if (expr1
->rank
!= expr2
->rank
)
9523 /* Compare the size of each dimension. */
9524 for (i
=0; i
<expr1
->rank
; i
++)
9526 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9529 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9532 if (mpz_cmp (shape
[i
], shape2
[i
]))
9536 /* When either of the two expression is an assumed size array, we
9537 ignore the comparison of dimension sizes. */
9542 gfc_clear_shape (shape
, i
);
9543 gfc_clear_shape (shape2
, i
);
9548 /* Check whether a WHERE assignment target or a WHERE mask expression
9549 has the same shape as the outmost WHERE mask expression. */
9552 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9558 cblock
= code
->block
;
9560 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9561 In case of nested WHERE, only the outmost one is stored. */
9562 if (mask
== NULL
) /* outmost WHERE */
9564 else /* inner WHERE */
9571 /* Check if the mask-expr has a consistent shape with the
9572 outmost WHERE mask-expr. */
9573 if (!resolve_where_shape (cblock
->expr1
, e
))
9574 gfc_error ("WHERE mask at %L has inconsistent shape",
9575 &cblock
->expr1
->where
);
9578 /* the assignment statement of a WHERE statement, or the first
9579 statement in where-body-construct of a WHERE construct */
9580 cnext
= cblock
->next
;
9585 /* WHERE assignment statement */
9588 /* Check shape consistent for WHERE assignment target. */
9589 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9590 gfc_error ("WHERE assignment target at %L has "
9591 "inconsistent shape", &cnext
->expr1
->where
);
9595 case EXEC_ASSIGN_CALL
:
9596 resolve_call (cnext
);
9597 if (!cnext
->resolved_sym
->attr
.elemental
)
9598 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9599 &cnext
->ext
.actual
->expr
->where
);
9602 /* WHERE or WHERE construct is part of a where-body-construct */
9604 resolve_where (cnext
, e
);
9608 gfc_error ("Unsupported statement inside WHERE at %L",
9611 /* the next statement within the same where-body-construct */
9612 cnext
= cnext
->next
;
9614 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9615 cblock
= cblock
->block
;
9620 /* Resolve assignment in FORALL construct.
9621 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9622 FORALL index variables. */
9625 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9629 for (n
= 0; n
< nvar
; n
++)
9631 gfc_symbol
*forall_index
;
9633 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9635 /* Check whether the assignment target is one of the FORALL index
9637 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9638 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9639 gfc_error ("Assignment to a FORALL index variable at %L",
9640 &code
->expr1
->where
);
9643 /* If one of the FORALL index variables doesn't appear in the
9644 assignment variable, then there could be a many-to-one
9645 assignment. Emit a warning rather than an error because the
9646 mask could be resolving this problem. */
9647 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9648 gfc_warning (0, "The FORALL with index %qs is not used on the "
9649 "left side of the assignment at %L and so might "
9650 "cause multiple assignment to this object",
9651 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9657 /* Resolve WHERE statement in FORALL construct. */
9660 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9661 gfc_expr
**var_expr
)
9666 cblock
= code
->block
;
9669 /* the assignment statement of a WHERE statement, or the first
9670 statement in where-body-construct of a WHERE construct */
9671 cnext
= cblock
->next
;
9676 /* WHERE assignment statement */
9678 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9681 /* WHERE operator assignment statement */
9682 case EXEC_ASSIGN_CALL
:
9683 resolve_call (cnext
);
9684 if (!cnext
->resolved_sym
->attr
.elemental
)
9685 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9686 &cnext
->ext
.actual
->expr
->where
);
9689 /* WHERE or WHERE construct is part of a where-body-construct */
9691 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9695 gfc_error ("Unsupported statement inside WHERE at %L",
9698 /* the next statement within the same where-body-construct */
9699 cnext
= cnext
->next
;
9701 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9702 cblock
= cblock
->block
;
9707 /* Traverse the FORALL body to check whether the following errors exist:
9708 1. For assignment, check if a many-to-one assignment happens.
9709 2. For WHERE statement, check the WHERE body to see if there is any
9710 many-to-one assignment. */
9713 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9717 c
= code
->block
->next
;
9723 case EXEC_POINTER_ASSIGN
:
9724 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9727 case EXEC_ASSIGN_CALL
:
9731 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9732 there is no need to handle it here. */
9736 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9741 /* The next statement in the FORALL body. */
9747 /* Counts the number of iterators needed inside a forall construct, including
9748 nested forall constructs. This is used to allocate the needed memory
9749 in gfc_resolve_forall. */
9752 gfc_count_forall_iterators (gfc_code
*code
)
9754 int max_iters
, sub_iters
, current_iters
;
9755 gfc_forall_iterator
*fa
;
9757 gcc_assert(code
->op
== EXEC_FORALL
);
9761 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9764 code
= code
->block
->next
;
9768 if (code
->op
== EXEC_FORALL
)
9770 sub_iters
= gfc_count_forall_iterators (code
);
9771 if (sub_iters
> max_iters
)
9772 max_iters
= sub_iters
;
9777 return current_iters
+ max_iters
;
9781 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9782 gfc_resolve_forall_body to resolve the FORALL body. */
9785 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9787 static gfc_expr
**var_expr
;
9788 static int total_var
= 0;
9789 static int nvar
= 0;
9790 int i
, old_nvar
, tmp
;
9791 gfc_forall_iterator
*fa
;
9795 /* Start to resolve a FORALL construct */
9796 if (forall_save
== 0)
9798 /* Count the total number of FORALL indices in the nested FORALL
9799 construct in order to allocate the VAR_EXPR with proper size. */
9800 total_var
= gfc_count_forall_iterators (code
);
9802 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9803 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9806 /* The information about FORALL iterator, including FORALL indices start, end
9807 and stride. An outer FORALL indice cannot appear in start, end or stride. */
9808 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9810 /* Fortran 20008: C738 (R753). */
9811 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
9813 gfc_error ("FORALL index-name at %L must be a scalar variable "
9814 "of type integer", &fa
->var
->where
);
9818 /* Check if any outer FORALL index name is the same as the current
9820 for (i
= 0; i
< nvar
; i
++)
9822 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9823 gfc_error ("An outer FORALL construct already has an index "
9824 "with this name %L", &fa
->var
->where
);
9827 /* Record the current FORALL index. */
9828 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9832 /* No memory leak. */
9833 gcc_assert (nvar
<= total_var
);
9836 /* Resolve the FORALL body. */
9837 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9839 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9840 gfc_resolve_blocks (code
->block
, ns
);
9844 /* Free only the VAR_EXPRs allocated in this frame. */
9845 for (i
= nvar
; i
< tmp
; i
++)
9846 gfc_free_expr (var_expr
[i
]);
9850 /* We are in the outermost FORALL construct. */
9851 gcc_assert (forall_save
== 0);
9853 /* VAR_EXPR is not needed any more. */
9860 /* Resolve a BLOCK construct statement. */
9863 resolve_block_construct (gfc_code
* code
)
9865 /* Resolve the BLOCK's namespace. */
9866 gfc_resolve (code
->ext
.block
.ns
);
9868 /* For an ASSOCIATE block, the associations (and their targets) are already
9869 resolved during resolve_symbol. */
9873 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9877 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9881 for (; b
; b
= b
->block
)
9883 t
= gfc_resolve_expr (b
->expr1
);
9884 if (!gfc_resolve_expr (b
->expr2
))
9890 if (t
&& b
->expr1
!= NULL
9891 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9892 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9899 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9900 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9905 resolve_branch (b
->label1
, b
);
9909 resolve_block_construct (b
);
9913 case EXEC_SELECT_TYPE
:
9917 case EXEC_DO_CONCURRENT
:
9925 case EXEC_OMP_ATOMIC
:
9926 case EXEC_OACC_ATOMIC
:
9928 gfc_omp_atomic_op aop
9929 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
9931 /* Verify this before calling gfc_resolve_code, which might
9933 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
9934 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
9935 && b
->next
->next
== NULL
)
9936 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
9937 && b
->next
->next
!= NULL
9938 && b
->next
->next
->op
== EXEC_ASSIGN
9939 && b
->next
->next
->next
== NULL
));
9943 case EXEC_OACC_PARALLEL_LOOP
:
9944 case EXEC_OACC_PARALLEL
:
9945 case EXEC_OACC_KERNELS_LOOP
:
9946 case EXEC_OACC_KERNELS
:
9947 case EXEC_OACC_DATA
:
9948 case EXEC_OACC_HOST_DATA
:
9949 case EXEC_OACC_LOOP
:
9950 case EXEC_OACC_UPDATE
:
9951 case EXEC_OACC_WAIT
:
9952 case EXEC_OACC_CACHE
:
9953 case EXEC_OACC_ENTER_DATA
:
9954 case EXEC_OACC_EXIT_DATA
:
9955 case EXEC_OACC_ROUTINE
:
9956 case EXEC_OMP_CRITICAL
:
9957 case EXEC_OMP_DISTRIBUTE
:
9958 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9959 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9960 case EXEC_OMP_DISTRIBUTE_SIMD
:
9962 case EXEC_OMP_DO_SIMD
:
9963 case EXEC_OMP_MASTER
:
9964 case EXEC_OMP_ORDERED
:
9965 case EXEC_OMP_PARALLEL
:
9966 case EXEC_OMP_PARALLEL_DO
:
9967 case EXEC_OMP_PARALLEL_DO_SIMD
:
9968 case EXEC_OMP_PARALLEL_SECTIONS
:
9969 case EXEC_OMP_PARALLEL_WORKSHARE
:
9970 case EXEC_OMP_SECTIONS
:
9972 case EXEC_OMP_SINGLE
:
9973 case EXEC_OMP_TARGET
:
9974 case EXEC_OMP_TARGET_DATA
:
9975 case EXEC_OMP_TARGET_ENTER_DATA
:
9976 case EXEC_OMP_TARGET_EXIT_DATA
:
9977 case EXEC_OMP_TARGET_PARALLEL
:
9978 case EXEC_OMP_TARGET_PARALLEL_DO
:
9979 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
9980 case EXEC_OMP_TARGET_SIMD
:
9981 case EXEC_OMP_TARGET_TEAMS
:
9982 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9983 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9984 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9985 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9986 case EXEC_OMP_TARGET_UPDATE
:
9988 case EXEC_OMP_TASKGROUP
:
9989 case EXEC_OMP_TASKLOOP
:
9990 case EXEC_OMP_TASKLOOP_SIMD
:
9991 case EXEC_OMP_TASKWAIT
:
9992 case EXEC_OMP_TASKYIELD
:
9993 case EXEC_OMP_TEAMS
:
9994 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9995 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9996 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9997 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9998 case EXEC_OMP_WORKSHARE
:
10002 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10005 gfc_resolve_code (b
->next
, ns
);
10010 /* Does everything to resolve an ordinary assignment. Returns true
10011 if this is an interface assignment. */
10013 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10022 symbol_attribute attr
;
10024 if (gfc_extend_assign (code
, ns
))
10028 if (code
->op
== EXEC_ASSIGN_CALL
)
10030 lhs
= code
->ext
.actual
->expr
;
10031 rhsptr
= &code
->ext
.actual
->next
->expr
;
10035 gfc_actual_arglist
* args
;
10036 gfc_typebound_proc
* tbp
;
10038 gcc_assert (code
->op
== EXEC_COMPCALL
);
10040 args
= code
->expr1
->value
.compcall
.actual
;
10042 rhsptr
= &args
->next
->expr
;
10044 tbp
= code
->expr1
->value
.compcall
.tbp
;
10045 gcc_assert (!tbp
->is_generic
);
10048 /* Make a temporary rhs when there is a default initializer
10049 and rhs is the same symbol as the lhs. */
10050 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10051 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10052 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10053 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10054 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10063 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10064 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10068 /* Handle the case of a BOZ literal on the RHS. */
10069 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10072 if (warn_surprising
)
10073 gfc_warning (OPT_Wsurprising
,
10074 "BOZ literal at %L is bitwise transferred "
10075 "non-integer symbol %qs", &code
->loc
,
10076 lhs
->symtree
->n
.sym
->name
);
10078 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10080 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10082 if (rc
== ARITH_UNDERFLOW
)
10083 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10084 ". This check can be disabled with the option "
10085 "%<-fno-range-check%>", &rhs
->where
);
10086 else if (rc
== ARITH_OVERFLOW
)
10087 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10088 ". This check can be disabled with the option "
10089 "%<-fno-range-check%>", &rhs
->where
);
10090 else if (rc
== ARITH_NAN
)
10091 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10092 ". This check can be disabled with the option "
10093 "%<-fno-range-check%>", &rhs
->where
);
10098 if (lhs
->ts
.type
== BT_CHARACTER
10099 && warn_character_truncation
)
10101 if (lhs
->ts
.u
.cl
!= NULL
10102 && lhs
->ts
.u
.cl
->length
!= NULL
10103 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10104 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
10106 if (rhs
->expr_type
== EXPR_CONSTANT
)
10107 rlen
= rhs
->value
.character
.length
;
10109 else if (rhs
->ts
.u
.cl
!= NULL
10110 && rhs
->ts
.u
.cl
->length
!= NULL
10111 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10112 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
10114 if (rlen
&& llen
&& rlen
> llen
)
10115 gfc_warning_now (OPT_Wcharacter_truncation
,
10116 "CHARACTER expression will be truncated "
10117 "in assignment (%d/%d) at %L",
10118 llen
, rlen
, &code
->loc
);
10121 /* Ensure that a vector index expression for the lvalue is evaluated
10122 to a temporary if the lvalue symbol is referenced in it. */
10125 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10126 if (ref
->type
== REF_ARRAY
)
10128 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10129 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10130 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10131 ref
->u
.ar
.start
[n
]))
10133 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10137 if (gfc_pure (NULL
))
10139 if (lhs
->ts
.type
== BT_DERIVED
10140 && lhs
->expr_type
== EXPR_VARIABLE
10141 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10142 && rhs
->expr_type
== EXPR_VARIABLE
10143 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10144 || gfc_is_coindexed (rhs
)))
10146 /* F2008, C1283. */
10147 if (gfc_is_coindexed (rhs
))
10148 gfc_error ("Coindexed expression at %L is assigned to "
10149 "a derived type variable with a POINTER "
10150 "component in a PURE procedure",
10153 gfc_error ("The impure variable at %L is assigned to "
10154 "a derived type variable with a POINTER "
10155 "component in a PURE procedure (12.6)",
10160 /* Fortran 2008, C1283. */
10161 if (gfc_is_coindexed (lhs
))
10163 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10164 "procedure", &rhs
->where
);
10169 if (gfc_implicit_pure (NULL
))
10171 if (lhs
->expr_type
== EXPR_VARIABLE
10172 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10173 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10174 gfc_unset_implicit_pure (NULL
);
10176 if (lhs
->ts
.type
== BT_DERIVED
10177 && lhs
->expr_type
== EXPR_VARIABLE
10178 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10179 && rhs
->expr_type
== EXPR_VARIABLE
10180 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10181 || gfc_is_coindexed (rhs
)))
10182 gfc_unset_implicit_pure (NULL
);
10184 /* Fortran 2008, C1283. */
10185 if (gfc_is_coindexed (lhs
))
10186 gfc_unset_implicit_pure (NULL
);
10189 /* F2008, 7.2.1.2. */
10190 attr
= gfc_expr_attr (lhs
);
10191 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10193 if (attr
.codimension
)
10195 gfc_error ("Assignment to polymorphic coarray at %L is not "
10196 "permitted", &lhs
->where
);
10199 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10200 "polymorphic variable at %L", &lhs
->where
))
10202 if (!flag_realloc_lhs
)
10204 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10205 "requires %<-frealloc-lhs%>", &lhs
->where
);
10209 else if (lhs
->ts
.type
== BT_CLASS
)
10211 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10212 "assignment at %L - check that there is a matching specific "
10213 "subroutine for '=' operator", &lhs
->where
);
10217 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10219 /* F2008, Section 7.2.1.2. */
10220 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10222 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10223 "component in assignment at %L", &lhs
->where
);
10227 /* Assign the 'data' of a class object to a derived type. */
10228 if (lhs
->ts
.type
== BT_DERIVED
10229 && rhs
->ts
.type
== BT_CLASS
)
10230 gfc_add_data_component (rhs
);
10232 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10234 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10235 && code
->expr2
->value
.function
.isym
10236 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10237 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10238 && !gfc_expr_attr (rhs
).allocatable
10239 && !gfc_has_vector_subscript (rhs
)));
10241 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10243 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10244 Additionally, insert this code when the RHS is a CAF as we then use the
10245 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10246 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10247 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10249 if (caf_convert_to_send
)
10251 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10252 && code
->expr2
->value
.function
.isym
10253 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10254 remove_caf_get_intrinsic (code
->expr2
);
10255 code
->op
= EXEC_CALL
;
10256 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10257 code
->resolved_sym
= code
->symtree
->n
.sym
;
10258 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10259 code
->resolved_sym
->attr
.intrinsic
= 1;
10260 code
->resolved_sym
->attr
.subroutine
= 1;
10261 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10262 gfc_commit_symbol (code
->resolved_sym
);
10263 code
->ext
.actual
= gfc_get_actual_arglist ();
10264 code
->ext
.actual
->expr
= lhs
;
10265 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10266 code
->ext
.actual
->next
->expr
= rhs
;
10267 code
->expr1
= NULL
;
10268 code
->expr2
= NULL
;
10275 /* Add a component reference onto an expression. */
10278 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10283 ref
= &((*ref
)->next
);
10284 *ref
= gfc_get_ref ();
10285 (*ref
)->type
= REF_COMPONENT
;
10286 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10287 (*ref
)->u
.c
.component
= c
;
10290 /* Add a full array ref, as necessary. */
10293 gfc_add_full_array_ref (e
, c
->as
);
10294 e
->rank
= c
->as
->rank
;
10299 /* Build an assignment. Keep the argument 'op' for future use, so that
10300 pointer assignments can be made. */
10303 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10304 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10306 gfc_code
*this_code
;
10308 this_code
= gfc_get_code (op
);
10309 this_code
->next
= NULL
;
10310 this_code
->expr1
= gfc_copy_expr (expr1
);
10311 this_code
->expr2
= gfc_copy_expr (expr2
);
10312 this_code
->loc
= loc
;
10313 if (comp1
&& comp2
)
10315 add_comp_ref (this_code
->expr1
, comp1
);
10316 add_comp_ref (this_code
->expr2
, comp2
);
10323 /* Makes a temporary variable expression based on the characteristics of
10324 a given variable expression. */
10327 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10329 static int serial
= 0;
10330 char name
[GFC_MAX_SYMBOL_LEN
];
10332 gfc_array_spec
*as
;
10333 gfc_array_ref
*aref
;
10336 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10337 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10338 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10344 /* Obtain the arrayspec for the temporary. */
10345 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10346 && e
->expr_type
!= EXPR_FUNCTION
10347 && e
->expr_type
!= EXPR_OP
)
10349 aref
= gfc_find_array_ref (e
);
10350 if (e
->expr_type
== EXPR_VARIABLE
10351 && e
->symtree
->n
.sym
->as
== aref
->as
)
10355 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10356 if (ref
->type
== REF_COMPONENT
10357 && ref
->u
.c
.component
->as
== aref
->as
)
10365 /* Add the attributes and the arrayspec to the temporary. */
10366 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10367 tmp
->n
.sym
->attr
.function
= 0;
10368 tmp
->n
.sym
->attr
.result
= 0;
10369 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10373 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10376 if (as
->type
== AS_DEFERRED
)
10377 tmp
->n
.sym
->attr
.allocatable
= 1;
10379 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10380 || e
->expr_type
== EXPR_FUNCTION
10381 || e
->expr_type
== EXPR_OP
))
10383 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10384 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10385 tmp
->n
.sym
->as
->rank
= e
->rank
;
10386 tmp
->n
.sym
->attr
.allocatable
= 1;
10387 tmp
->n
.sym
->attr
.dimension
= 1;
10390 tmp
->n
.sym
->attr
.dimension
= 0;
10392 gfc_set_sym_referenced (tmp
->n
.sym
);
10393 gfc_commit_symbol (tmp
->n
.sym
);
10394 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10396 /* Should the lhs be a section, use its array ref for the
10397 temporary expression. */
10398 if (aref
&& aref
->type
!= AR_FULL
)
10400 gfc_free_ref_list (e
->ref
);
10401 e
->ref
= gfc_copy_ref (ref
);
10407 /* Add one line of code to the code chain, making sure that 'head' and
10408 'tail' are appropriately updated. */
10411 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10413 gcc_assert (this_code
);
10415 *head
= *tail
= *this_code
;
10417 *tail
= gfc_append_code (*tail
, *this_code
);
10422 /* Counts the potential number of part array references that would
10423 result from resolution of typebound defined assignments. */
10426 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10429 int c_depth
= 0, t_depth
;
10431 for (c
= derived
->components
; c
; c
= c
->next
)
10433 if ((!gfc_bt_struct (c
->ts
.type
)
10435 || c
->attr
.allocatable
10436 || c
->attr
.proc_pointer_comp
10437 || c
->attr
.class_pointer
10438 || c
->attr
.proc_pointer
)
10439 && !c
->attr
.defined_assign_comp
)
10442 if (c
->as
&& c_depth
== 0)
10445 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10446 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10451 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10453 return depth
+ c_depth
;
10457 /* Implement 7.2.1.3 of the F08 standard:
10458 "An intrinsic assignment where the variable is of derived type is
10459 performed as if each component of the variable were assigned from the
10460 corresponding component of expr using pointer assignment (7.2.2) for
10461 each pointer component, defined assignment for each nonpointer
10462 nonallocatable component of a type that has a type-bound defined
10463 assignment consistent with the component, intrinsic assignment for
10464 each other nonpointer nonallocatable component, ..."
10466 The pointer assignments are taken care of by the intrinsic
10467 assignment of the structure itself. This function recursively adds
10468 defined assignments where required. The recursion is accomplished
10469 by calling gfc_resolve_code.
10471 When the lhs in a defined assignment has intent INOUT, we need a
10472 temporary for the lhs. In pseudo-code:
10474 ! Only call function lhs once.
10475 if (lhs is not a constant or an variable)
10478 ! Do the intrinsic assignment
10480 ! Now do the defined assignments
10481 do over components with typebound defined assignment [%cmp]
10482 #if one component's assignment procedure is INOUT
10484 #if expr2 non-variable
10490 t1%cmp {defined=} expr2%cmp
10496 expr1%cmp {defined=} expr2%cmp
10500 /* The temporary assignments have to be put on top of the additional
10501 code to avoid the result being changed by the intrinsic assignment.
10503 static int component_assignment_level
= 0;
10504 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10507 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10509 gfc_component
*comp1
, *comp2
;
10510 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10512 int error_count
, depth
;
10514 gfc_get_errors (NULL
, &error_count
);
10516 /* Filter out continuing processing after an error. */
10518 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10519 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10522 /* TODO: Handle more than one part array reference in assignments. */
10523 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10524 (*code
)->expr1
->rank
? 1 : 0);
10527 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10528 "done because multiple part array references would "
10529 "occur in intermediate expressions.", &(*code
)->loc
);
10533 component_assignment_level
++;
10535 /* Create a temporary so that functions get called only once. */
10536 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10537 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10539 gfc_expr
*tmp_expr
;
10541 /* Assign the rhs to the temporary. */
10542 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10543 this_code
= build_assignment (EXEC_ASSIGN
,
10544 tmp_expr
, (*code
)->expr2
,
10545 NULL
, NULL
, (*code
)->loc
);
10546 /* Add the code and substitute the rhs expression. */
10547 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10548 gfc_free_expr ((*code
)->expr2
);
10549 (*code
)->expr2
= tmp_expr
;
10552 /* Do the intrinsic assignment. This is not needed if the lhs is one
10553 of the temporaries generated here, since the intrinsic assignment
10554 to the final result already does this. */
10555 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10557 this_code
= build_assignment (EXEC_ASSIGN
,
10558 (*code
)->expr1
, (*code
)->expr2
,
10559 NULL
, NULL
, (*code
)->loc
);
10560 add_code_to_chain (&this_code
, &head
, &tail
);
10563 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10564 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10567 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10569 bool inout
= false;
10571 /* The intrinsic assignment does the right thing for pointers
10572 of all kinds and allocatable components. */
10573 if (!gfc_bt_struct (comp1
->ts
.type
)
10574 || comp1
->attr
.pointer
10575 || comp1
->attr
.allocatable
10576 || comp1
->attr
.proc_pointer_comp
10577 || comp1
->attr
.class_pointer
10578 || comp1
->attr
.proc_pointer
)
10581 /* Make an assigment for this component. */
10582 this_code
= build_assignment (EXEC_ASSIGN
,
10583 (*code
)->expr1
, (*code
)->expr2
,
10584 comp1
, comp2
, (*code
)->loc
);
10586 /* Convert the assignment if there is a defined assignment for
10587 this type. Otherwise, using the call from gfc_resolve_code,
10588 recurse into its components. */
10589 gfc_resolve_code (this_code
, ns
);
10591 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10593 gfc_formal_arglist
*dummy_args
;
10595 /* Check that there is a typebound defined assignment. If not,
10596 then this must be a module defined assignment. We cannot
10597 use the defined_assign_comp attribute here because it must
10598 be this derived type that has the defined assignment and not
10600 if (!(comp1
->ts
.u
.derived
->f2k_derived
10601 && comp1
->ts
.u
.derived
->f2k_derived
10602 ->tb_op
[INTRINSIC_ASSIGN
]))
10604 gfc_free_statements (this_code
);
10609 /* If the first argument of the subroutine has intent INOUT
10610 a temporary must be generated and used instead. */
10611 rsym
= this_code
->resolved_sym
;
10612 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10614 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10616 gfc_code
*temp_code
;
10619 /* Build the temporary required for the assignment and put
10620 it at the head of the generated code. */
10623 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10624 temp_code
= build_assignment (EXEC_ASSIGN
,
10625 t1
, (*code
)->expr1
,
10626 NULL
, NULL
, (*code
)->loc
);
10628 /* For allocatable LHS, check whether it is allocated. Note
10629 that allocatable components with defined assignment are
10630 not yet support. See PR 57696. */
10631 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10635 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10636 block
= gfc_get_code (EXEC_IF
);
10637 block
->block
= gfc_get_code (EXEC_IF
);
10638 block
->block
->expr1
10639 = gfc_build_intrinsic_call (ns
,
10640 GFC_ISYM_ALLOCATED
, "allocated",
10641 (*code
)->loc
, 1, e
);
10642 block
->block
->next
= temp_code
;
10645 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10648 /* Replace the first actual arg with the component of the
10650 gfc_free_expr (this_code
->ext
.actual
->expr
);
10651 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10652 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10654 /* If the LHS variable is allocatable and wasn't allocated and
10655 the temporary is allocatable, pointer assign the address of
10656 the freshly allocated LHS to the temporary. */
10657 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10658 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10663 cond
= gfc_get_expr ();
10664 cond
->ts
.type
= BT_LOGICAL
;
10665 cond
->ts
.kind
= gfc_default_logical_kind
;
10666 cond
->expr_type
= EXPR_OP
;
10667 cond
->where
= (*code
)->loc
;
10668 cond
->value
.op
.op
= INTRINSIC_NOT
;
10669 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10670 GFC_ISYM_ALLOCATED
, "allocated",
10671 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10672 block
= gfc_get_code (EXEC_IF
);
10673 block
->block
= gfc_get_code (EXEC_IF
);
10674 block
->block
->expr1
= cond
;
10675 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10676 t1
, (*code
)->expr1
,
10677 NULL
, NULL
, (*code
)->loc
);
10678 add_code_to_chain (&block
, &head
, &tail
);
10682 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10684 /* Don't add intrinsic assignments since they are already
10685 effected by the intrinsic assignment of the structure. */
10686 gfc_free_statements (this_code
);
10691 add_code_to_chain (&this_code
, &head
, &tail
);
10695 /* Transfer the value to the final result. */
10696 this_code
= build_assignment (EXEC_ASSIGN
,
10697 (*code
)->expr1
, t1
,
10698 comp1
, comp2
, (*code
)->loc
);
10699 add_code_to_chain (&this_code
, &head
, &tail
);
10703 /* Put the temporary assignments at the top of the generated code. */
10704 if (tmp_head
&& component_assignment_level
== 1)
10706 gfc_append_code (tmp_head
, head
);
10708 tmp_head
= tmp_tail
= NULL
;
10711 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10712 // not accidentally deallocated. Hence, nullify t1.
10713 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10714 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10720 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10721 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10722 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10723 block
= gfc_get_code (EXEC_IF
);
10724 block
->block
= gfc_get_code (EXEC_IF
);
10725 block
->block
->expr1
= cond
;
10726 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10727 t1
, gfc_get_null_expr (&(*code
)->loc
),
10728 NULL
, NULL
, (*code
)->loc
);
10729 gfc_append_code (tail
, block
);
10733 /* Now attach the remaining code chain to the input code. Step on
10734 to the end of the new code since resolution is complete. */
10735 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10736 tail
->next
= (*code
)->next
;
10737 /* Overwrite 'code' because this would place the intrinsic assignment
10738 before the temporary for the lhs is created. */
10739 gfc_free_expr ((*code
)->expr1
);
10740 gfc_free_expr ((*code
)->expr2
);
10746 component_assignment_level
--;
10750 /* F2008: Pointer function assignments are of the form:
10751 ptr_fcn (args) = expr
10752 This function breaks these assignments into two statements:
10753 temporary_pointer => ptr_fcn(args)
10754 temporary_pointer = expr */
10757 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10759 gfc_expr
*tmp_ptr_expr
;
10760 gfc_code
*this_code
;
10761 gfc_component
*comp
;
10764 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10767 /* Even if standard does not support this feature, continue to build
10768 the two statements to avoid upsetting frontend_passes.c. */
10769 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10770 "%L", &(*code
)->loc
);
10772 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10775 s
= comp
->ts
.interface
;
10777 s
= (*code
)->expr1
->symtree
->n
.sym
;
10779 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10781 gfc_error ("The function result on the lhs of the assignment at "
10782 "%L must have the pointer attribute.",
10783 &(*code
)->expr1
->where
);
10784 (*code
)->op
= EXEC_NOP
;
10788 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10790 /* get_temp_from_expression is set up for ordinary assignments. To that
10791 end, where array bounds are not known, arrays are made allocatable.
10792 Change the temporary to a pointer here. */
10793 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10794 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10795 tmp_ptr_expr
->where
= (*code
)->loc
;
10797 this_code
= build_assignment (EXEC_ASSIGN
,
10798 tmp_ptr_expr
, (*code
)->expr2
,
10799 NULL
, NULL
, (*code
)->loc
);
10800 this_code
->next
= (*code
)->next
;
10801 (*code
)->next
= this_code
;
10802 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10803 (*code
)->expr2
= (*code
)->expr1
;
10804 (*code
)->expr1
= tmp_ptr_expr
;
10810 /* Deferred character length assignments from an operator expression
10811 require a temporary because the character length of the lhs can
10812 change in the course of the assignment. */
10815 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10817 gfc_expr
*tmp_expr
;
10818 gfc_code
*this_code
;
10820 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10821 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10822 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10825 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10828 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10829 tmp_expr
->where
= (*code
)->loc
;
10831 /* A new charlen is required to ensure that the variable string
10832 length is different to that of the original lhs. */
10833 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10834 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10835 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10836 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10838 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10840 this_code
= build_assignment (EXEC_ASSIGN
,
10842 gfc_copy_expr (tmp_expr
),
10843 NULL
, NULL
, (*code
)->loc
);
10845 (*code
)->expr1
= tmp_expr
;
10847 this_code
->next
= (*code
)->next
;
10848 (*code
)->next
= this_code
;
10854 /* Given a block of code, recursively resolve everything pointed to by this
10858 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10860 int omp_workshare_save
;
10861 int forall_save
, do_concurrent_save
;
10865 frame
.prev
= cs_base
;
10869 find_reachable_labels (code
);
10871 for (; code
; code
= code
->next
)
10873 frame
.current
= code
;
10874 forall_save
= forall_flag
;
10875 do_concurrent_save
= gfc_do_concurrent_flag
;
10877 if (code
->op
== EXEC_FORALL
)
10880 gfc_resolve_forall (code
, ns
, forall_save
);
10883 else if (code
->block
)
10885 omp_workshare_save
= -1;
10888 case EXEC_OACC_PARALLEL_LOOP
:
10889 case EXEC_OACC_PARALLEL
:
10890 case EXEC_OACC_KERNELS_LOOP
:
10891 case EXEC_OACC_KERNELS
:
10892 case EXEC_OACC_DATA
:
10893 case EXEC_OACC_HOST_DATA
:
10894 case EXEC_OACC_LOOP
:
10895 gfc_resolve_oacc_blocks (code
, ns
);
10897 case EXEC_OMP_PARALLEL_WORKSHARE
:
10898 omp_workshare_save
= omp_workshare_flag
;
10899 omp_workshare_flag
= 1;
10900 gfc_resolve_omp_parallel_blocks (code
, ns
);
10902 case EXEC_OMP_PARALLEL
:
10903 case EXEC_OMP_PARALLEL_DO
:
10904 case EXEC_OMP_PARALLEL_DO_SIMD
:
10905 case EXEC_OMP_PARALLEL_SECTIONS
:
10906 case EXEC_OMP_TARGET_PARALLEL
:
10907 case EXEC_OMP_TARGET_PARALLEL_DO
:
10908 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10909 case EXEC_OMP_TARGET_TEAMS
:
10910 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10911 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10912 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10913 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10914 case EXEC_OMP_TASK
:
10915 case EXEC_OMP_TEAMS
:
10916 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10917 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10918 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10919 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10920 omp_workshare_save
= omp_workshare_flag
;
10921 omp_workshare_flag
= 0;
10922 gfc_resolve_omp_parallel_blocks (code
, ns
);
10924 case EXEC_OMP_DISTRIBUTE
:
10925 case EXEC_OMP_DISTRIBUTE_SIMD
:
10927 case EXEC_OMP_DO_SIMD
:
10928 case EXEC_OMP_SIMD
:
10929 case EXEC_OMP_TARGET_SIMD
:
10930 case EXEC_OMP_TASKLOOP
:
10931 case EXEC_OMP_TASKLOOP_SIMD
:
10932 gfc_resolve_omp_do_blocks (code
, ns
);
10934 case EXEC_SELECT_TYPE
:
10935 /* Blocks are handled in resolve_select_type because we have
10936 to transform the SELECT TYPE into ASSOCIATE first. */
10938 case EXEC_DO_CONCURRENT
:
10939 gfc_do_concurrent_flag
= 1;
10940 gfc_resolve_blocks (code
->block
, ns
);
10941 gfc_do_concurrent_flag
= 2;
10943 case EXEC_OMP_WORKSHARE
:
10944 omp_workshare_save
= omp_workshare_flag
;
10945 omp_workshare_flag
= 1;
10948 gfc_resolve_blocks (code
->block
, ns
);
10952 if (omp_workshare_save
!= -1)
10953 omp_workshare_flag
= omp_workshare_save
;
10957 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10958 t
= gfc_resolve_expr (code
->expr1
);
10959 forall_flag
= forall_save
;
10960 gfc_do_concurrent_flag
= do_concurrent_save
;
10962 if (!gfc_resolve_expr (code
->expr2
))
10965 if (code
->op
== EXEC_ALLOCATE
10966 && !gfc_resolve_expr (code
->expr3
))
10972 case EXEC_END_BLOCK
:
10973 case EXEC_END_NESTED_BLOCK
:
10977 case EXEC_ERROR_STOP
:
10979 case EXEC_CONTINUE
:
10981 case EXEC_ASSIGN_CALL
:
10984 case EXEC_CRITICAL
:
10985 resolve_critical (code
);
10988 case EXEC_SYNC_ALL
:
10989 case EXEC_SYNC_IMAGES
:
10990 case EXEC_SYNC_MEMORY
:
10991 resolve_sync (code
);
10996 case EXEC_EVENT_POST
:
10997 case EXEC_EVENT_WAIT
:
10998 resolve_lock_unlock_event (code
);
11001 case EXEC_FAIL_IMAGE
:
11005 /* Keep track of which entry we are up to. */
11006 current_entry_id
= code
->ext
.entry
->id
;
11010 resolve_where (code
, NULL
);
11014 if (code
->expr1
!= NULL
)
11016 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11017 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11018 "INTEGER variable", &code
->expr1
->where
);
11019 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11020 gfc_error ("Variable %qs has not been assigned a target "
11021 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11022 &code
->expr1
->where
);
11025 resolve_branch (code
->label1
, code
);
11029 if (code
->expr1
!= NULL
11030 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11031 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11032 "INTEGER return specifier", &code
->expr1
->where
);
11035 case EXEC_INIT_ASSIGN
:
11036 case EXEC_END_PROCEDURE
:
11043 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11045 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11046 && code
->expr1
->value
.function
.isym
11047 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11048 remove_caf_get_intrinsic (code
->expr1
);
11050 /* If this is a pointer function in an lvalue variable context,
11051 the new code will have to be resolved afresh. This is also the
11052 case with an error, where the code is transformed into NOP to
11053 prevent ICEs downstream. */
11054 if (resolve_ptr_fcn_assign (&code
, ns
)
11055 || code
->op
== EXEC_NOP
)
11058 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11062 if (resolve_ordinary_assign (code
, ns
))
11064 if (code
->op
== EXEC_COMPCALL
)
11070 /* Check for dependencies in deferred character length array
11071 assignments and generate a temporary, if necessary. */
11072 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11075 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11076 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11077 && code
->expr1
->ts
.u
.derived
11078 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11079 generate_component_assignments (&code
, ns
);
11083 case EXEC_LABEL_ASSIGN
:
11084 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11085 gfc_error ("Label %d referenced at %L is never defined",
11086 code
->label1
->value
, &code
->label1
->where
);
11088 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11089 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11090 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11091 != gfc_default_integer_kind
11092 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11093 gfc_error ("ASSIGN statement at %L requires a scalar "
11094 "default INTEGER variable", &code
->expr1
->where
);
11097 case EXEC_POINTER_ASSIGN
:
11104 /* This is both a variable definition and pointer assignment
11105 context, so check both of them. For rank remapping, a final
11106 array ref may be present on the LHS and fool gfc_expr_attr
11107 used in gfc_check_vardef_context. Remove it. */
11108 e
= remove_last_array_ref (code
->expr1
);
11109 t
= gfc_check_vardef_context (e
, true, false, false,
11110 _("pointer assignment"));
11112 t
= gfc_check_vardef_context (e
, false, false, false,
11113 _("pointer assignment"));
11118 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
11120 /* Assigning a class object always is a regular assign. */
11121 if (code
->expr2
->ts
.type
== BT_CLASS
11122 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11123 && !(UNLIMITED_POLY (code
->expr2
)
11124 && code
->expr1
->ts
.type
== BT_DERIVED
11125 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
11126 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
11127 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11128 && code
->expr2
->expr_type
== EXPR_VARIABLE
11129 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11131 code
->op
= EXEC_ASSIGN
;
11135 case EXEC_ARITHMETIC_IF
:
11137 gfc_expr
*e
= code
->expr1
;
11139 gfc_resolve_expr (e
);
11140 if (e
->expr_type
== EXPR_NULL
)
11141 gfc_error ("Invalid NULL at %L", &e
->where
);
11143 if (t
&& (e
->rank
> 0
11144 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11145 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11146 "REAL or INTEGER expression", &e
->where
);
11148 resolve_branch (code
->label1
, code
);
11149 resolve_branch (code
->label2
, code
);
11150 resolve_branch (code
->label3
, code
);
11155 if (t
&& code
->expr1
!= NULL
11156 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11157 || code
->expr1
->rank
!= 0))
11158 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11159 &code
->expr1
->where
);
11164 resolve_call (code
);
11167 case EXEC_COMPCALL
:
11169 resolve_typebound_subroutine (code
);
11172 case EXEC_CALL_PPC
:
11173 resolve_ppc_call (code
);
11177 /* Select is complicated. Also, a SELECT construct could be
11178 a transformed computed GOTO. */
11179 resolve_select (code
, false);
11182 case EXEC_SELECT_TYPE
:
11183 resolve_select_type (code
, ns
);
11187 resolve_block_construct (code
);
11191 if (code
->ext
.iterator
!= NULL
)
11193 gfc_iterator
*iter
= code
->ext
.iterator
;
11194 if (gfc_resolve_iterator (iter
, true, false))
11195 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
11199 case EXEC_DO_WHILE
:
11200 if (code
->expr1
== NULL
)
11201 gfc_internal_error ("gfc_resolve_code(): No expression on "
11204 && (code
->expr1
->rank
!= 0
11205 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11206 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11207 "a scalar LOGICAL expression", &code
->expr1
->where
);
11210 case EXEC_ALLOCATE
:
11212 resolve_allocate_deallocate (code
, "ALLOCATE");
11216 case EXEC_DEALLOCATE
:
11218 resolve_allocate_deallocate (code
, "DEALLOCATE");
11223 if (!gfc_resolve_open (code
->ext
.open
))
11226 resolve_branch (code
->ext
.open
->err
, code
);
11230 if (!gfc_resolve_close (code
->ext
.close
))
11233 resolve_branch (code
->ext
.close
->err
, code
);
11236 case EXEC_BACKSPACE
:
11240 if (!gfc_resolve_filepos (code
->ext
.filepos
))
11243 resolve_branch (code
->ext
.filepos
->err
, code
);
11247 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11250 resolve_branch (code
->ext
.inquire
->err
, code
);
11253 case EXEC_IOLENGTH
:
11254 gcc_assert (code
->ext
.inquire
!= NULL
);
11255 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11258 resolve_branch (code
->ext
.inquire
->err
, code
);
11262 if (!gfc_resolve_wait (code
->ext
.wait
))
11265 resolve_branch (code
->ext
.wait
->err
, code
);
11266 resolve_branch (code
->ext
.wait
->end
, code
);
11267 resolve_branch (code
->ext
.wait
->eor
, code
);
11272 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11275 resolve_branch (code
->ext
.dt
->err
, code
);
11276 resolve_branch (code
->ext
.dt
->end
, code
);
11277 resolve_branch (code
->ext
.dt
->eor
, code
);
11280 case EXEC_TRANSFER
:
11281 resolve_transfer (code
);
11284 case EXEC_DO_CONCURRENT
:
11286 resolve_forall_iterators (code
->ext
.forall_iterator
);
11288 if (code
->expr1
!= NULL
11289 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11290 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11291 "expression", &code
->expr1
->where
);
11294 case EXEC_OACC_PARALLEL_LOOP
:
11295 case EXEC_OACC_PARALLEL
:
11296 case EXEC_OACC_KERNELS_LOOP
:
11297 case EXEC_OACC_KERNELS
:
11298 case EXEC_OACC_DATA
:
11299 case EXEC_OACC_HOST_DATA
:
11300 case EXEC_OACC_LOOP
:
11301 case EXEC_OACC_UPDATE
:
11302 case EXEC_OACC_WAIT
:
11303 case EXEC_OACC_CACHE
:
11304 case EXEC_OACC_ENTER_DATA
:
11305 case EXEC_OACC_EXIT_DATA
:
11306 case EXEC_OACC_ATOMIC
:
11307 case EXEC_OACC_DECLARE
:
11308 gfc_resolve_oacc_directive (code
, ns
);
11311 case EXEC_OMP_ATOMIC
:
11312 case EXEC_OMP_BARRIER
:
11313 case EXEC_OMP_CANCEL
:
11314 case EXEC_OMP_CANCELLATION_POINT
:
11315 case EXEC_OMP_CRITICAL
:
11316 case EXEC_OMP_FLUSH
:
11317 case EXEC_OMP_DISTRIBUTE
:
11318 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11319 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11320 case EXEC_OMP_DISTRIBUTE_SIMD
:
11322 case EXEC_OMP_DO_SIMD
:
11323 case EXEC_OMP_MASTER
:
11324 case EXEC_OMP_ORDERED
:
11325 case EXEC_OMP_SECTIONS
:
11326 case EXEC_OMP_SIMD
:
11327 case EXEC_OMP_SINGLE
:
11328 case EXEC_OMP_TARGET
:
11329 case EXEC_OMP_TARGET_DATA
:
11330 case EXEC_OMP_TARGET_ENTER_DATA
:
11331 case EXEC_OMP_TARGET_EXIT_DATA
:
11332 case EXEC_OMP_TARGET_PARALLEL
:
11333 case EXEC_OMP_TARGET_PARALLEL_DO
:
11334 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11335 case EXEC_OMP_TARGET_SIMD
:
11336 case EXEC_OMP_TARGET_TEAMS
:
11337 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11338 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11339 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11340 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11341 case EXEC_OMP_TARGET_UPDATE
:
11342 case EXEC_OMP_TASK
:
11343 case EXEC_OMP_TASKGROUP
:
11344 case EXEC_OMP_TASKLOOP
:
11345 case EXEC_OMP_TASKLOOP_SIMD
:
11346 case EXEC_OMP_TASKWAIT
:
11347 case EXEC_OMP_TASKYIELD
:
11348 case EXEC_OMP_TEAMS
:
11349 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11350 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11351 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11352 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11353 case EXEC_OMP_WORKSHARE
:
11354 gfc_resolve_omp_directive (code
, ns
);
11357 case EXEC_OMP_PARALLEL
:
11358 case EXEC_OMP_PARALLEL_DO
:
11359 case EXEC_OMP_PARALLEL_DO_SIMD
:
11360 case EXEC_OMP_PARALLEL_SECTIONS
:
11361 case EXEC_OMP_PARALLEL_WORKSHARE
:
11362 omp_workshare_save
= omp_workshare_flag
;
11363 omp_workshare_flag
= 0;
11364 gfc_resolve_omp_directive (code
, ns
);
11365 omp_workshare_flag
= omp_workshare_save
;
11369 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11373 cs_base
= frame
.prev
;
11377 /* Resolve initial values and make sure they are compatible with
11381 resolve_values (gfc_symbol
*sym
)
11385 if (sym
->value
== NULL
)
11388 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11389 t
= resolve_structure_cons (sym
->value
, 1);
11391 t
= gfc_resolve_expr (sym
->value
);
11396 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11400 /* Verify any BIND(C) derived types in the namespace so we can report errors
11401 for them once, rather than for each variable declared of that type. */
11404 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11406 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11407 && derived_sym
->attr
.is_bind_c
== 1)
11408 verify_bind_c_derived_type (derived_sym
);
11414 /* Check the interfaces of DTIO procedures associated with derived
11415 type 'sym'. These procedures can either have typebound bindings or
11416 can appear in DTIO generic interfaces. */
11419 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11421 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11424 gfc_check_dtio_interfaces (sym
);
11429 /* Verify that any binding labels used in a given namespace do not collide
11430 with the names or binding labels of any global symbols. Multiple INTERFACE
11431 for the same procedure are permitted. */
11434 gfc_verify_binding_labels (gfc_symbol
*sym
)
11437 const char *module
;
11439 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11440 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11443 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11446 module
= sym
->module
;
11447 else if (sym
->ns
&& sym
->ns
->proc_name
11448 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11449 module
= sym
->ns
->proc_name
->name
;
11450 else if (sym
->ns
&& sym
->ns
->parent
11451 && sym
->ns
&& sym
->ns
->parent
->proc_name
11452 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11453 module
= sym
->ns
->parent
->proc_name
->name
;
11459 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11462 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11463 gsym
->where
= sym
->declared_at
;
11464 gsym
->sym_name
= sym
->name
;
11465 gsym
->binding_label
= sym
->binding_label
;
11466 gsym
->ns
= sym
->ns
;
11467 gsym
->mod_name
= module
;
11468 if (sym
->attr
.function
)
11469 gsym
->type
= GSYM_FUNCTION
;
11470 else if (sym
->attr
.subroutine
)
11471 gsym
->type
= GSYM_SUBROUTINE
;
11472 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11473 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11477 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11479 gfc_error ("Variable %s with binding label %s at %L uses the same global "
11480 "identifier as entity at %L", sym
->name
,
11481 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11482 /* Clear the binding label to prevent checking multiple times. */
11483 sym
->binding_label
= NULL
;
11486 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11487 && (strcmp (module
, gsym
->mod_name
) != 0
11488 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11490 /* This can only happen if the variable is defined in a module - if it
11491 isn't the same module, reject it. */
11492 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
11493 "the same global identifier as entity at %L from module %s",
11494 sym
->name
, module
, sym
->binding_label
,
11495 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11496 sym
->binding_label
= NULL
;
11498 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11499 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11500 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11501 && sym
!= gsym
->ns
->proc_name
11502 && (module
!= gsym
->mod_name
11503 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11504 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11506 /* Print an error if the procedure is defined multiple times; we have to
11507 exclude references to the same procedure via module association or
11508 multiple checks for the same procedure. */
11509 gfc_error ("Procedure %s with binding label %s at %L uses the same "
11510 "global identifier as entity at %L", sym
->name
,
11511 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11512 sym
->binding_label
= NULL
;
11517 /* Resolve an index expression. */
11520 resolve_index_expr (gfc_expr
*e
)
11522 if (!gfc_resolve_expr (e
))
11525 if (!gfc_simplify_expr (e
, 0))
11528 if (!gfc_specification_expr (e
))
11535 /* Resolve a charlen structure. */
11538 resolve_charlen (gfc_charlen
*cl
)
11541 bool saved_specification_expr
;
11547 saved_specification_expr
= specification_expr
;
11548 specification_expr
= true;
11550 if (cl
->length_from_typespec
)
11552 if (!gfc_resolve_expr (cl
->length
))
11554 specification_expr
= saved_specification_expr
;
11558 if (!gfc_simplify_expr (cl
->length
, 0))
11560 specification_expr
= saved_specification_expr
;
11567 if (!resolve_index_expr (cl
->length
))
11569 specification_expr
= saved_specification_expr
;
11574 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11575 a negative value, the length of character entities declared is zero. */
11576 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
11577 gfc_replace_expr (cl
->length
,
11578 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
11580 /* Check that the character length is not too large. */
11581 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11582 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11583 && cl
->length
->ts
.type
== BT_INTEGER
11584 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11586 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11587 specification_expr
= saved_specification_expr
;
11591 specification_expr
= saved_specification_expr
;
11596 /* Test for non-constant shape arrays. */
11599 is_non_constant_shape_array (gfc_symbol
*sym
)
11605 not_constant
= false;
11606 if (sym
->as
!= NULL
)
11608 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11609 has not been simplified; parameter array references. Do the
11610 simplification now. */
11611 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11613 e
= sym
->as
->lower
[i
];
11614 if (e
&& (!resolve_index_expr(e
)
11615 || !gfc_is_constant_expr (e
)))
11616 not_constant
= true;
11617 e
= sym
->as
->upper
[i
];
11618 if (e
&& (!resolve_index_expr(e
)
11619 || !gfc_is_constant_expr (e
)))
11620 not_constant
= true;
11623 return not_constant
;
11626 /* Given a symbol and an initialization expression, add code to initialize
11627 the symbol to the function entry. */
11629 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11633 gfc_namespace
*ns
= sym
->ns
;
11635 /* Search for the function namespace if this is a contained
11636 function without an explicit result. */
11637 if (sym
->attr
.function
&& sym
== sym
->result
11638 && sym
->name
!= sym
->ns
->proc_name
->name
)
11640 ns
= ns
->contained
;
11641 for (;ns
; ns
= ns
->sibling
)
11642 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11648 gfc_free_expr (init
);
11652 /* Build an l-value expression for the result. */
11653 lval
= gfc_lval_expr_from_sym (sym
);
11655 /* Add the code at scope entry. */
11656 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11657 init_st
->next
= ns
->code
;
11658 ns
->code
= init_st
;
11660 /* Assign the default initializer to the l-value. */
11661 init_st
->loc
= sym
->declared_at
;
11662 init_st
->expr1
= lval
;
11663 init_st
->expr2
= init
;
11667 /* Whether or not we can generate a default initializer for a symbol. */
11670 can_generate_init (gfc_symbol
*sym
)
11672 symbol_attribute
*a
;
11677 /* These symbols should never have a default initialization. */
11682 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11683 && (CLASS_DATA (sym
)->attr
.class_pointer
11684 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11685 || a
->in_equivalence
11692 || (!a
->referenced
&& !a
->result
)
11693 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
11694 || (a
->function
&& sym
!= sym
->result
)
11699 /* Assign the default initializer to a derived type variable or result. */
11702 apply_default_init (gfc_symbol
*sym
)
11704 gfc_expr
*init
= NULL
;
11706 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11709 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11710 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11712 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11715 build_init_assign (sym
, init
);
11716 sym
->attr
.referenced
= 1;
11720 /* Build an initializer for a local. Returns null if the symbol should not have
11721 a default initialization. */
11724 build_default_init_expr (gfc_symbol
*sym
)
11726 /* These symbols should never have a default initialization. */
11727 if (sym
->attr
.allocatable
11728 || sym
->attr
.external
11730 || sym
->attr
.pointer
11731 || sym
->attr
.in_equivalence
11732 || sym
->attr
.in_common
11735 || sym
->attr
.cray_pointee
11736 || sym
->attr
.cray_pointer
11740 /* Get the appropriate init expression. */
11741 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
11744 /* Add an initialization expression to a local variable. */
11746 apply_default_init_local (gfc_symbol
*sym
)
11748 gfc_expr
*init
= NULL
;
11750 /* The symbol should be a variable or a function return value. */
11751 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11752 || (sym
->attr
.function
&& sym
->result
!= sym
))
11755 /* Try to build the initializer expression. If we can't initialize
11756 this symbol, then init will be NULL. */
11757 init
= build_default_init_expr (sym
);
11761 /* For saved variables, we don't want to add an initializer at function
11762 entry, so we just add a static initializer. Note that automatic variables
11763 are stack allocated even with -fno-automatic; we have also to exclude
11764 result variable, which are also nonstatic. */
11765 if (!sym
->attr
.automatic
11766 && (sym
->attr
.save
|| sym
->ns
->save_all
11767 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11768 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11769 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
11771 /* Don't clobber an existing initializer! */
11772 gcc_assert (sym
->value
== NULL
);
11777 build_init_assign (sym
, init
);
11781 /* Resolution of common features of flavors variable and procedure. */
11784 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11786 gfc_array_spec
*as
;
11788 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11789 as
= CLASS_DATA (sym
)->as
;
11793 /* Constraints on deferred shape variable. */
11794 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11796 bool pointer
, allocatable
, dimension
;
11798 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11800 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11801 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11802 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11806 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11807 allocatable
= sym
->attr
.allocatable
;
11808 dimension
= sym
->attr
.dimension
;
11813 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11815 gfc_error ("Allocatable array %qs at %L must have a deferred "
11816 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11819 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11820 "%qs at %L may not be ALLOCATABLE",
11821 sym
->name
, &sym
->declared_at
))
11825 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11827 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11828 "assumed rank", sym
->name
, &sym
->declared_at
);
11834 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11835 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11837 gfc_error ("Array %qs at %L cannot have a deferred shape",
11838 sym
->name
, &sym
->declared_at
);
11843 /* Constraints on polymorphic variables. */
11844 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11847 if (sym
->attr
.class_ok
11848 && !sym
->attr
.select_type_temporary
11849 && !UNLIMITED_POLY (sym
)
11850 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11852 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11853 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11854 &sym
->declared_at
);
11859 /* Assume that use associated symbols were checked in the module ns.
11860 Class-variables that are associate-names are also something special
11861 and excepted from the test. */
11862 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11864 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11865 "or pointer", sym
->name
, &sym
->declared_at
);
11874 /* Additional checks for symbols with flavor variable and derived
11875 type. To be called from resolve_fl_variable. */
11878 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11880 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11882 /* Check to see if a derived type is blocked from being host
11883 associated by the presence of another class I symbol in the same
11884 namespace. 14.6.1.3 of the standard and the discussion on
11885 comp.lang.fortran. */
11886 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11887 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11890 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11891 if (s
&& s
->attr
.generic
)
11892 s
= gfc_find_dt_in_generic (s
);
11893 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
11895 gfc_error ("The type %qs cannot be host associated at %L "
11896 "because it is blocked by an incompatible object "
11897 "of the same name declared at %L",
11898 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11904 /* 4th constraint in section 11.3: "If an object of a type for which
11905 component-initialization is specified (R429) appears in the
11906 specification-part of a module and does not have the ALLOCATABLE
11907 or POINTER attribute, the object shall have the SAVE attribute."
11909 The check for initializers is performed with
11910 gfc_has_default_initializer because gfc_default_initializer generates
11911 a hidden default for allocatable components. */
11912 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11913 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11914 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
11915 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11916 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11917 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11918 "%qs at %L, needed due to the default "
11919 "initialization", sym
->name
, &sym
->declared_at
))
11922 /* Assign default initializer. */
11923 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11924 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11925 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11931 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
11932 except in the declaration of an entity or component that has the POINTER
11933 or ALLOCATABLE attribute. */
11936 deferred_requirements (gfc_symbol
*sym
)
11938 if (sym
->ts
.deferred
11939 && !(sym
->attr
.pointer
11940 || sym
->attr
.allocatable
11941 || sym
->attr
.associate_var
11942 || sym
->attr
.omp_udr_artificial_var
))
11944 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11945 "requires either the POINTER or ALLOCATABLE attribute",
11946 sym
->name
, &sym
->declared_at
);
11953 /* Resolve symbols with flavor variable. */
11956 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11958 int no_init_flag
, automatic_flag
;
11960 const char *auto_save_msg
;
11961 bool saved_specification_expr
;
11963 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11966 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11969 /* Set this flag to check that variables are parameters of all entries.
11970 This check is effected by the call to gfc_resolve_expr through
11971 is_non_constant_shape_array. */
11972 saved_specification_expr
= specification_expr
;
11973 specification_expr
= true;
11975 if (sym
->ns
->proc_name
11976 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11977 || sym
->ns
->proc_name
->attr
.is_main_program
)
11978 && !sym
->attr
.use_assoc
11979 && !sym
->attr
.allocatable
11980 && !sym
->attr
.pointer
11981 && is_non_constant_shape_array (sym
))
11983 /* F08:C541. The shape of an array defined in a main program or module
11984 * needs to be constant. */
11985 gfc_error ("The module or main program array %qs at %L must "
11986 "have constant shape", sym
->name
, &sym
->declared_at
);
11987 specification_expr
= saved_specification_expr
;
11991 /* Constraints on deferred type parameter. */
11992 if (!deferred_requirements (sym
))
11995 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
11997 /* Make sure that character string variables with assumed length are
11998 dummy arguments. */
11999 e
= sym
->ts
.u
.cl
->length
;
12000 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12001 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12002 && !sym
->attr
.omp_udr_artificial_var
)
12004 gfc_error ("Entity with assumed character length at %L must be a "
12005 "dummy argument or a PARAMETER", &sym
->declared_at
);
12006 specification_expr
= saved_specification_expr
;
12010 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12012 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12013 specification_expr
= saved_specification_expr
;
12017 if (!gfc_is_constant_expr (e
)
12018 && !(e
->expr_type
== EXPR_VARIABLE
12019 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12021 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12022 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12023 || sym
->ns
->proc_name
->attr
.is_main_program
))
12025 gfc_error ("%qs at %L must have constant character length "
12026 "in this context", sym
->name
, &sym
->declared_at
);
12027 specification_expr
= saved_specification_expr
;
12030 if (sym
->attr
.in_common
)
12032 gfc_error ("COMMON variable %qs at %L must have constant "
12033 "character length", sym
->name
, &sym
->declared_at
);
12034 specification_expr
= saved_specification_expr
;
12040 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12041 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12043 /* Determine if the symbol may not have an initializer. */
12044 no_init_flag
= automatic_flag
= 0;
12045 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12046 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12048 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12049 && is_non_constant_shape_array (sym
))
12051 no_init_flag
= automatic_flag
= 1;
12053 /* Also, they must not have the SAVE attribute.
12054 SAVE_IMPLICIT is checked below. */
12055 if (sym
->as
&& sym
->attr
.codimension
)
12057 int corank
= sym
->as
->corank
;
12058 sym
->as
->corank
= 0;
12059 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12060 sym
->as
->corank
= corank
;
12062 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12064 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12065 specification_expr
= saved_specification_expr
;
12070 /* Ensure that any initializer is simplified. */
12072 gfc_simplify_expr (sym
->value
, 1);
12074 /* Reject illegal initializers. */
12075 if (!sym
->mark
&& sym
->value
)
12077 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12078 && CLASS_DATA (sym
)->attr
.allocatable
))
12079 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12080 sym
->name
, &sym
->declared_at
);
12081 else if (sym
->attr
.external
)
12082 gfc_error ("External %qs at %L cannot have an initializer",
12083 sym
->name
, &sym
->declared_at
);
12084 else if (sym
->attr
.dummy
12085 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12086 gfc_error ("Dummy %qs at %L cannot have an initializer",
12087 sym
->name
, &sym
->declared_at
);
12088 else if (sym
->attr
.intrinsic
)
12089 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12090 sym
->name
, &sym
->declared_at
);
12091 else if (sym
->attr
.result
)
12092 gfc_error ("Function result %qs at %L cannot have an initializer",
12093 sym
->name
, &sym
->declared_at
);
12094 else if (automatic_flag
)
12095 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12096 sym
->name
, &sym
->declared_at
);
12098 goto no_init_error
;
12099 specification_expr
= saved_specification_expr
;
12104 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12106 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12107 specification_expr
= saved_specification_expr
;
12111 specification_expr
= saved_specification_expr
;
12116 /* Compare the dummy characteristics of a module procedure interface
12117 declaration with the corresponding declaration in a submodule. */
12118 static gfc_formal_arglist
*new_formal
;
12119 static char errmsg
[200];
12122 compare_fsyms (gfc_symbol
*sym
)
12126 if (sym
== NULL
|| new_formal
== NULL
)
12129 fsym
= new_formal
->sym
;
12134 if (strcmp (sym
->name
, fsym
->name
) == 0)
12136 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12137 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12142 /* Resolve a procedure. */
12145 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12147 gfc_formal_arglist
*arg
;
12149 if (sym
->attr
.function
12150 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12153 if (sym
->ts
.type
== BT_CHARACTER
)
12155 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12157 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12158 && !resolve_charlen (cl
))
12161 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12162 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12164 gfc_error ("Character-valued statement function %qs at %L must "
12165 "have constant length", sym
->name
, &sym
->declared_at
);
12170 /* Ensure that derived type for are not of a private type. Internal
12171 module procedures are excluded by 2.2.3.3 - i.e., they are not
12172 externally accessible and can access all the objects accessible in
12174 if (!(sym
->ns
->parent
12175 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12176 && gfc_check_symbol_access (sym
))
12178 gfc_interface
*iface
;
12180 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12183 && arg
->sym
->ts
.type
== BT_DERIVED
12184 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12185 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12186 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12187 "and cannot be a dummy argument"
12188 " of %qs, which is PUBLIC at %L",
12189 arg
->sym
->name
, sym
->name
,
12190 &sym
->declared_at
))
12192 /* Stop this message from recurring. */
12193 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12198 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12199 PRIVATE to the containing module. */
12200 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12202 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12205 && arg
->sym
->ts
.type
== BT_DERIVED
12206 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12207 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12208 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12209 "PUBLIC interface %qs at %L "
12210 "takes dummy arguments of %qs which "
12211 "is PRIVATE", iface
->sym
->name
,
12212 sym
->name
, &iface
->sym
->declared_at
,
12213 gfc_typename(&arg
->sym
->ts
)))
12215 /* Stop this message from recurring. */
12216 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12223 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12224 && !sym
->attr
.proc_pointer
)
12226 gfc_error ("Function %qs at %L cannot have an initializer",
12227 sym
->name
, &sym
->declared_at
);
12231 /* An external symbol may not have an initializer because it is taken to be
12232 a procedure. Exception: Procedure Pointers. */
12233 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12235 gfc_error ("External object %qs at %L may not have an initializer",
12236 sym
->name
, &sym
->declared_at
);
12240 /* An elemental function is required to return a scalar 12.7.1 */
12241 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
12243 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12244 "result", sym
->name
, &sym
->declared_at
);
12245 /* Reset so that the error only occurs once. */
12246 sym
->attr
.elemental
= 0;
12250 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12251 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12253 gfc_error ("Statement function %qs at %L may not have pointer or "
12254 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12258 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12259 char-len-param shall not be array-valued, pointer-valued, recursive
12260 or pure. ....snip... A character value of * may only be used in the
12261 following ways: (i) Dummy arg of procedure - dummy associates with
12262 actual length; (ii) To declare a named constant; or (iii) External
12263 function - but length must be declared in calling scoping unit. */
12264 if (sym
->attr
.function
12265 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12266 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12268 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12269 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12271 if (sym
->as
&& sym
->as
->rank
)
12272 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12273 "array-valued", sym
->name
, &sym
->declared_at
);
12275 if (sym
->attr
.pointer
)
12276 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12277 "pointer-valued", sym
->name
, &sym
->declared_at
);
12279 if (sym
->attr
.pure
)
12280 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12281 "pure", sym
->name
, &sym
->declared_at
);
12283 if (sym
->attr
.recursive
)
12284 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12285 "recursive", sym
->name
, &sym
->declared_at
);
12290 /* Appendix B.2 of the standard. Contained functions give an
12291 error anyway. Deferred character length is an F2003 feature.
12292 Don't warn on intrinsic conversion functions, which start
12293 with two underscores. */
12294 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12295 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12296 gfc_notify_std (GFC_STD_F95_OBS
,
12297 "CHARACTER(*) function %qs at %L",
12298 sym
->name
, &sym
->declared_at
);
12301 /* F2008, C1218. */
12302 if (sym
->attr
.elemental
)
12304 if (sym
->attr
.proc_pointer
)
12306 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12307 sym
->name
, &sym
->declared_at
);
12310 if (sym
->attr
.dummy
)
12312 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12313 sym
->name
, &sym
->declared_at
);
12318 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12320 gfc_formal_arglist
*curr_arg
;
12321 int has_non_interop_arg
= 0;
12323 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12324 sym
->common_block
))
12326 /* Clear these to prevent looking at them again if there was an
12328 sym
->attr
.is_bind_c
= 0;
12329 sym
->attr
.is_c_interop
= 0;
12330 sym
->ts
.is_c_interop
= 0;
12334 /* So far, no errors have been found. */
12335 sym
->attr
.is_c_interop
= 1;
12336 sym
->ts
.is_c_interop
= 1;
12339 curr_arg
= gfc_sym_get_dummy_args (sym
);
12340 while (curr_arg
!= NULL
)
12342 /* Skip implicitly typed dummy args here. */
12343 if (curr_arg
->sym
->attr
.implicit_type
== 0)
12344 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12345 /* If something is found to fail, record the fact so we
12346 can mark the symbol for the procedure as not being
12347 BIND(C) to try and prevent multiple errors being
12349 has_non_interop_arg
= 1;
12351 curr_arg
= curr_arg
->next
;
12354 /* See if any of the arguments were not interoperable and if so, clear
12355 the procedure symbol to prevent duplicate error messages. */
12356 if (has_non_interop_arg
!= 0)
12358 sym
->attr
.is_c_interop
= 0;
12359 sym
->ts
.is_c_interop
= 0;
12360 sym
->attr
.is_bind_c
= 0;
12364 if (!sym
->attr
.proc_pointer
)
12366 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12368 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12369 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12372 if (sym
->attr
.intent
)
12374 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12375 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12378 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12380 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12381 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12384 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12385 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12386 || sym
->attr
.contained
))
12388 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12389 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12392 if (strcmp ("ppr@", sym
->name
) == 0)
12394 gfc_error ("Procedure pointer result %qs at %L "
12395 "is missing the pointer attribute",
12396 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12401 /* Assume that a procedure whose body is not known has references
12402 to external arrays. */
12403 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12404 sym
->attr
.array_outer_dependency
= 1;
12406 /* Compare the characteristics of a module procedure with the
12407 interface declaration. Ideally this would be done with
12408 gfc_compare_interfaces but, at present, the formal interface
12409 cannot be copied to the ts.interface. */
12410 if (sym
->attr
.module_procedure
12411 && sym
->attr
.if_source
== IFSRC_DECL
)
12414 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12416 char *submodule_name
;
12417 strcpy (name
, sym
->ns
->proc_name
->name
);
12418 module_name
= strtok (name
, ".");
12419 submodule_name
= strtok (NULL
, ".");
12421 iface
= sym
->tlink
;
12424 /* Make sure that the result uses the correct charlen for deferred
12426 if (iface
&& sym
->result
12427 && iface
->ts
.type
== BT_CHARACTER
12428 && iface
->ts
.deferred
)
12429 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12434 /* Check the procedure characteristics. */
12435 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12437 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12438 "PROCEDURE at %L and its interface in %s",
12439 &sym
->declared_at
, module_name
);
12443 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12445 gfc_error ("Mismatch in PURE attribute between MODULE "
12446 "PROCEDURE at %L and its interface in %s",
12447 &sym
->declared_at
, module_name
);
12451 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12453 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12454 "PROCEDURE at %L and its interface in %s",
12455 &sym
->declared_at
, module_name
);
12459 /* Check the result characteristics. */
12460 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12462 gfc_error ("%s between the MODULE PROCEDURE declaration "
12463 "in MODULE %qs and the declaration at %L in "
12465 errmsg
, module_name
, &sym
->declared_at
,
12466 submodule_name
? submodule_name
: module_name
);
12471 /* Check the characteristics of the formal arguments. */
12472 if (sym
->formal
&& sym
->formal_ns
)
12474 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12477 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12485 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12486 been defined and we now know their defined arguments, check that they fulfill
12487 the requirements of the standard for procedures used as finalizers. */
12490 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12492 gfc_finalizer
* list
;
12493 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12494 bool result
= true;
12495 bool seen_scalar
= false;
12498 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12501 gfc_resolve_finalizers (parent
, finalizable
);
12503 /* Ensure that derived-type components have a their finalizers resolved. */
12504 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12505 for (c
= derived
->components
; c
; c
= c
->next
)
12506 if (c
->ts
.type
== BT_DERIVED
12507 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12509 bool has_final2
= false;
12510 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12511 return false; /* Error. */
12512 has_final
= has_final
|| has_final2
;
12514 /* Return early if not finalizable. */
12518 *finalizable
= false;
12522 /* Walk over the list of finalizer-procedures, check them, and if any one
12523 does not fit in with the standard's definition, print an error and remove
12524 it from the list. */
12525 prev_link
= &derived
->f2k_derived
->finalizers
;
12526 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12528 gfc_formal_arglist
*dummy_args
;
12533 /* Skip this finalizer if we already resolved it. */
12534 if (list
->proc_tree
)
12536 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12537 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
12538 seen_scalar
= true;
12539 prev_link
= &(list
->next
);
12543 /* Check this exists and is a SUBROUTINE. */
12544 if (!list
->proc_sym
->attr
.subroutine
)
12546 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12547 list
->proc_sym
->name
, &list
->where
);
12551 /* We should have exactly one argument. */
12552 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12553 if (!dummy_args
|| dummy_args
->next
)
12555 gfc_error ("FINAL procedure at %L must have exactly one argument",
12559 arg
= dummy_args
->sym
;
12561 /* This argument must be of our type. */
12562 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12564 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12565 &arg
->declared_at
, derived
->name
);
12569 /* It must neither be a pointer nor allocatable nor optional. */
12570 if (arg
->attr
.pointer
)
12572 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12573 &arg
->declared_at
);
12576 if (arg
->attr
.allocatable
)
12578 gfc_error ("Argument of FINAL procedure at %L must not be"
12579 " ALLOCATABLE", &arg
->declared_at
);
12582 if (arg
->attr
.optional
)
12584 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12585 &arg
->declared_at
);
12589 /* It must not be INTENT(OUT). */
12590 if (arg
->attr
.intent
== INTENT_OUT
)
12592 gfc_error ("Argument of FINAL procedure at %L must not be"
12593 " INTENT(OUT)", &arg
->declared_at
);
12597 /* Warn if the procedure is non-scalar and not assumed shape. */
12598 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12599 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12600 gfc_warning (OPT_Wsurprising
,
12601 "Non-scalar FINAL procedure at %L should have assumed"
12602 " shape argument", &arg
->declared_at
);
12604 /* Check that it does not match in kind and rank with a FINAL procedure
12605 defined earlier. To really loop over the *earlier* declarations,
12606 we need to walk the tail of the list as new ones were pushed at the
12608 /* TODO: Handle kind parameters once they are implemented. */
12609 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12610 for (i
= list
->next
; i
; i
= i
->next
)
12612 gfc_formal_arglist
*dummy_args
;
12614 /* Argument list might be empty; that is an error signalled earlier,
12615 but we nevertheless continued resolving. */
12616 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12619 gfc_symbol
* i_arg
= dummy_args
->sym
;
12620 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12621 if (i_rank
== my_rank
)
12623 gfc_error ("FINAL procedure %qs declared at %L has the same"
12624 " rank (%d) as %qs",
12625 list
->proc_sym
->name
, &list
->where
, my_rank
,
12626 i
->proc_sym
->name
);
12632 /* Is this the/a scalar finalizer procedure? */
12634 seen_scalar
= true;
12636 /* Find the symtree for this procedure. */
12637 gcc_assert (!list
->proc_tree
);
12638 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12640 prev_link
= &list
->next
;
12643 /* Remove wrong nodes immediately from the list so we don't risk any
12644 troubles in the future when they might fail later expectations. */
12647 *prev_link
= list
->next
;
12648 gfc_free_finalizer (i
);
12652 if (result
== false)
12655 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12656 were nodes in the list, must have been for arrays. It is surely a good
12657 idea to have a scalar version there if there's something to finalize. */
12658 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
12659 gfc_warning (OPT_Wsurprising
,
12660 "Only array FINAL procedures declared for derived type %qs"
12661 " defined at %L, suggest also scalar one",
12662 derived
->name
, &derived
->declared_at
);
12664 vtab
= gfc_find_derived_vtab (derived
);
12665 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12666 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12669 *finalizable
= true;
12675 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12678 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12679 const char* generic_name
, locus where
)
12681 gfc_symbol
*sym1
, *sym2
;
12682 const char *pass1
, *pass2
;
12683 gfc_formal_arglist
*dummy_args
;
12685 gcc_assert (t1
->specific
&& t2
->specific
);
12686 gcc_assert (!t1
->specific
->is_generic
);
12687 gcc_assert (!t2
->specific
->is_generic
);
12688 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12690 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12691 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12696 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12697 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12698 || sym1
->attr
.function
!= sym2
->attr
.function
)
12700 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12701 " GENERIC %qs at %L",
12702 sym1
->name
, sym2
->name
, generic_name
, &where
);
12706 /* Determine PASS arguments. */
12707 if (t1
->specific
->nopass
)
12709 else if (t1
->specific
->pass_arg
)
12710 pass1
= t1
->specific
->pass_arg
;
12713 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12715 pass1
= dummy_args
->sym
->name
;
12719 if (t2
->specific
->nopass
)
12721 else if (t2
->specific
->pass_arg
)
12722 pass2
= t2
->specific
->pass_arg
;
12725 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12727 pass2
= dummy_args
->sym
->name
;
12732 /* Compare the interfaces. */
12733 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12734 NULL
, 0, pass1
, pass2
))
12736 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12737 sym1
->name
, sym2
->name
, generic_name
, &where
);
12745 /* Worker function for resolving a generic procedure binding; this is used to
12746 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12748 The difference between those cases is finding possible inherited bindings
12749 that are overridden, as one has to look for them in tb_sym_root,
12750 tb_uop_root or tb_op, respectively. Thus the caller must already find
12751 the super-type and set p->overridden correctly. */
12754 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12755 gfc_typebound_proc
* p
, const char* name
)
12757 gfc_tbp_generic
* target
;
12758 gfc_symtree
* first_target
;
12759 gfc_symtree
* inherited
;
12761 gcc_assert (p
&& p
->is_generic
);
12763 /* Try to find the specific bindings for the symtrees in our target-list. */
12764 gcc_assert (p
->u
.generic
);
12765 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12766 if (!target
->specific
)
12768 gfc_typebound_proc
* overridden_tbp
;
12769 gfc_tbp_generic
* g
;
12770 const char* target_name
;
12772 target_name
= target
->specific_st
->name
;
12774 /* Defined for this type directly. */
12775 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12777 target
->specific
= target
->specific_st
->n
.tb
;
12778 goto specific_found
;
12781 /* Look for an inherited specific binding. */
12784 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12789 gcc_assert (inherited
->n
.tb
);
12790 target
->specific
= inherited
->n
.tb
;
12791 goto specific_found
;
12795 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12796 " at %L", target_name
, name
, &p
->where
);
12799 /* Once we've found the specific binding, check it is not ambiguous with
12800 other specifics already found or inherited for the same GENERIC. */
12802 gcc_assert (target
->specific
);
12804 /* This must really be a specific binding! */
12805 if (target
->specific
->is_generic
)
12807 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12808 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12812 /* Check those already resolved on this type directly. */
12813 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12814 if (g
!= target
&& g
->specific
12815 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12818 /* Check for ambiguity with inherited specific targets. */
12819 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12820 overridden_tbp
= overridden_tbp
->overridden
)
12821 if (overridden_tbp
->is_generic
)
12823 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12825 gcc_assert (g
->specific
);
12826 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12832 /* If we attempt to "overwrite" a specific binding, this is an error. */
12833 if (p
->overridden
&& !p
->overridden
->is_generic
)
12835 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12836 " the same name", name
, &p
->where
);
12840 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12841 all must have the same attributes here. */
12842 first_target
= p
->u
.generic
->specific
->u
.specific
;
12843 gcc_assert (first_target
);
12844 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12845 p
->function
= first_target
->n
.sym
->attr
.function
;
12851 /* Resolve a GENERIC procedure binding for a derived type. */
12854 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12856 gfc_symbol
* super_type
;
12858 /* Find the overridden binding if any. */
12859 st
->n
.tb
->overridden
= NULL
;
12860 super_type
= gfc_get_derived_super_type (derived
);
12863 gfc_symtree
* overridden
;
12864 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12867 if (overridden
&& overridden
->n
.tb
)
12868 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12871 /* Resolve using worker function. */
12872 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12876 /* Retrieve the target-procedure of an operator binding and do some checks in
12877 common for intrinsic and user-defined type-bound operators. */
12880 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12882 gfc_symbol
* target_proc
;
12884 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12885 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12886 gcc_assert (target_proc
);
12888 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12889 if (target
->specific
->nopass
)
12891 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12895 return target_proc
;
12899 /* Resolve a type-bound intrinsic operator. */
12902 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12903 gfc_typebound_proc
* p
)
12905 gfc_symbol
* super_type
;
12906 gfc_tbp_generic
* target
;
12908 /* If there's already an error here, do nothing (but don't fail again). */
12912 /* Operators should always be GENERIC bindings. */
12913 gcc_assert (p
->is_generic
);
12915 /* Look for an overridden binding. */
12916 super_type
= gfc_get_derived_super_type (derived
);
12917 if (super_type
&& super_type
->f2k_derived
)
12918 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12921 p
->overridden
= NULL
;
12923 /* Resolve general GENERIC properties using worker function. */
12924 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
12927 /* Check the targets to be procedures of correct interface. */
12928 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12930 gfc_symbol
* target_proc
;
12932 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12936 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12939 /* Add target to non-typebound operator list. */
12940 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12941 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12943 gfc_interface
*head
, *intr
;
12945 /* Preempt 'gfc_check_new_interface' for submodules, where the
12946 mechanism for handling module procedures winds up resolving
12947 operator interfaces twice and would otherwise cause an error. */
12948 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
12949 if (intr
->sym
== target_proc
12950 && target_proc
->attr
.used_in_submodule
)
12953 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
12954 target_proc
, p
->where
))
12956 head
= derived
->ns
->op
[op
];
12957 intr
= gfc_get_interface ();
12958 intr
->sym
= target_proc
;
12959 intr
->where
= p
->where
;
12961 derived
->ns
->op
[op
] = intr
;
12973 /* Resolve a type-bound user operator (tree-walker callback). */
12975 static gfc_symbol
* resolve_bindings_derived
;
12976 static bool resolve_bindings_result
;
12978 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12981 resolve_typebound_user_op (gfc_symtree
* stree
)
12983 gfc_symbol
* super_type
;
12984 gfc_tbp_generic
* target
;
12986 gcc_assert (stree
&& stree
->n
.tb
);
12988 if (stree
->n
.tb
->error
)
12991 /* Operators should always be GENERIC bindings. */
12992 gcc_assert (stree
->n
.tb
->is_generic
);
12994 /* Find overridden procedure, if any. */
12995 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12996 if (super_type
&& super_type
->f2k_derived
)
12998 gfc_symtree
* overridden
;
12999 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13000 stree
->name
, true, NULL
);
13002 if (overridden
&& overridden
->n
.tb
)
13003 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13006 stree
->n
.tb
->overridden
= NULL
;
13008 /* Resolve basically using worker function. */
13009 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13012 /* Check the targets to be functions of correct interface. */
13013 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13015 gfc_symbol
* target_proc
;
13017 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13021 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13028 resolve_bindings_result
= false;
13029 stree
->n
.tb
->error
= 1;
13033 /* Resolve the type-bound procedures for a derived type. */
13036 resolve_typebound_procedure (gfc_symtree
* stree
)
13040 gfc_symbol
* me_arg
;
13041 gfc_symbol
* super_type
;
13042 gfc_component
* comp
;
13044 gcc_assert (stree
);
13046 /* Undefined specific symbol from GENERIC target definition. */
13050 if (stree
->n
.tb
->error
)
13053 /* If this is a GENERIC binding, use that routine. */
13054 if (stree
->n
.tb
->is_generic
)
13056 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13061 /* Get the target-procedure to check it. */
13062 gcc_assert (!stree
->n
.tb
->is_generic
);
13063 gcc_assert (stree
->n
.tb
->u
.specific
);
13064 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13065 where
= stree
->n
.tb
->where
;
13067 /* Default access should already be resolved from the parser. */
13068 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13070 if (stree
->n
.tb
->deferred
)
13072 if (!check_proc_interface (proc
, &where
))
13077 /* Check for F08:C465. */
13078 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13079 || (proc
->attr
.proc
!= PROC_MODULE
13080 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13081 || proc
->attr
.abstract
)
13083 gfc_error ("%qs must be a module procedure or an external procedure with"
13084 " an explicit interface at %L", proc
->name
, &where
);
13089 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13090 stree
->n
.tb
->function
= proc
->attr
.function
;
13092 /* Find the super-type of the current derived type. We could do this once and
13093 store in a global if speed is needed, but as long as not I believe this is
13094 more readable and clearer. */
13095 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13097 /* If PASS, resolve and check arguments if not already resolved / loaded
13098 from a .mod file. */
13099 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13101 gfc_formal_arglist
*dummy_args
;
13103 dummy_args
= gfc_sym_get_dummy_args (proc
);
13104 if (stree
->n
.tb
->pass_arg
)
13106 gfc_formal_arglist
*i
;
13108 /* If an explicit passing argument name is given, walk the arg-list
13109 and look for it. */
13112 stree
->n
.tb
->pass_arg_num
= 1;
13113 for (i
= dummy_args
; i
; i
= i
->next
)
13115 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13120 ++stree
->n
.tb
->pass_arg_num
;
13125 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13127 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13128 stree
->n
.tb
->pass_arg
);
13134 /* Otherwise, take the first one; there should in fact be at least
13136 stree
->n
.tb
->pass_arg_num
= 1;
13139 gfc_error ("Procedure %qs with PASS at %L must have at"
13140 " least one argument", proc
->name
, &where
);
13143 me_arg
= dummy_args
->sym
;
13146 /* Now check that the argument-type matches and the passed-object
13147 dummy argument is generally fine. */
13149 gcc_assert (me_arg
);
13151 if (me_arg
->ts
.type
!= BT_CLASS
)
13153 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13154 " at %L", proc
->name
, &where
);
13158 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13159 != resolve_bindings_derived
)
13161 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13162 " the derived-type %qs", me_arg
->name
, proc
->name
,
13163 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13167 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13168 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13170 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13171 " scalar", proc
->name
, &where
);
13174 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13176 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13177 " be ALLOCATABLE", proc
->name
, &where
);
13180 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13182 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13183 " be POINTER", proc
->name
, &where
);
13188 /* If we are extending some type, check that we don't override a procedure
13189 flagged NON_OVERRIDABLE. */
13190 stree
->n
.tb
->overridden
= NULL
;
13193 gfc_symtree
* overridden
;
13194 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13195 stree
->name
, true, NULL
);
13199 if (overridden
->n
.tb
)
13200 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13202 if (!gfc_check_typebound_override (stree
, overridden
))
13207 /* See if there's a name collision with a component directly in this type. */
13208 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13209 if (!strcmp (comp
->name
, stree
->name
))
13211 gfc_error ("Procedure %qs at %L has the same name as a component of"
13213 stree
->name
, &where
, resolve_bindings_derived
->name
);
13217 /* Try to find a name collision with an inherited component. */
13218 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13221 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13222 " component of %qs",
13223 stree
->name
, &where
, resolve_bindings_derived
->name
);
13227 stree
->n
.tb
->error
= 0;
13231 resolve_bindings_result
= false;
13232 stree
->n
.tb
->error
= 1;
13237 resolve_typebound_procedures (gfc_symbol
* derived
)
13240 gfc_symbol
* super_type
;
13242 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13245 super_type
= gfc_get_derived_super_type (derived
);
13247 resolve_symbol (super_type
);
13249 resolve_bindings_derived
= derived
;
13250 resolve_bindings_result
= true;
13252 if (derived
->f2k_derived
->tb_sym_root
)
13253 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13254 &resolve_typebound_procedure
);
13256 if (derived
->f2k_derived
->tb_uop_root
)
13257 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13258 &resolve_typebound_user_op
);
13260 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13262 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13263 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13264 (gfc_intrinsic_op
)op
, p
))
13265 resolve_bindings_result
= false;
13268 return resolve_bindings_result
;
13272 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13273 to give all identical derived types the same backend_decl. */
13275 add_dt_to_dt_list (gfc_symbol
*derived
)
13277 gfc_dt_list
*dt_list
;
13279 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
13280 if (derived
== dt_list
->derived
)
13283 dt_list
= gfc_get_dt_list ();
13284 dt_list
->next
= gfc_derived_types
;
13285 dt_list
->derived
= derived
;
13286 gfc_derived_types
= dt_list
;
13290 /* Ensure that a derived-type is really not abstract, meaning that every
13291 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13294 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13299 if (!ensure_not_abstract_walker (sub
, st
->left
))
13301 if (!ensure_not_abstract_walker (sub
, st
->right
))
13304 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13306 gfc_symtree
* overriding
;
13307 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13310 gcc_assert (overriding
->n
.tb
);
13311 if (overriding
->n
.tb
->deferred
)
13313 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13314 " %qs is DEFERRED and not overridden",
13315 sub
->name
, &sub
->declared_at
, st
->name
);
13324 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13326 /* The algorithm used here is to recursively travel up the ancestry of sub
13327 and for each ancestor-type, check all bindings. If any of them is
13328 DEFERRED, look it up starting from sub and see if the found (overriding)
13329 binding is not DEFERRED.
13330 This is not the most efficient way to do this, but it should be ok and is
13331 clearer than something sophisticated. */
13333 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13335 if (!ancestor
->attr
.abstract
)
13338 /* Walk bindings of this ancestor. */
13339 if (ancestor
->f2k_derived
)
13342 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13347 /* Find next ancestor type and recurse on it. */
13348 ancestor
= gfc_get_derived_super_type (ancestor
);
13350 return ensure_not_abstract (sub
, ancestor
);
13356 /* This check for typebound defined assignments is done recursively
13357 since the order in which derived types are resolved is not always in
13358 order of the declarations. */
13361 check_defined_assignments (gfc_symbol
*derived
)
13365 for (c
= derived
->components
; c
; c
= c
->next
)
13367 if (!gfc_bt_struct (c
->ts
.type
)
13369 || c
->attr
.allocatable
13370 || c
->attr
.proc_pointer_comp
13371 || c
->attr
.class_pointer
13372 || c
->attr
.proc_pointer
)
13375 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13376 || (c
->ts
.u
.derived
->f2k_derived
13377 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13379 derived
->attr
.defined_assign_comp
= 1;
13383 check_defined_assignments (c
->ts
.u
.derived
);
13384 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13386 derived
->attr
.defined_assign_comp
= 1;
13393 /* Resolve a single component of a derived type or structure. */
13396 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13398 gfc_symbol
*super_type
;
13400 if (c
->attr
.artificial
)
13404 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13405 && c
->attr
.codimension
13406 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13408 gfc_error ("Coarray component %qs at %L must be allocatable with "
13409 "deferred shape", c
->name
, &c
->loc
);
13414 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13415 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13417 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13418 "shall not be a coarray", c
->name
, &c
->loc
);
13423 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13424 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13425 || c
->attr
.allocatable
))
13427 gfc_error ("Component %qs at %L with coarray component "
13428 "shall be a nonpointer, nonallocatable scalar",
13434 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13436 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13437 "is not an array pointer", c
->name
, &c
->loc
);
13441 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13443 gfc_symbol
*ifc
= c
->ts
.interface
;
13445 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13451 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13453 /* Resolve interface and copy attributes. */
13454 if (ifc
->formal
&& !ifc
->formal_ns
)
13455 resolve_symbol (ifc
);
13456 if (ifc
->attr
.intrinsic
)
13457 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13461 c
->ts
= ifc
->result
->ts
;
13462 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13463 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13464 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13465 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13466 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13471 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13472 c
->attr
.pointer
= ifc
->attr
.pointer
;
13473 c
->attr
.dimension
= ifc
->attr
.dimension
;
13474 c
->as
= gfc_copy_array_spec (ifc
->as
);
13475 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13477 c
->ts
.interface
= ifc
;
13478 c
->attr
.function
= ifc
->attr
.function
;
13479 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13481 c
->attr
.pure
= ifc
->attr
.pure
;
13482 c
->attr
.elemental
= ifc
->attr
.elemental
;
13483 c
->attr
.recursive
= ifc
->attr
.recursive
;
13484 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13485 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13486 /* Copy char length. */
13487 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13489 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13490 if (cl
->length
&& !cl
->resolved
13491 && !gfc_resolve_expr (cl
->length
))
13500 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13502 /* Since PPCs are not implicitly typed, a PPC without an explicit
13503 interface must be a subroutine. */
13504 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13507 /* Procedure pointer components: Check PASS arg. */
13508 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13509 && !sym
->attr
.vtype
)
13511 gfc_symbol
* me_arg
;
13513 if (c
->tb
->pass_arg
)
13515 gfc_formal_arglist
* i
;
13517 /* If an explicit passing argument name is given, walk the arg-list
13518 and look for it. */
13521 c
->tb
->pass_arg_num
= 1;
13522 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13524 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13529 c
->tb
->pass_arg_num
++;
13534 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13535 "at %L has no argument %qs", c
->name
,
13536 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13543 /* Otherwise, take the first one; there should in fact be at least
13545 c
->tb
->pass_arg_num
= 1;
13546 if (!c
->ts
.interface
->formal
)
13548 gfc_error ("Procedure pointer component %qs with PASS at %L "
13549 "must have at least one argument",
13554 me_arg
= c
->ts
.interface
->formal
->sym
;
13557 /* Now check that the argument-type matches. */
13558 gcc_assert (me_arg
);
13559 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13560 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13561 || (me_arg
->ts
.type
== BT_CLASS
13562 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13564 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13565 " the derived type %qs", me_arg
->name
, c
->name
,
13566 me_arg
->name
, &c
->loc
, sym
->name
);
13571 /* Check for C453. */
13572 if (me_arg
->attr
.dimension
)
13574 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13575 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13581 if (me_arg
->attr
.pointer
)
13583 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13584 "may not have the POINTER attribute", me_arg
->name
,
13585 c
->name
, me_arg
->name
, &c
->loc
);
13590 if (me_arg
->attr
.allocatable
)
13592 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13593 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13594 me_arg
->name
, &c
->loc
);
13599 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13601 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13602 " at %L", c
->name
, &c
->loc
);
13608 /* Check type-spec if this is not the parent-type component. */
13609 if (((sym
->attr
.is_class
13610 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13611 || c
!= sym
->components
->ts
.u
.derived
->components
))
13612 || (!sym
->attr
.is_class
13613 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13614 && !sym
->attr
.vtype
13615 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13618 super_type
= gfc_get_derived_super_type (sym
);
13620 /* If this type is an extension, set the accessibility of the parent
13623 && ((sym
->attr
.is_class
13624 && c
== sym
->components
->ts
.u
.derived
->components
)
13625 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13626 && strcmp (super_type
->name
, c
->name
) == 0)
13627 c
->attr
.access
= super_type
->attr
.access
;
13629 /* If this type is an extension, see if this component has the same name
13630 as an inherited type-bound procedure. */
13631 if (super_type
&& !sym
->attr
.is_class
13632 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13634 gfc_error ("Component %qs of %qs at %L has the same name as an"
13635 " inherited type-bound procedure",
13636 c
->name
, sym
->name
, &c
->loc
);
13640 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13641 && !c
->ts
.deferred
)
13643 if (c
->ts
.u
.cl
->length
== NULL
13644 || (!resolve_charlen(c
->ts
.u
.cl
))
13645 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13647 gfc_error ("Character length of component %qs needs to "
13648 "be a constant specification expression at %L",
13650 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13655 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13656 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13658 gfc_error ("Character component %qs of %qs at %L with deferred "
13659 "length must be a POINTER or ALLOCATABLE",
13660 c
->name
, sym
->name
, &c
->loc
);
13664 /* Add the hidden deferred length field. */
13665 if (c
->ts
.type
== BT_CHARACTER
13666 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
13667 && !c
->attr
.function
13668 && !sym
->attr
.is_class
)
13670 char name
[GFC_MAX_SYMBOL_LEN
+9];
13671 gfc_component
*strlen
;
13672 sprintf (name
, "_%s_length", c
->name
);
13673 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
13674 if (strlen
== NULL
)
13676 if (!gfc_add_component (sym
, name
, &strlen
))
13678 strlen
->ts
.type
= BT_INTEGER
;
13679 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13680 strlen
->attr
.access
= ACCESS_PRIVATE
;
13681 strlen
->attr
.artificial
= 1;
13685 if (c
->ts
.type
== BT_DERIVED
13686 && sym
->component_access
!= ACCESS_PRIVATE
13687 && gfc_check_symbol_access (sym
)
13688 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13689 && !c
->ts
.u
.derived
->attr
.use_assoc
13690 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13691 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13692 "PRIVATE type and cannot be a component of "
13693 "%qs, which is PUBLIC at %L", c
->name
,
13694 sym
->name
, &sym
->declared_at
))
13697 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13699 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13700 "type %s", c
->name
, &c
->loc
, sym
->name
);
13704 if (sym
->attr
.sequence
)
13706 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13708 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13709 "not have the SEQUENCE attribute",
13710 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13715 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13716 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13717 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13718 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13719 CLASS_DATA (c
)->ts
.u
.derived
13720 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13722 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13723 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13724 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13726 gfc_error ("The pointer component %qs of %qs at %L is a type "
13727 "that has not been declared", c
->name
, sym
->name
,
13732 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13733 && CLASS_DATA (c
)->attr
.class_pointer
13734 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13735 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13736 && !UNLIMITED_POLY (c
))
13738 gfc_error ("The pointer component %qs of %qs at %L is a type "
13739 "that has not been declared", c
->name
, sym
->name
,
13744 /* If an allocatable component derived type is of the same type as
13745 the enclosing derived type, we need a vtable generating so that
13746 the __deallocate procedure is created. */
13747 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
13748 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
13749 gfc_find_vtab (&c
->ts
);
13751 /* Ensure that all the derived type components are put on the
13752 derived type list; even in formal namespaces, where derived type
13753 pointer components might not have been declared. */
13754 if (c
->ts
.type
== BT_DERIVED
13756 && c
->ts
.u
.derived
->components
13758 && sym
!= c
->ts
.u
.derived
)
13759 add_dt_to_dt_list (c
->ts
.u
.derived
);
13761 if (!gfc_resolve_array_spec (c
->as
,
13762 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13763 || c
->attr
.allocatable
)))
13766 if (c
->initializer
&& !sym
->attr
.vtype
13767 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
13768 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13775 /* Be nice about the locus for a structure expression - show the locus of the
13776 first non-null sub-expression if we can. */
13779 cons_where (gfc_expr
*struct_expr
)
13781 gfc_constructor
*cons
;
13783 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
13785 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
13786 for (; cons
; cons
= gfc_constructor_next (cons
))
13788 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
13789 return &cons
->expr
->where
;
13792 return &struct_expr
->where
;
13795 /* Resolve the components of a structure type. Much less work than derived
13799 resolve_fl_struct (gfc_symbol
*sym
)
13802 gfc_expr
*init
= NULL
;
13805 /* Make sure UNIONs do not have overlapping initializers. */
13806 if (sym
->attr
.flavor
== FL_UNION
)
13808 for (c
= sym
->components
; c
; c
= c
->next
)
13810 if (init
&& c
->initializer
)
13812 gfc_error ("Conflicting initializers in union at %L and %L",
13813 cons_where (init
), cons_where (c
->initializer
));
13814 gfc_free_expr (c
->initializer
);
13815 c
->initializer
= NULL
;
13818 init
= c
->initializer
;
13823 for (c
= sym
->components
; c
; c
= c
->next
)
13824 if (!resolve_component (c
, sym
))
13830 if (sym
->components
)
13831 add_dt_to_dt_list (sym
);
13837 /* Resolve the components of a derived type. This does not have to wait until
13838 resolution stage, but can be done as soon as the dt declaration has been
13842 resolve_fl_derived0 (gfc_symbol
*sym
)
13844 gfc_symbol
* super_type
;
13848 if (sym
->attr
.unlimited_polymorphic
)
13851 super_type
= gfc_get_derived_super_type (sym
);
13854 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
13856 gfc_error ("As extending type %qs at %L has a coarray component, "
13857 "parent type %qs shall also have one", sym
->name
,
13858 &sym
->declared_at
, super_type
->name
);
13862 /* Ensure the extended type gets resolved before we do. */
13863 if (super_type
&& !resolve_fl_derived0 (super_type
))
13866 /* An ABSTRACT type must be extensible. */
13867 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
13869 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
13870 sym
->name
, &sym
->declared_at
);
13874 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
13878 for ( ; c
!= NULL
; c
= c
->next
)
13879 if (!resolve_component (c
, sym
))
13885 check_defined_assignments (sym
);
13887 if (!sym
->attr
.defined_assign_comp
&& super_type
)
13888 sym
->attr
.defined_assign_comp
13889 = super_type
->attr
.defined_assign_comp
;
13891 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13892 all DEFERRED bindings are overridden. */
13893 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
13894 && !sym
->attr
.is_class
13895 && !ensure_not_abstract (sym
, super_type
))
13898 /* Add derived type to the derived type list. */
13899 add_dt_to_dt_list (sym
);
13905 /* The following procedure does the full resolution of a derived type,
13906 including resolution of all type-bound procedures (if present). In contrast
13907 to 'resolve_fl_derived0' this can only be done after the module has been
13908 parsed completely. */
13911 resolve_fl_derived (gfc_symbol
*sym
)
13913 gfc_symbol
*gen_dt
= NULL
;
13915 if (sym
->attr
.unlimited_polymorphic
)
13918 if (!sym
->attr
.is_class
)
13919 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
13920 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
13921 && (!gen_dt
->generic
->sym
->attr
.use_assoc
13922 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
13923 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
13924 "%qs at %L being the same name as derived "
13925 "type at %L", sym
->name
,
13926 gen_dt
->generic
->sym
== sym
13927 ? gen_dt
->generic
->next
->sym
->name
13928 : gen_dt
->generic
->sym
->name
,
13929 gen_dt
->generic
->sym
== sym
13930 ? &gen_dt
->generic
->next
->sym
->declared_at
13931 : &gen_dt
->generic
->sym
->declared_at
,
13932 &sym
->declared_at
))
13935 /* Resolve the finalizer procedures. */
13936 if (!gfc_resolve_finalizers (sym
, NULL
))
13939 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
13941 /* Fix up incomplete CLASS symbols. */
13942 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
13943 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
13945 /* Nothing more to do for unlimited polymorphic entities. */
13946 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
13948 else if (vptr
->ts
.u
.derived
== NULL
)
13950 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
13952 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
13953 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
13958 if (!resolve_fl_derived0 (sym
))
13961 /* Resolve the type-bound procedures. */
13962 if (!resolve_typebound_procedures (sym
))
13970 resolve_fl_namelist (gfc_symbol
*sym
)
13975 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13977 /* Check again, the check in match only works if NAMELIST comes
13979 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
13981 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13982 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13986 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
13987 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13988 "with assumed shape in namelist %qs at %L",
13989 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13992 if (is_non_constant_shape_array (nl
->sym
)
13993 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13994 "with nonconstant shape in namelist %qs at %L",
13995 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13998 if (nl
->sym
->ts
.type
== BT_CHARACTER
13999 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14000 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14001 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14002 "nonconstant character length in "
14003 "namelist %qs at %L", nl
->sym
->name
,
14004 sym
->name
, &sym
->declared_at
))
14009 /* Reject PRIVATE objects in a PUBLIC namelist. */
14010 if (gfc_check_symbol_access (sym
))
14012 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14014 if (!nl
->sym
->attr
.use_assoc
14015 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14016 && !gfc_check_symbol_access (nl
->sym
))
14018 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14019 "cannot be member of PUBLIC namelist %qs at %L",
14020 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14024 if (nl
->sym
->ts
.type
== BT_DERIVED
14025 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14026 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14028 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14029 "namelist %qs at %L with ALLOCATABLE "
14030 "or POINTER components", nl
->sym
->name
,
14031 sym
->name
, &sym
->declared_at
))
14036 /* Types with private components that came here by USE-association. */
14037 if (nl
->sym
->ts
.type
== BT_DERIVED
14038 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14040 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14041 "components and cannot be member of namelist %qs at %L",
14042 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14046 /* Types with private components that are defined in the same module. */
14047 if (nl
->sym
->ts
.type
== BT_DERIVED
14048 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14049 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14051 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14052 "cannot be a member of PUBLIC namelist %qs at %L",
14053 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14060 /* 14.1.2 A module or internal procedure represent local entities
14061 of the same type as a namelist member and so are not allowed. */
14062 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14064 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14067 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14068 if ((nl
->sym
== sym
->ns
->proc_name
)
14070 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14075 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14076 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14078 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14079 "attribute in %qs at %L", nlsym
->name
,
14080 &sym
->declared_at
);
14090 resolve_fl_parameter (gfc_symbol
*sym
)
14092 /* A parameter array's shape needs to be constant. */
14093 if (sym
->as
!= NULL
14094 && (sym
->as
->type
== AS_DEFERRED
14095 || is_non_constant_shape_array (sym
)))
14097 gfc_error ("Parameter array %qs at %L cannot be automatic "
14098 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14102 /* Constraints on deferred type parameter. */
14103 if (!deferred_requirements (sym
))
14106 /* Make sure a parameter that has been implicitly typed still
14107 matches the implicit type, since PARAMETER statements can precede
14108 IMPLICIT statements. */
14109 if (sym
->attr
.implicit_type
14110 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14113 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14114 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14118 /* Make sure the types of derived parameters are consistent. This
14119 type checking is deferred until resolution because the type may
14120 refer to a derived type from the host. */
14121 if (sym
->ts
.type
== BT_DERIVED
14122 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14124 gfc_error ("Incompatible derived type in PARAMETER at %L",
14125 &sym
->value
->where
);
14129 /* F03:C509,C514. */
14130 if (sym
->ts
.type
== BT_CLASS
)
14132 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14133 sym
->name
, &sym
->declared_at
);
14141 /* Called by resolve_symbol to chack PDTs. */
14144 resolve_pdt (gfc_symbol
* sym
)
14146 gfc_symbol
*derived
= NULL
;
14147 gfc_actual_arglist
*param
;
14149 bool const_len_exprs
= true;
14150 bool assumed_len_exprs
= false;
14152 if (sym
->ts
.type
== BT_DERIVED
)
14153 derived
= sym
->ts
.u
.derived
;
14154 else if (sym
->ts
.type
== BT_CLASS
)
14155 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14157 gcc_unreachable ();
14159 gcc_assert (derived
->attr
.pdt_type
);
14161 for (param
= sym
->param_list
; param
; param
= param
->next
)
14163 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14165 if (c
->attr
.pdt_kind
)
14168 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14169 && c
->attr
.pdt_len
)
14170 const_len_exprs
= false;
14171 else if (param
->spec_type
== SPEC_ASSUMED
)
14172 assumed_len_exprs
= true;
14175 if (!const_len_exprs
14176 && (sym
->ns
->proc_name
->attr
.is_main_program
14177 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14178 || sym
->attr
.save
!= SAVE_NONE
))
14179 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14180 "SAVE attribute or be a variable declared in the "
14181 "main program, a module or a submodule(F08/C513)",
14182 sym
->name
, &sym
->declared_at
);
14184 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14185 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14186 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14187 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14188 sym
->name
, &sym
->declared_at
);
14192 /* Do anything necessary to resolve a symbol. Right now, we just
14193 assume that an otherwise unknown symbol is a variable. This sort
14194 of thing commonly happens for symbols in module. */
14197 resolve_symbol (gfc_symbol
*sym
)
14199 int check_constant
, mp_flag
;
14200 gfc_symtree
*symtree
;
14201 gfc_symtree
*this_symtree
;
14204 symbol_attribute class_attr
;
14205 gfc_array_spec
*as
;
14206 bool saved_specification_expr
;
14212 /* No symbol will ever have union type; only components can be unions.
14213 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14214 (just like derived type declaration symbols have flavor FL_DERIVED). */
14215 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14217 /* Coarrayed polymorphic objects with allocatable or pointer components are
14218 yet unsupported for -fcoarray=lib. */
14219 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14220 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14221 && CLASS_DATA (sym
)->attr
.codimension
14222 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14223 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14225 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14226 "type coarrays at %L are unsupported", &sym
->declared_at
);
14230 if (sym
->attr
.artificial
)
14233 if (sym
->attr
.unlimited_polymorphic
)
14236 if (sym
->attr
.flavor
== FL_UNKNOWN
14237 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14238 && !sym
->attr
.generic
&& !sym
->attr
.external
14239 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14240 && sym
->ts
.type
== BT_UNKNOWN
))
14243 /* If we find that a flavorless symbol is an interface in one of the
14244 parent namespaces, find its symtree in this namespace, free the
14245 symbol and set the symtree to point to the interface symbol. */
14246 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14248 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14249 if (symtree
&& (symtree
->n
.sym
->generic
||
14250 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14251 && sym
->ns
->construct_entities
)))
14253 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14255 if (this_symtree
->n
.sym
== sym
)
14257 symtree
->n
.sym
->refs
++;
14258 gfc_release_symbol (sym
);
14259 this_symtree
->n
.sym
= symtree
->n
.sym
;
14265 /* Otherwise give it a flavor according to such attributes as
14267 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14268 && sym
->attr
.intrinsic
== 0)
14269 sym
->attr
.flavor
= FL_VARIABLE
;
14270 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14272 sym
->attr
.flavor
= FL_PROCEDURE
;
14273 if (sym
->attr
.dimension
)
14274 sym
->attr
.function
= 1;
14278 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14279 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14281 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14282 && !resolve_procedure_interface (sym
))
14285 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14286 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14288 if (sym
->attr
.external
)
14289 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14290 "at %L", &sym
->declared_at
);
14292 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14293 "at %L", &sym
->declared_at
);
14298 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14301 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14302 && !resolve_fl_struct (sym
))
14305 /* Symbols that are module procedures with results (functions) have
14306 the types and array specification copied for type checking in
14307 procedures that call them, as well as for saving to a module
14308 file. These symbols can't stand the scrutiny that their results
14310 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14312 /* Make sure that the intrinsic is consistent with its internal
14313 representation. This needs to be done before assigning a default
14314 type to avoid spurious warnings. */
14315 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14316 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14319 /* Resolve associate names. */
14321 resolve_assoc_var (sym
, true);
14323 /* Assign default type to symbols that need one and don't have one. */
14324 if (sym
->ts
.type
== BT_UNKNOWN
)
14326 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14328 gfc_set_default_type (sym
, 1, NULL
);
14331 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14332 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14333 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14334 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14336 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14338 /* The specific case of an external procedure should emit an error
14339 in the case that there is no implicit type. */
14342 if (!sym
->attr
.mixed_entry_master
)
14343 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14347 /* Result may be in another namespace. */
14348 resolve_symbol (sym
->result
);
14350 if (!sym
->result
->attr
.proc_pointer
)
14352 sym
->ts
= sym
->result
->ts
;
14353 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14354 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14355 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14356 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14357 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14362 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14364 bool saved_specification_expr
= specification_expr
;
14365 specification_expr
= true;
14366 gfc_resolve_array_spec (sym
->result
->as
, false);
14367 specification_expr
= saved_specification_expr
;
14370 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14372 as
= CLASS_DATA (sym
)->as
;
14373 class_attr
= CLASS_DATA (sym
)->attr
;
14374 class_attr
.pointer
= class_attr
.class_pointer
;
14378 class_attr
= sym
->attr
;
14383 if (sym
->attr
.contiguous
14384 && (!class_attr
.dimension
14385 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14386 && !class_attr
.pointer
)))
14388 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14389 "array pointer or an assumed-shape or assumed-rank array",
14390 sym
->name
, &sym
->declared_at
);
14394 /* Assumed size arrays and assumed shape arrays must be dummy
14395 arguments. Array-spec's of implied-shape should have been resolved to
14396 AS_EXPLICIT already. */
14400 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
14401 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14402 || as
->type
== AS_ASSUMED_SHAPE
)
14403 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14405 if (as
->type
== AS_ASSUMED_SIZE
)
14406 gfc_error ("Assumed size array at %L must be a dummy argument",
14407 &sym
->declared_at
);
14409 gfc_error ("Assumed shape array at %L must be a dummy argument",
14410 &sym
->declared_at
);
14413 /* TS 29113, C535a. */
14414 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14415 && !sym
->attr
.select_type_temporary
)
14417 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14418 &sym
->declared_at
);
14421 if (as
->type
== AS_ASSUMED_RANK
14422 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14424 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14425 "CODIMENSION attribute", &sym
->declared_at
);
14430 /* Make sure symbols with known intent or optional are really dummy
14431 variable. Because of ENTRY statement, this has to be deferred
14432 until resolution time. */
14434 if (!sym
->attr
.dummy
14435 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14437 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14441 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14443 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14444 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14448 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14450 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14451 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14453 gfc_error ("Character dummy variable %qs at %L with VALUE "
14454 "attribute must have constant length",
14455 sym
->name
, &sym
->declared_at
);
14459 if (sym
->ts
.is_c_interop
14460 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14462 gfc_error ("C interoperable character dummy variable %qs at %L "
14463 "with VALUE attribute must have length one",
14464 sym
->name
, &sym
->declared_at
);
14469 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14470 && sym
->ts
.u
.derived
->attr
.generic
)
14472 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14473 if (!sym
->ts
.u
.derived
)
14475 gfc_error ("The derived type %qs at %L is of type %qs, "
14476 "which has not been defined", sym
->name
,
14477 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14478 sym
->ts
.type
= BT_UNKNOWN
;
14483 /* Use the same constraints as TYPE(*), except for the type check
14484 and that only scalars and assumed-size arrays are permitted. */
14485 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14487 if (!sym
->attr
.dummy
)
14489 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14490 "a dummy argument", sym
->name
, &sym
->declared_at
);
14494 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14495 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14496 && sym
->ts
.type
!= BT_COMPLEX
)
14498 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14499 "of type TYPE(*) or of an numeric intrinsic type",
14500 sym
->name
, &sym
->declared_at
);
14504 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14505 || sym
->attr
.pointer
|| sym
->attr
.value
)
14507 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14508 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14509 "attribute", sym
->name
, &sym
->declared_at
);
14513 if (sym
->attr
.intent
== INTENT_OUT
)
14515 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14516 "have the INTENT(OUT) attribute",
14517 sym
->name
, &sym
->declared_at
);
14520 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14522 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14523 "either be a scalar or an assumed-size array",
14524 sym
->name
, &sym
->declared_at
);
14528 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14529 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14531 sym
->ts
.type
= BT_ASSUMED
;
14532 sym
->as
= gfc_get_array_spec ();
14533 sym
->as
->type
= AS_ASSUMED_SIZE
;
14535 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14537 else if (sym
->ts
.type
== BT_ASSUMED
)
14539 /* TS 29113, C407a. */
14540 if (!sym
->attr
.dummy
)
14542 gfc_error ("Assumed type of variable %s at %L is only permitted "
14543 "for dummy variables", sym
->name
, &sym
->declared_at
);
14546 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14547 || sym
->attr
.pointer
|| sym
->attr
.value
)
14549 gfc_error ("Assumed-type variable %s at %L may not have the "
14550 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14551 sym
->name
, &sym
->declared_at
);
14554 if (sym
->attr
.intent
== INTENT_OUT
)
14556 gfc_error ("Assumed-type variable %s at %L may not have the "
14557 "INTENT(OUT) attribute",
14558 sym
->name
, &sym
->declared_at
);
14561 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14563 gfc_error ("Assumed-type variable %s at %L shall not be an "
14564 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14569 /* If the symbol is marked as bind(c), that it is declared at module level
14570 scope and verify its type and kind. Do not do the latter for symbols
14571 that are implicitly typed because that is handled in
14572 gfc_set_default_type. Handle dummy arguments and procedure definitions
14573 separately. Also, anything that is use associated is not handled here
14574 but instead is handled in the module it is declared in. Finally, derived
14575 type definitions are allowed to be BIND(C) since that only implies that
14576 they're interoperable, and they are checked fully for interoperability
14577 when a variable is declared of that type. */
14578 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
14579 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
14580 && sym
->attr
.flavor
!= FL_DERIVED
)
14584 /* First, make sure the variable is declared at the
14585 module-level scope (J3/04-007, Section 15.3). */
14586 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
14587 sym
->attr
.in_common
== 0)
14589 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14590 "is neither a COMMON block nor declared at the "
14591 "module level scope", sym
->name
, &(sym
->declared_at
));
14594 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
14596 t
= verify_com_block_vars_c_interop (sym
->common_head
);
14598 else if (sym
->attr
.implicit_type
== 0)
14600 /* If type() declaration, we need to verify that the components
14601 of the given type are all C interoperable, etc. */
14602 if (sym
->ts
.type
== BT_DERIVED
&&
14603 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
14605 /* Make sure the user marked the derived type as BIND(C). If
14606 not, call the verify routine. This could print an error
14607 for the derived type more than once if multiple variables
14608 of that type are declared. */
14609 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
14610 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
14614 /* Verify the variable itself as C interoperable if it
14615 is BIND(C). It is not possible for this to succeed if
14616 the verify_bind_c_derived_type failed, so don't have to handle
14617 any error returned by verify_bind_c_derived_type. */
14618 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
14619 sym
->common_block
);
14624 /* clear the is_bind_c flag to prevent reporting errors more than
14625 once if something failed. */
14626 sym
->attr
.is_bind_c
= 0;
14631 /* If a derived type symbol has reached this point, without its
14632 type being declared, we have an error. Notice that most
14633 conditions that produce undefined derived types have already
14634 been dealt with. However, the likes of:
14635 implicit type(t) (t) ..... call foo (t) will get us here if
14636 the type is not declared in the scope of the implicit
14637 statement. Change the type to BT_UNKNOWN, both because it is so
14638 and to prevent an ICE. */
14639 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14640 && sym
->ts
.u
.derived
->components
== NULL
14641 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14643 gfc_error ("The derived type %qs at %L is of type %qs, "
14644 "which has not been defined", sym
->name
,
14645 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14646 sym
->ts
.type
= BT_UNKNOWN
;
14650 /* Make sure that the derived type has been resolved and that the
14651 derived type is visible in the symbol's namespace, if it is a
14652 module function and is not PRIVATE. */
14653 if (sym
->ts
.type
== BT_DERIVED
14654 && sym
->ts
.u
.derived
->attr
.use_assoc
14655 && sym
->ns
->proc_name
14656 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14657 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14660 /* Unless the derived-type declaration is use associated, Fortran 95
14661 does not allow public entries of private derived types.
14662 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14663 161 in 95-006r3. */
14664 if (sym
->ts
.type
== BT_DERIVED
14665 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14666 && !sym
->ts
.u
.derived
->attr
.use_assoc
14667 && gfc_check_symbol_access (sym
)
14668 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14669 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14670 "derived type %qs",
14671 (sym
->attr
.flavor
== FL_PARAMETER
)
14672 ? "parameter" : "variable",
14673 sym
->name
, &sym
->declared_at
,
14674 sym
->ts
.u
.derived
->name
))
14677 /* F2008, C1302. */
14678 if (sym
->ts
.type
== BT_DERIVED
14679 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14680 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14681 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14682 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14684 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14685 "type LOCK_TYPE must be a coarray", sym
->name
,
14686 &sym
->declared_at
);
14690 /* TS18508, C702/C703. */
14691 if (sym
->ts
.type
== BT_DERIVED
14692 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14693 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14694 || sym
->ts
.u
.derived
->attr
.event_comp
)
14695 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14697 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14698 "type EVENT_TYPE must be a coarray", sym
->name
,
14699 &sym
->declared_at
);
14703 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14704 default initialization is defined (5.1.2.4.4). */
14705 if (sym
->ts
.type
== BT_DERIVED
14707 && sym
->attr
.intent
== INTENT_OUT
14709 && sym
->as
->type
== AS_ASSUMED_SIZE
)
14711 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
14713 if (c
->initializer
)
14715 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14716 "ASSUMED SIZE and so cannot have a default initializer",
14717 sym
->name
, &sym
->declared_at
);
14724 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14725 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
14727 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14728 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14733 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14734 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
14736 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14737 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14742 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14743 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14744 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14745 || class_attr
.codimension
)
14746 && (sym
->attr
.result
|| sym
->result
== sym
))
14748 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14749 "a coarray component", sym
->name
, &sym
->declared_at
);
14754 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
14755 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
14757 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14758 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
14763 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14764 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14765 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14766 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
14767 || class_attr
.allocatable
))
14769 gfc_error ("Variable %qs at %L with coarray component shall be a "
14770 "nonpointer, nonallocatable scalar, which is not a coarray",
14771 sym
->name
, &sym
->declared_at
);
14775 /* F2008, C526. The function-result case was handled above. */
14776 if (class_attr
.codimension
14777 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
14778 || sym
->attr
.select_type_temporary
14779 || sym
->attr
.associate_var
14780 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14781 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14782 || sym
->ns
->proc_name
->attr
.is_main_program
14783 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
14785 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14786 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
14790 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
14791 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
14793 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
14794 "deferred shape", sym
->name
, &sym
->declared_at
);
14797 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
14798 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
14800 gfc_error ("Allocatable coarray variable %qs at %L must have "
14801 "deferred shape", sym
->name
, &sym
->declared_at
);
14806 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14807 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14808 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14809 || (class_attr
.codimension
&& class_attr
.allocatable
))
14810 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
14812 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
14813 "allocatable coarray or have coarray components",
14814 sym
->name
, &sym
->declared_at
);
14818 if (class_attr
.codimension
&& sym
->attr
.dummy
14819 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
14821 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
14822 "procedure %qs", sym
->name
, &sym
->declared_at
,
14823 sym
->ns
->proc_name
->name
);
14827 if (sym
->ts
.type
== BT_LOGICAL
14828 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
14829 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
14830 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
14833 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
14834 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
14836 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
14837 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
14838 "%L with non-C_Bool kind in BIND(C) procedure "
14839 "%qs", sym
->name
, &sym
->declared_at
,
14840 sym
->ns
->proc_name
->name
))
14842 else if (!gfc_logical_kinds
[i
].c_bool
14843 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
14844 "%qs at %L with non-C_Bool kind in "
14845 "BIND(C) procedure %qs", sym
->name
,
14847 sym
->attr
.function
? sym
->name
14848 : sym
->ns
->proc_name
->name
))
14852 switch (sym
->attr
.flavor
)
14855 if (!resolve_fl_variable (sym
, mp_flag
))
14860 if (sym
->formal
&& !sym
->formal_ns
)
14862 /* Check that none of the arguments are a namelist. */
14863 gfc_formal_arglist
*formal
= sym
->formal
;
14865 for (; formal
; formal
= formal
->next
)
14866 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
14868 gfc_error ("Namelist %qs can not be an argument to "
14869 "subroutine or function at %L",
14870 formal
->sym
->name
, &sym
->declared_at
);
14875 if (!resolve_fl_procedure (sym
, mp_flag
))
14880 if (!resolve_fl_namelist (sym
))
14885 if (!resolve_fl_parameter (sym
))
14893 /* Resolve array specifier. Check as well some constraints
14894 on COMMON blocks. */
14896 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
14898 /* Set the formal_arg_flag so that check_conflict will not throw
14899 an error for host associated variables in the specification
14900 expression for an array_valued function. */
14901 if (sym
->attr
.function
&& sym
->as
)
14902 formal_arg_flag
= true;
14904 saved_specification_expr
= specification_expr
;
14905 specification_expr
= true;
14906 gfc_resolve_array_spec (sym
->as
, check_constant
);
14907 specification_expr
= saved_specification_expr
;
14909 formal_arg_flag
= false;
14911 /* Resolve formal namespaces. */
14912 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
14913 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
14914 gfc_resolve (sym
->formal_ns
);
14916 /* Make sure the formal namespace is present. */
14917 if (sym
->formal
&& !sym
->formal_ns
)
14919 gfc_formal_arglist
*formal
= sym
->formal
;
14920 while (formal
&& !formal
->sym
)
14921 formal
= formal
->next
;
14925 sym
->formal_ns
= formal
->sym
->ns
;
14926 if (sym
->ns
!= formal
->sym
->ns
)
14927 sym
->formal_ns
->refs
++;
14931 /* Check threadprivate restrictions. */
14932 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
14933 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14934 && (!sym
->attr
.in_common
14935 && sym
->module
== NULL
14936 && (sym
->ns
->proc_name
== NULL
14937 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14938 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
14940 /* Check omp declare target restrictions. */
14941 if (sym
->attr
.omp_declare_target
14942 && sym
->attr
.flavor
== FL_VARIABLE
14944 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14945 && (!sym
->attr
.in_common
14946 && sym
->module
== NULL
14947 && (sym
->ns
->proc_name
== NULL
14948 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14949 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14950 sym
->name
, &sym
->declared_at
);
14952 /* If we have come this far we can apply default-initializers, as
14953 described in 14.7.5, to those variables that have not already
14954 been assigned one. */
14955 if (sym
->ts
.type
== BT_DERIVED
14957 && !sym
->attr
.allocatable
14958 && !sym
->attr
.alloc_comp
)
14960 symbol_attribute
*a
= &sym
->attr
;
14962 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
14963 && !a
->in_common
&& !a
->use_assoc
14964 && !a
->result
&& !a
->function
)
14965 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
14966 apply_default_init (sym
);
14967 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
14968 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14969 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14970 /* Mark the result symbol to be referenced, when it has allocatable
14972 sym
->result
->attr
.referenced
= 1;
14975 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
14976 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
14977 && !CLASS_DATA (sym
)->attr
.class_pointer
14978 && !CLASS_DATA (sym
)->attr
.allocatable
)
14979 apply_default_init (sym
);
14981 /* If this symbol has a type-spec, check it. */
14982 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
14983 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
14984 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
14987 if (sym
->param_list
)
14992 /************* Resolve DATA statements *************/
14996 gfc_data_value
*vnode
;
15002 /* Advance the values structure to point to the next value in the data list. */
15005 next_data_value (void)
15007 while (mpz_cmp_ui (values
.left
, 0) == 0)
15010 if (values
.vnode
->next
== NULL
)
15013 values
.vnode
= values
.vnode
->next
;
15014 mpz_set (values
.left
, values
.vnode
->repeat
);
15022 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15028 ar_type mark
= AR_UNKNOWN
;
15030 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15036 if (!gfc_resolve_expr (var
->expr
))
15040 mpz_init_set_si (offset
, 0);
15043 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15044 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15045 e
= e
->value
.function
.actual
->expr
;
15047 if (e
->expr_type
!= EXPR_VARIABLE
)
15048 gfc_internal_error ("check_data_variable(): Bad expression");
15050 sym
= e
->symtree
->n
.sym
;
15052 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15054 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15055 sym
->name
, &sym
->declared_at
);
15058 if (e
->ref
== NULL
&& sym
->as
)
15060 gfc_error ("DATA array %qs at %L must be specified in a previous"
15061 " declaration", sym
->name
, where
);
15065 has_pointer
= sym
->attr
.pointer
;
15067 if (gfc_is_coindexed (e
))
15069 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15074 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15076 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15080 && ref
->type
== REF_ARRAY
15081 && ref
->u
.ar
.type
!= AR_FULL
)
15083 gfc_error ("DATA element %qs at %L is a pointer and so must "
15084 "be a full array", sym
->name
, where
);
15089 if (e
->rank
== 0 || has_pointer
)
15091 mpz_init_set_ui (size
, 1);
15098 /* Find the array section reference. */
15099 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15101 if (ref
->type
!= REF_ARRAY
)
15103 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15109 /* Set marks according to the reference pattern. */
15110 switch (ref
->u
.ar
.type
)
15118 /* Get the start position of array section. */
15119 gfc_get_section_index (ar
, section_index
, &offset
);
15124 gcc_unreachable ();
15127 if (!gfc_array_size (e
, &size
))
15129 gfc_error ("Nonconstant array section at %L in DATA statement",
15131 mpz_clear (offset
);
15138 while (mpz_cmp_ui (size
, 0) > 0)
15140 if (!next_data_value ())
15142 gfc_error ("DATA statement at %L has more variables than values",
15148 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15152 /* If we have more than one element left in the repeat count,
15153 and we have more than one element left in the target variable,
15154 then create a range assignment. */
15155 /* FIXME: Only done for full arrays for now, since array sections
15157 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15158 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15162 if (mpz_cmp (size
, values
.left
) >= 0)
15164 mpz_init_set (range
, values
.left
);
15165 mpz_sub (size
, size
, values
.left
);
15166 mpz_set_ui (values
.left
, 0);
15170 mpz_init_set (range
, size
);
15171 mpz_sub (values
.left
, values
.left
, size
);
15172 mpz_set_ui (size
, 0);
15175 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15178 mpz_add (offset
, offset
, range
);
15185 /* Assign initial value to symbol. */
15188 mpz_sub_ui (values
.left
, values
.left
, 1);
15189 mpz_sub_ui (size
, size
, 1);
15191 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15196 if (mark
== AR_FULL
)
15197 mpz_add_ui (offset
, offset
, 1);
15199 /* Modify the array section indexes and recalculate the offset
15200 for next element. */
15201 else if (mark
== AR_SECTION
)
15202 gfc_advance_section (section_index
, ar
, &offset
);
15206 if (mark
== AR_SECTION
)
15208 for (i
= 0; i
< ar
->dimen
; i
++)
15209 mpz_clear (section_index
[i
]);
15213 mpz_clear (offset
);
15219 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15221 /* Iterate over a list of elements in a DATA statement. */
15224 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15227 iterator_stack frame
;
15228 gfc_expr
*e
, *start
, *end
, *step
;
15229 bool retval
= true;
15231 mpz_init (frame
.value
);
15234 start
= gfc_copy_expr (var
->iter
.start
);
15235 end
= gfc_copy_expr (var
->iter
.end
);
15236 step
= gfc_copy_expr (var
->iter
.step
);
15238 if (!gfc_simplify_expr (start
, 1)
15239 || start
->expr_type
!= EXPR_CONSTANT
)
15241 gfc_error ("start of implied-do loop at %L could not be "
15242 "simplified to a constant value", &start
->where
);
15246 if (!gfc_simplify_expr (end
, 1)
15247 || end
->expr_type
!= EXPR_CONSTANT
)
15249 gfc_error ("end of implied-do loop at %L could not be "
15250 "simplified to a constant value", &start
->where
);
15254 if (!gfc_simplify_expr (step
, 1)
15255 || step
->expr_type
!= EXPR_CONSTANT
)
15257 gfc_error ("step of implied-do loop at %L could not be "
15258 "simplified to a constant value", &start
->where
);
15263 mpz_set (trip
, end
->value
.integer
);
15264 mpz_sub (trip
, trip
, start
->value
.integer
);
15265 mpz_add (trip
, trip
, step
->value
.integer
);
15267 mpz_div (trip
, trip
, step
->value
.integer
);
15269 mpz_set (frame
.value
, start
->value
.integer
);
15271 frame
.prev
= iter_stack
;
15272 frame
.variable
= var
->iter
.var
->symtree
;
15273 iter_stack
= &frame
;
15275 while (mpz_cmp_ui (trip
, 0) > 0)
15277 if (!traverse_data_var (var
->list
, where
))
15283 e
= gfc_copy_expr (var
->expr
);
15284 if (!gfc_simplify_expr (e
, 1))
15291 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15293 mpz_sub_ui (trip
, trip
, 1);
15297 mpz_clear (frame
.value
);
15300 gfc_free_expr (start
);
15301 gfc_free_expr (end
);
15302 gfc_free_expr (step
);
15304 iter_stack
= frame
.prev
;
15309 /* Type resolve variables in the variable list of a DATA statement. */
15312 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15316 for (; var
; var
= var
->next
)
15318 if (var
->expr
== NULL
)
15319 t
= traverse_data_list (var
, where
);
15321 t
= check_data_variable (var
, where
);
15331 /* Resolve the expressions and iterators associated with a data statement.
15332 This is separate from the assignment checking because data lists should
15333 only be resolved once. */
15336 resolve_data_variables (gfc_data_variable
*d
)
15338 for (; d
; d
= d
->next
)
15340 if (d
->list
== NULL
)
15342 if (!gfc_resolve_expr (d
->expr
))
15347 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15350 if (!resolve_data_variables (d
->list
))
15359 /* Resolve a single DATA statement. We implement this by storing a pointer to
15360 the value list into static variables, and then recursively traversing the
15361 variables list, expanding iterators and such. */
15364 resolve_data (gfc_data
*d
)
15367 if (!resolve_data_variables (d
->var
))
15370 values
.vnode
= d
->value
;
15371 if (d
->value
== NULL
)
15372 mpz_set_ui (values
.left
, 0);
15374 mpz_set (values
.left
, d
->value
->repeat
);
15376 if (!traverse_data_var (d
->var
, &d
->where
))
15379 /* At this point, we better not have any values left. */
15381 if (next_data_value ())
15382 gfc_error ("DATA statement at %L has more values than variables",
15387 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15388 accessed by host or use association, is a dummy argument to a pure function,
15389 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15390 is storage associated with any such variable, shall not be used in the
15391 following contexts: (clients of this function). */
15393 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15394 procedure. Returns zero if assignment is OK, nonzero if there is a
15397 gfc_impure_variable (gfc_symbol
*sym
)
15402 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15405 /* Check if the symbol's ns is inside the pure procedure. */
15406 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15410 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15414 proc
= sym
->ns
->proc_name
;
15415 if (sym
->attr
.dummy
15416 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15417 || proc
->attr
.function
))
15420 /* TODO: Sort out what can be storage associated, if anything, and include
15421 it here. In principle equivalences should be scanned but it does not
15422 seem to be possible to storage associate an impure variable this way. */
15427 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15428 current namespace is inside a pure procedure. */
15431 gfc_pure (gfc_symbol
*sym
)
15433 symbol_attribute attr
;
15438 /* Check if the current namespace or one of its parents
15439 belongs to a pure procedure. */
15440 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15442 sym
= ns
->proc_name
;
15446 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15454 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15458 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15459 checks if the current namespace is implicitly pure. Note that this
15460 function returns false for a PURE procedure. */
15463 gfc_implicit_pure (gfc_symbol
*sym
)
15469 /* Check if the current procedure is implicit_pure. Walk up
15470 the procedure list until we find a procedure. */
15471 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15473 sym
= ns
->proc_name
;
15477 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15482 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15483 && !sym
->attr
.pure
;
15488 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15494 /* Check if the current procedure is implicit_pure. Walk up
15495 the procedure list until we find a procedure. */
15496 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15498 sym
= ns
->proc_name
;
15502 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15507 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15508 sym
->attr
.implicit_pure
= 0;
15510 sym
->attr
.pure
= 0;
15514 /* Test whether the current procedure is elemental or not. */
15517 gfc_elemental (gfc_symbol
*sym
)
15519 symbol_attribute attr
;
15522 sym
= gfc_current_ns
->proc_name
;
15527 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15531 /* Warn about unused labels. */
15534 warn_unused_fortran_label (gfc_st_label
*label
)
15539 warn_unused_fortran_label (label
->left
);
15541 if (label
->defined
== ST_LABEL_UNKNOWN
)
15544 switch (label
->referenced
)
15546 case ST_LABEL_UNKNOWN
:
15547 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
15548 label
->value
, &label
->where
);
15551 case ST_LABEL_BAD_TARGET
:
15552 gfc_warning (OPT_Wunused_label
,
15553 "Label %d at %L defined but cannot be used",
15554 label
->value
, &label
->where
);
15561 warn_unused_fortran_label (label
->right
);
15565 /* Returns the sequence type of a symbol or sequence. */
15568 sequence_type (gfc_typespec ts
)
15577 if (ts
.u
.derived
->components
== NULL
)
15578 return SEQ_NONDEFAULT
;
15580 result
= sequence_type (ts
.u
.derived
->components
->ts
);
15581 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
15582 if (sequence_type (c
->ts
) != result
)
15588 if (ts
.kind
!= gfc_default_character_kind
)
15589 return SEQ_NONDEFAULT
;
15591 return SEQ_CHARACTER
;
15594 if (ts
.kind
!= gfc_default_integer_kind
)
15595 return SEQ_NONDEFAULT
;
15597 return SEQ_NUMERIC
;
15600 if (!(ts
.kind
== gfc_default_real_kind
15601 || ts
.kind
== gfc_default_double_kind
))
15602 return SEQ_NONDEFAULT
;
15604 return SEQ_NUMERIC
;
15607 if (ts
.kind
!= gfc_default_complex_kind
)
15608 return SEQ_NONDEFAULT
;
15610 return SEQ_NUMERIC
;
15613 if (ts
.kind
!= gfc_default_logical_kind
)
15614 return SEQ_NONDEFAULT
;
15616 return SEQ_NUMERIC
;
15619 return SEQ_NONDEFAULT
;
15624 /* Resolve derived type EQUIVALENCE object. */
15627 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
15629 gfc_component
*c
= derived
->components
;
15634 /* Shall not be an object of nonsequence derived type. */
15635 if (!derived
->attr
.sequence
)
15637 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15638 "attribute to be an EQUIVALENCE object", sym
->name
,
15643 /* Shall not have allocatable components. */
15644 if (derived
->attr
.alloc_comp
)
15646 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15647 "components to be an EQUIVALENCE object",sym
->name
,
15652 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
15654 gfc_error ("Derived type variable %qs at %L with default "
15655 "initialization cannot be in EQUIVALENCE with a variable "
15656 "in COMMON", sym
->name
, &e
->where
);
15660 for (; c
; c
= c
->next
)
15662 if (gfc_bt_struct (c
->ts
.type
)
15663 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15666 /* Shall not be an object of sequence derived type containing a pointer
15667 in the structure. */
15668 if (c
->attr
.pointer
)
15670 gfc_error ("Derived type variable %qs at %L with pointer "
15671 "component(s) cannot be an EQUIVALENCE object",
15672 sym
->name
, &e
->where
);
15680 /* Resolve equivalence object.
15681 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15682 an allocatable array, an object of nonsequence derived type, an object of
15683 sequence derived type containing a pointer at any level of component
15684 selection, an automatic object, a function name, an entry name, a result
15685 name, a named constant, a structure component, or a subobject of any of
15686 the preceding objects. A substring shall not have length zero. A
15687 derived type shall not have components with default initialization nor
15688 shall two objects of an equivalence group be initialized.
15689 Either all or none of the objects shall have an protected attribute.
15690 The simple constraints are done in symbol.c(check_conflict) and the rest
15691 are implemented here. */
15694 resolve_equivalence (gfc_equiv
*eq
)
15697 gfc_symbol
*first_sym
;
15700 locus
*last_where
= NULL
;
15701 seq_type eq_type
, last_eq_type
;
15702 gfc_typespec
*last_ts
;
15703 int object
, cnt_protected
;
15706 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
15708 first_sym
= eq
->expr
->symtree
->n
.sym
;
15712 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
15716 e
->ts
= e
->symtree
->n
.sym
->ts
;
15717 /* match_varspec might not know yet if it is seeing
15718 array reference or substring reference, as it doesn't
15720 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
15722 gfc_ref
*ref
= e
->ref
;
15723 sym
= e
->symtree
->n
.sym
;
15725 if (sym
->attr
.dimension
)
15727 ref
->u
.ar
.as
= sym
->as
;
15731 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15732 if (e
->ts
.type
== BT_CHARACTER
15734 && ref
->type
== REF_ARRAY
15735 && ref
->u
.ar
.dimen
== 1
15736 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
15737 && ref
->u
.ar
.stride
[0] == NULL
)
15739 gfc_expr
*start
= ref
->u
.ar
.start
[0];
15740 gfc_expr
*end
= ref
->u
.ar
.end
[0];
15743 /* Optimize away the (:) reference. */
15744 if (start
== NULL
&& end
== NULL
)
15747 e
->ref
= ref
->next
;
15749 e
->ref
->next
= ref
->next
;
15754 ref
->type
= REF_SUBSTRING
;
15756 start
= gfc_get_int_expr (gfc_default_integer_kind
,
15758 ref
->u
.ss
.start
= start
;
15759 if (end
== NULL
&& e
->ts
.u
.cl
)
15760 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
15761 ref
->u
.ss
.end
= end
;
15762 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
15769 /* Any further ref is an error. */
15772 gcc_assert (ref
->type
== REF_ARRAY
);
15773 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15779 if (!gfc_resolve_expr (e
))
15782 sym
= e
->symtree
->n
.sym
;
15784 if (sym
->attr
.is_protected
)
15786 if (cnt_protected
> 0 && cnt_protected
!= object
)
15788 gfc_error ("Either all or none of the objects in the "
15789 "EQUIVALENCE set at %L shall have the "
15790 "PROTECTED attribute",
15795 /* Shall not equivalence common block variables in a PURE procedure. */
15796 if (sym
->ns
->proc_name
15797 && sym
->ns
->proc_name
->attr
.pure
15798 && sym
->attr
.in_common
)
15800 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
15801 "object in the pure procedure %qs",
15802 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
15806 /* Shall not be a named constant. */
15807 if (e
->expr_type
== EXPR_CONSTANT
)
15809 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
15810 "object", sym
->name
, &e
->where
);
15814 if (e
->ts
.type
== BT_DERIVED
15815 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
15818 /* Check that the types correspond correctly:
15820 A numeric sequence structure may be equivalenced to another sequence
15821 structure, an object of default integer type, default real type, double
15822 precision real type, default logical type such that components of the
15823 structure ultimately only become associated to objects of the same
15824 kind. A character sequence structure may be equivalenced to an object
15825 of default character kind or another character sequence structure.
15826 Other objects may be equivalenced only to objects of the same type and
15827 kind parameters. */
15829 /* Identical types are unconditionally OK. */
15830 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
15831 goto identical_types
;
15833 last_eq_type
= sequence_type (*last_ts
);
15834 eq_type
= sequence_type (sym
->ts
);
15836 /* Since the pair of objects is not of the same type, mixed or
15837 non-default sequences can be rejected. */
15839 msg
= "Sequence %s with mixed components in EQUIVALENCE "
15840 "statement at %L with different type objects";
15842 && last_eq_type
== SEQ_MIXED
15843 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15844 || (eq_type
== SEQ_MIXED
15845 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15848 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
15849 "statement at %L with objects of different type";
15851 && last_eq_type
== SEQ_NONDEFAULT
15852 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15853 || (eq_type
== SEQ_NONDEFAULT
15854 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15857 msg
="Non-CHARACTER object %qs in default CHARACTER "
15858 "EQUIVALENCE statement at %L";
15859 if (last_eq_type
== SEQ_CHARACTER
15860 && eq_type
!= SEQ_CHARACTER
15861 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15864 msg
="Non-NUMERIC object %qs in default NUMERIC "
15865 "EQUIVALENCE statement at %L";
15866 if (last_eq_type
== SEQ_NUMERIC
15867 && eq_type
!= SEQ_NUMERIC
15868 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15873 last_where
= &e
->where
;
15878 /* Shall not be an automatic array. */
15879 if (e
->ref
->type
== REF_ARRAY
15880 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
15882 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15883 "an EQUIVALENCE object", sym
->name
, &e
->where
);
15890 /* Shall not be a structure component. */
15891 if (r
->type
== REF_COMPONENT
)
15893 gfc_error ("Structure component %qs at %L cannot be an "
15894 "EQUIVALENCE object",
15895 r
->u
.c
.component
->name
, &e
->where
);
15899 /* A substring shall not have length zero. */
15900 if (r
->type
== REF_SUBSTRING
)
15902 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
15904 gfc_error ("Substring at %L has length zero",
15905 &r
->u
.ss
.start
->where
);
15915 /* Function called by resolve_fntype to flag other symbol used in the
15916 length type parameter specification of function resuls. */
15919 flag_fn_result_spec (gfc_expr
*expr
,
15920 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
15921 int *f ATTRIBUTE_UNUSED
)
15926 if (expr
->expr_type
== EXPR_VARIABLE
)
15928 s
= expr
->symtree
->n
.sym
;
15929 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
15933 if (!s
->fn_result_spec
15934 && s
->attr
.flavor
== FL_PARAMETER
)
15936 /* Function contained in a module.... */
15937 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
15940 s
->fn_result_spec
= 1;
15941 /* Make sure that this symbol is translated as a module
15943 st
= gfc_get_unique_symtree (ns
);
15947 /* ... which is use associated and called. */
15948 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
15950 /* External function matched with an interface. */
15953 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
15954 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15955 && s
->ns
->proc_name
->attr
.function
))
15956 s
->fn_result_spec
= 1;
15963 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15966 resolve_fntype (gfc_namespace
*ns
)
15968 gfc_entry_list
*el
;
15971 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
15974 /* If there are any entries, ns->proc_name is the entry master
15975 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15977 sym
= ns
->entries
->sym
;
15979 sym
= ns
->proc_name
;
15980 if (sym
->result
== sym
15981 && sym
->ts
.type
== BT_UNKNOWN
15982 && !gfc_set_default_type (sym
, 0, NULL
)
15983 && !sym
->attr
.untyped
)
15985 gfc_error ("Function %qs at %L has no IMPLICIT type",
15986 sym
->name
, &sym
->declared_at
);
15987 sym
->attr
.untyped
= 1;
15990 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
15991 && !sym
->attr
.contained
15992 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15993 && gfc_check_symbol_access (sym
))
15995 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
15996 "%L of PRIVATE type %qs", sym
->name
,
15997 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16001 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16003 if (el
->sym
->result
== el
->sym
16004 && el
->sym
->ts
.type
== BT_UNKNOWN
16005 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16006 && !el
->sym
->attr
.untyped
)
16008 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16009 el
->sym
->name
, &el
->sym
->declared_at
);
16010 el
->sym
->attr
.untyped
= 1;
16014 if (sym
->ts
.type
== BT_CHARACTER
)
16015 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, NULL
, flag_fn_result_spec
, 0);
16019 /* 12.3.2.1.1 Defined operators. */
16022 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16024 gfc_formal_arglist
*formal
;
16026 if (!sym
->attr
.function
)
16028 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16029 sym
->name
, &where
);
16033 if (sym
->ts
.type
== BT_CHARACTER
16034 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16035 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16036 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16038 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16039 "character length", sym
->name
, &where
);
16043 formal
= gfc_sym_get_dummy_args (sym
);
16044 if (!formal
|| !formal
->sym
)
16046 gfc_error ("User operator procedure %qs at %L must have at least "
16047 "one argument", sym
->name
, &where
);
16051 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16053 gfc_error ("First argument of operator interface at %L must be "
16054 "INTENT(IN)", &where
);
16058 if (formal
->sym
->attr
.optional
)
16060 gfc_error ("First argument of operator interface at %L cannot be "
16061 "optional", &where
);
16065 formal
= formal
->next
;
16066 if (!formal
|| !formal
->sym
)
16069 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16071 gfc_error ("Second argument of operator interface at %L must be "
16072 "INTENT(IN)", &where
);
16076 if (formal
->sym
->attr
.optional
)
16078 gfc_error ("Second argument of operator interface at %L cannot be "
16079 "optional", &where
);
16085 gfc_error ("Operator interface at %L must have, at most, two "
16086 "arguments", &where
);
16094 gfc_resolve_uops (gfc_symtree
*symtree
)
16096 gfc_interface
*itr
;
16098 if (symtree
== NULL
)
16101 gfc_resolve_uops (symtree
->left
);
16102 gfc_resolve_uops (symtree
->right
);
16104 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16105 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16109 /* Examine all of the expressions associated with a program unit,
16110 assign types to all intermediate expressions, make sure that all
16111 assignments are to compatible types and figure out which names
16112 refer to which functions or subroutines. It doesn't check code
16113 block, which is handled by gfc_resolve_code. */
16116 resolve_types (gfc_namespace
*ns
)
16122 gfc_namespace
* old_ns
= gfc_current_ns
;
16124 if (ns
->types_resolved
)
16127 /* Check that all IMPLICIT types are ok. */
16128 if (!ns
->seen_implicit_none
)
16131 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16132 if (ns
->set_flag
[letter
]
16133 && !resolve_typespec_used (&ns
->default_type
[letter
],
16134 &ns
->implicit_loc
[letter
], NULL
))
16138 gfc_current_ns
= ns
;
16140 resolve_entries (ns
);
16142 resolve_common_vars (&ns
->blank_common
, false);
16143 resolve_common_blocks (ns
->common_root
);
16145 resolve_contained_functions (ns
);
16147 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16148 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16149 resolve_formal_arglist (ns
->proc_name
);
16151 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16153 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16154 resolve_charlen (cl
);
16156 gfc_traverse_ns (ns
, resolve_symbol
);
16158 resolve_fntype (ns
);
16160 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16162 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16163 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16164 "also be PURE", n
->proc_name
->name
,
16165 &n
->proc_name
->declared_at
);
16171 gfc_do_concurrent_flag
= 0;
16172 gfc_check_interfaces (ns
);
16174 gfc_traverse_ns (ns
, resolve_values
);
16180 for (d
= ns
->data
; d
; d
= d
->next
)
16184 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16186 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16188 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16189 resolve_equivalence (eq
);
16191 /* Warn about unused labels. */
16192 if (warn_unused_label
)
16193 warn_unused_fortran_label (ns
->st_labels
);
16195 gfc_resolve_uops (ns
->uop_root
);
16197 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16199 gfc_resolve_omp_declare_simd (ns
);
16201 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16203 ns
->types_resolved
= 1;
16205 gfc_current_ns
= old_ns
;
16209 /* Call gfc_resolve_code recursively. */
16212 resolve_codes (gfc_namespace
*ns
)
16215 bitmap_obstack old_obstack
;
16217 if (ns
->resolved
== 1)
16220 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16223 gfc_current_ns
= ns
;
16225 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16226 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16229 /* Set to an out of range value. */
16230 current_entry_id
= -1;
16232 old_obstack
= labels_obstack
;
16233 bitmap_obstack_initialize (&labels_obstack
);
16235 gfc_resolve_oacc_declare (ns
);
16236 gfc_resolve_code (ns
->code
, ns
);
16238 bitmap_obstack_release (&labels_obstack
);
16239 labels_obstack
= old_obstack
;
16243 /* This function is called after a complete program unit has been compiled.
16244 Its purpose is to examine all of the expressions associated with a program
16245 unit, assign types to all intermediate expressions, make sure that all
16246 assignments are to compatible types and figure out which names refer to
16247 which functions or subroutines. */
16250 gfc_resolve (gfc_namespace
*ns
)
16252 gfc_namespace
*old_ns
;
16253 code_stack
*old_cs_base
;
16254 struct gfc_omp_saved_state old_omp_state
;
16260 old_ns
= gfc_current_ns
;
16261 old_cs_base
= cs_base
;
16263 /* As gfc_resolve can be called during resolution of an OpenMP construct
16264 body, we should clear any state associated to it, so that say NS's
16265 DO loops are not interpreted as OpenMP loops. */
16266 if (!ns
->construct_entities
)
16267 gfc_omp_save_and_clear_state (&old_omp_state
);
16269 resolve_types (ns
);
16270 component_assignment_level
= 0;
16271 resolve_codes (ns
);
16273 gfc_current_ns
= old_ns
;
16274 cs_base
= old_cs_base
;
16277 gfc_run_passes (ns
);
16279 if (!ns
->construct_entities
)
16280 gfc_omp_restore_state (&old_omp_state
);