1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* Nonzero if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static int formal_arg_flag
= 0;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
221 sym
->ts
.interface
= ifc
;
222 sym
->attr
.function
= ifc
->attr
.function
;
223 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
225 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
226 sym
->attr
.pointer
= ifc
->attr
.pointer
;
227 sym
->attr
.pure
= ifc
->attr
.pure
;
228 sym
->attr
.elemental
= ifc
->attr
.elemental
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
231 sym
->attr
.recursive
= ifc
->attr
.recursive
;
232 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
233 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
234 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
235 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
236 /* Copy array spec. */
237 sym
->as
= gfc_copy_array_spec (ifc
->as
);
238 /* Copy char length. */
239 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
241 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
242 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
243 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
252 /* Resolve types of formal argument lists. These have to be done early so that
253 the formal argument lists of module procedures can be copied to the
254 containing module before the individual procedures are resolved
255 individually. We also resolve argument lists of procedures in interface
256 blocks because they are self-contained scoping units.
258 Since a dummy argument cannot be a non-dummy procedure, the only
259 resort left for untyped names are the IMPLICIT types. */
262 resolve_formal_arglist (gfc_symbol
*proc
)
264 gfc_formal_arglist
*f
;
266 bool saved_specification_expr
;
269 if (proc
->result
!= NULL
)
274 if (gfc_elemental (proc
)
275 || sym
->attr
.pointer
|| sym
->attr
.allocatable
276 || (sym
->as
&& sym
->as
->rank
!= 0))
278 proc
->attr
.always_explicit
= 1;
279 sym
->attr
.always_explicit
= 1;
284 for (f
= proc
->formal
; f
; f
= f
->next
)
292 /* Alternate return placeholder. */
293 if (gfc_elemental (proc
))
294 gfc_error ("Alternate return specifier in elemental subroutine "
295 "%qs at %L is not allowed", proc
->name
,
297 if (proc
->attr
.function
)
298 gfc_error ("Alternate return specifier in function "
299 "%qs at %L is not allowed", proc
->name
,
303 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
304 && !resolve_procedure_interface (sym
))
307 if (strcmp (proc
->name
, sym
->name
) == 0)
309 gfc_error ("Self-referential argument "
310 "%qs at %L is not allowed", sym
->name
,
315 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
316 resolve_formal_arglist (sym
);
318 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
320 if (sym
->attr
.flavor
== FL_UNKNOWN
)
321 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
325 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
326 && (!sym
->attr
.function
|| sym
->result
== sym
))
327 gfc_set_default_type (sym
, 1, sym
->ns
);
330 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
331 ? CLASS_DATA (sym
)->as
: sym
->as
;
333 saved_specification_expr
= specification_expr
;
334 specification_expr
= true;
335 gfc_resolve_array_spec (as
, 0);
336 specification_expr
= saved_specification_expr
;
338 /* We can't tell if an array with dimension (:) is assumed or deferred
339 shape until we know if it has the pointer or allocatable attributes.
341 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
342 && ((sym
->ts
.type
!= BT_CLASS
343 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
344 || (sym
->ts
.type
== BT_CLASS
345 && !(CLASS_DATA (sym
)->attr
.class_pointer
346 || CLASS_DATA (sym
)->attr
.allocatable
)))
347 && sym
->attr
.flavor
!= FL_PROCEDURE
)
349 as
->type
= AS_ASSUMED_SHAPE
;
350 for (i
= 0; i
< as
->rank
; i
++)
351 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
354 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
355 || (as
&& as
->type
== AS_ASSUMED_RANK
)
356 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
357 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
358 && (CLASS_DATA (sym
)->attr
.class_pointer
359 || CLASS_DATA (sym
)->attr
.allocatable
360 || CLASS_DATA (sym
)->attr
.target
))
361 || sym
->attr
.optional
)
363 proc
->attr
.always_explicit
= 1;
365 proc
->result
->attr
.always_explicit
= 1;
368 /* If the flavor is unknown at this point, it has to be a variable.
369 A procedure specification would have already set the type. */
371 if (sym
->attr
.flavor
== FL_UNKNOWN
)
372 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
376 if (sym
->attr
.flavor
== FL_PROCEDURE
)
381 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
382 "also be PURE", sym
->name
, &sym
->declared_at
);
386 else if (!sym
->attr
.pointer
)
388 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
391 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
392 " of pure function %qs at %L with VALUE "
393 "attribute but without INTENT(IN)",
394 sym
->name
, proc
->name
, &sym
->declared_at
);
396 gfc_error ("Argument %qs of pure function %qs at %L must "
397 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
401 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
404 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
405 " of pure subroutine %qs at %L with VALUE "
406 "attribute but without INTENT", sym
->name
,
407 proc
->name
, &sym
->declared_at
);
409 gfc_error ("Argument %qs of pure subroutine %qs at %L "
410 "must have its INTENT specified or have the "
411 "VALUE attribute", sym
->name
, proc
->name
,
417 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
419 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
420 " may not be polymorphic", sym
->name
, proc
->name
,
426 if (proc
->attr
.implicit_pure
)
428 if (sym
->attr
.flavor
== FL_PROCEDURE
)
431 proc
->attr
.implicit_pure
= 0;
433 else if (!sym
->attr
.pointer
)
435 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
437 proc
->attr
.implicit_pure
= 0;
439 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
441 proc
->attr
.implicit_pure
= 0;
445 if (gfc_elemental (proc
))
448 if (sym
->attr
.codimension
449 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
450 && CLASS_DATA (sym
)->attr
.codimension
))
452 gfc_error ("Coarray dummy argument %qs at %L to elemental "
453 "procedure", sym
->name
, &sym
->declared_at
);
457 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
458 && CLASS_DATA (sym
)->as
))
460 gfc_error ("Argument %qs of elemental procedure at %L must "
461 "be scalar", sym
->name
, &sym
->declared_at
);
465 if (sym
->attr
.allocatable
466 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
467 && CLASS_DATA (sym
)->attr
.allocatable
))
469 gfc_error ("Argument %qs of elemental procedure at %L cannot "
470 "have the ALLOCATABLE attribute", sym
->name
,
475 if (sym
->attr
.pointer
476 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
477 && CLASS_DATA (sym
)->attr
.class_pointer
))
479 gfc_error ("Argument %qs of elemental procedure at %L cannot "
480 "have the POINTER attribute", sym
->name
,
485 if (sym
->attr
.flavor
== FL_PROCEDURE
)
487 gfc_error ("Dummy procedure %qs not allowed in elemental "
488 "procedure %qs at %L", sym
->name
, proc
->name
,
493 /* Fortran 2008 Corrigendum 1, C1290a. */
494 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
496 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
497 "have its INTENT specified or have the VALUE "
498 "attribute", sym
->name
, proc
->name
,
504 /* Each dummy shall be specified to be scalar. */
505 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
509 gfc_error ("Argument %qs of statement function at %L must "
510 "be scalar", sym
->name
, &sym
->declared_at
);
514 if (sym
->ts
.type
== BT_CHARACTER
)
516 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
517 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
519 gfc_error ("Character-valued argument %qs of statement "
520 "function at %L must have constant length",
521 sym
->name
, &sym
->declared_at
);
531 /* Work function called when searching for symbols that have argument lists
532 associated with them. */
535 find_arglists (gfc_symbol
*sym
)
537 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
538 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
541 resolve_formal_arglist (sym
);
545 /* Given a namespace, resolve all formal argument lists within the namespace.
549 resolve_formal_arglists (gfc_namespace
*ns
)
554 gfc_traverse_ns (ns
, find_arglists
);
559 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
563 /* If this namespace is not a function or an entry master function,
565 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
566 || sym
->attr
.entry_master
)
569 /* Try to find out of what the return type is. */
570 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
572 t
= gfc_set_default_type (sym
->result
, 0, ns
);
574 if (!t
&& !sym
->result
->attr
.untyped
)
576 if (sym
->result
== sym
)
577 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
578 sym
->name
, &sym
->declared_at
);
579 else if (!sym
->result
->attr
.proc_pointer
)
580 gfc_error ("Result %qs of contained function %qs at %L has "
581 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
582 &sym
->result
->declared_at
);
583 sym
->result
->attr
.untyped
= 1;
587 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
588 type, lists the only ways a character length value of * can be used:
589 dummy arguments of procedures, named constants, and function results
590 in external functions. Internal function results and results of module
591 procedures are not on this list, ergo, not permitted. */
593 if (sym
->result
->ts
.type
== BT_CHARACTER
)
595 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
596 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
598 /* See if this is a module-procedure and adapt error message
601 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
602 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
604 gfc_error ("Character-valued %s %qs at %L must not be"
606 module_proc
? _("module procedure")
607 : _("internal function"),
608 sym
->name
, &sym
->declared_at
);
614 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
615 introduce duplicates. */
618 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
620 gfc_formal_arglist
*f
, *new_arglist
;
623 for (; new_args
!= NULL
; new_args
= new_args
->next
)
625 new_sym
= new_args
->sym
;
626 /* See if this arg is already in the formal argument list. */
627 for (f
= proc
->formal
; f
; f
= f
->next
)
629 if (new_sym
== f
->sym
)
636 /* Add a new argument. Argument order is not important. */
637 new_arglist
= gfc_get_formal_arglist ();
638 new_arglist
->sym
= new_sym
;
639 new_arglist
->next
= proc
->formal
;
640 proc
->formal
= new_arglist
;
645 /* Flag the arguments that are not present in all entries. */
648 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
650 gfc_formal_arglist
*f
, *head
;
653 for (f
= proc
->formal
; f
; f
= f
->next
)
658 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
660 if (new_args
->sym
== f
->sym
)
667 f
->sym
->attr
.not_always_present
= 1;
672 /* Resolve alternate entry points. If a symbol has multiple entry points we
673 create a new master symbol for the main routine, and turn the existing
674 symbol into an entry point. */
677 resolve_entries (gfc_namespace
*ns
)
679 gfc_namespace
*old_ns
;
683 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
684 static int master_count
= 0;
686 if (ns
->proc_name
== NULL
)
689 /* No need to do anything if this procedure doesn't have alternate entry
694 /* We may already have resolved alternate entry points. */
695 if (ns
->proc_name
->attr
.entry_master
)
698 /* If this isn't a procedure something has gone horribly wrong. */
699 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
701 /* Remember the current namespace. */
702 old_ns
= gfc_current_ns
;
706 /* Add the main entry point to the list of entry points. */
707 el
= gfc_get_entry_list ();
708 el
->sym
= ns
->proc_name
;
710 el
->next
= ns
->entries
;
712 ns
->proc_name
->attr
.entry
= 1;
714 /* If it is a module function, it needs to be in the right namespace
715 so that gfc_get_fake_result_decl can gather up the results. The
716 need for this arose in get_proc_name, where these beasts were
717 left in their own namespace, to keep prior references linked to
718 the entry declaration.*/
719 if (ns
->proc_name
->attr
.function
720 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
723 /* Do the same for entries where the master is not a module
724 procedure. These are retained in the module namespace because
725 of the module procedure declaration. */
726 for (el
= el
->next
; el
; el
= el
->next
)
727 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
728 && el
->sym
->attr
.mod_proc
)
732 /* Add an entry statement for it. */
733 c
= gfc_get_code (EXEC_ENTRY
);
738 /* Create a new symbol for the master function. */
739 /* Give the internal function a unique name (within this file).
740 Also include the function name so the user has some hope of figuring
741 out what is going on. */
742 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
743 master_count
++, ns
->proc_name
->name
);
744 gfc_get_ha_symbol (name
, &proc
);
745 gcc_assert (proc
!= NULL
);
747 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
748 if (ns
->proc_name
->attr
.subroutine
)
749 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
753 gfc_typespec
*ts
, *fts
;
754 gfc_array_spec
*as
, *fas
;
755 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
757 fas
= ns
->entries
->sym
->as
;
758 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
759 fts
= &ns
->entries
->sym
->result
->ts
;
760 if (fts
->type
== BT_UNKNOWN
)
761 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
762 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
764 ts
= &el
->sym
->result
->ts
;
766 as
= as
? as
: el
->sym
->result
->as
;
767 if (ts
->type
== BT_UNKNOWN
)
768 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
770 if (! gfc_compare_types (ts
, fts
)
771 || (el
->sym
->result
->attr
.dimension
772 != ns
->entries
->sym
->result
->attr
.dimension
)
773 || (el
->sym
->result
->attr
.pointer
774 != ns
->entries
->sym
->result
->attr
.pointer
))
776 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
777 && gfc_compare_array_spec (as
, fas
) == 0)
778 gfc_error ("Function %s at %L has entries with mismatched "
779 "array specifications", ns
->entries
->sym
->name
,
780 &ns
->entries
->sym
->declared_at
);
781 /* The characteristics need to match and thus both need to have
782 the same string length, i.e. both len=*, or both len=4.
783 Having both len=<variable> is also possible, but difficult to
784 check at compile time. */
785 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
786 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
787 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
789 && ts
->u
.cl
->length
->expr_type
790 != fts
->u
.cl
->length
->expr_type
)
792 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
793 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
794 fts
->u
.cl
->length
->value
.integer
) != 0)))
795 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
796 "entries returning variables of different "
797 "string lengths", ns
->entries
->sym
->name
,
798 &ns
->entries
->sym
->declared_at
);
803 sym
= ns
->entries
->sym
->result
;
804 /* All result types the same. */
806 if (sym
->attr
.dimension
)
807 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
808 if (sym
->attr
.pointer
)
809 gfc_add_pointer (&proc
->attr
, NULL
);
813 /* Otherwise the result will be passed through a union by
815 proc
->attr
.mixed_entry_master
= 1;
816 for (el
= ns
->entries
; el
; el
= el
->next
)
818 sym
= el
->sym
->result
;
819 if (sym
->attr
.dimension
)
821 if (el
== ns
->entries
)
822 gfc_error ("FUNCTION result %s can't be an array in "
823 "FUNCTION %s at %L", sym
->name
,
824 ns
->entries
->sym
->name
, &sym
->declared_at
);
826 gfc_error ("ENTRY result %s can't be an array in "
827 "FUNCTION %s at %L", sym
->name
,
828 ns
->entries
->sym
->name
, &sym
->declared_at
);
830 else if (sym
->attr
.pointer
)
832 if (el
== ns
->entries
)
833 gfc_error ("FUNCTION result %s can't be a POINTER in "
834 "FUNCTION %s at %L", sym
->name
,
835 ns
->entries
->sym
->name
, &sym
->declared_at
);
837 gfc_error ("ENTRY result %s can't be a POINTER in "
838 "FUNCTION %s at %L", sym
->name
,
839 ns
->entries
->sym
->name
, &sym
->declared_at
);
844 if (ts
->type
== BT_UNKNOWN
)
845 ts
= gfc_get_default_type (sym
->name
, NULL
);
849 if (ts
->kind
== gfc_default_integer_kind
)
853 if (ts
->kind
== gfc_default_real_kind
854 || ts
->kind
== gfc_default_double_kind
)
858 if (ts
->kind
== gfc_default_complex_kind
)
862 if (ts
->kind
== gfc_default_logical_kind
)
866 /* We will issue error elsewhere. */
874 if (el
== ns
->entries
)
875 gfc_error ("FUNCTION result %s can't be of type %s "
876 "in FUNCTION %s at %L", sym
->name
,
877 gfc_typename (ts
), ns
->entries
->sym
->name
,
880 gfc_error ("ENTRY result %s can't be of type %s "
881 "in FUNCTION %s at %L", sym
->name
,
882 gfc_typename (ts
), ns
->entries
->sym
->name
,
889 proc
->attr
.access
= ACCESS_PRIVATE
;
890 proc
->attr
.entry_master
= 1;
892 /* Merge all the entry point arguments. */
893 for (el
= ns
->entries
; el
; el
= el
->next
)
894 merge_argument_lists (proc
, el
->sym
->formal
);
896 /* Check the master formal arguments for any that are not
897 present in all entry points. */
898 for (el
= ns
->entries
; el
; el
= el
->next
)
899 check_argument_lists (proc
, el
->sym
->formal
);
901 /* Use the master function for the function body. */
902 ns
->proc_name
= proc
;
904 /* Finalize the new symbols. */
905 gfc_commit_symbols ();
907 /* Restore the original namespace. */
908 gfc_current_ns
= old_ns
;
912 /* Resolve common variables. */
914 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
916 gfc_symbol
*csym
= common_block
->head
;
918 for (; csym
; csym
= csym
->common_next
)
920 /* gfc_add_in_common may have been called before, but the reported errors
921 have been ignored to continue parsing.
922 We do the checks again here. */
923 if (!csym
->attr
.use_assoc
)
924 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
926 if (csym
->value
|| csym
->attr
.data
)
928 if (!csym
->ns
->is_block_data
)
929 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
930 "but only in BLOCK DATA initialization is "
931 "allowed", csym
->name
, &csym
->declared_at
);
932 else if (!named_common
)
933 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
934 "in a blank COMMON but initialization is only "
935 "allowed in named common blocks", csym
->name
,
939 if (UNLIMITED_POLY (csym
))
940 gfc_error_now ("%qs in cannot appear in COMMON at %L "
941 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
943 if (csym
->ts
.type
!= BT_DERIVED
)
946 if (!(csym
->ts
.u
.derived
->attr
.sequence
947 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
948 gfc_error_now ("Derived type variable %qs in COMMON at %L "
949 "has neither the SEQUENCE nor the BIND(C) "
950 "attribute", csym
->name
, &csym
->declared_at
);
951 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
952 gfc_error_now ("Derived type variable %qs in COMMON at %L "
953 "has an ultimate component that is "
954 "allocatable", csym
->name
, &csym
->declared_at
);
955 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
956 gfc_error_now ("Derived type variable %qs in COMMON at %L "
957 "may not have default initializer", csym
->name
,
960 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
961 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
965 /* Resolve common blocks. */
967 resolve_common_blocks (gfc_symtree
*common_root
)
972 if (common_root
== NULL
)
975 if (common_root
->left
)
976 resolve_common_blocks (common_root
->left
);
977 if (common_root
->right
)
978 resolve_common_blocks (common_root
->right
);
980 resolve_common_vars (common_root
->n
.common
, true);
982 /* The common name is a global name - in Fortran 2003 also if it has a
983 C binding name, since Fortran 2008 only the C binding name is a global
985 if (!common_root
->n
.common
->binding_label
986 || gfc_notification_std (GFC_STD_F2008
))
988 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
989 common_root
->n
.common
->name
);
991 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
992 && gsym
->type
== GSYM_COMMON
993 && ((common_root
->n
.common
->binding_label
994 && (!gsym
->binding_label
995 || strcmp (common_root
->n
.common
->binding_label
,
996 gsym
->binding_label
) != 0))
997 || (!common_root
->n
.common
->binding_label
998 && gsym
->binding_label
)))
1000 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1001 "identifier and must thus have the same binding name "
1002 "as the same-named COMMON block at %L: %s vs %s",
1003 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1005 common_root
->n
.common
->binding_label
1006 ? common_root
->n
.common
->binding_label
: "(blank)",
1007 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1011 if (gsym
&& gsym
->type
!= GSYM_COMMON
1012 && !common_root
->n
.common
->binding_label
)
1014 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1016 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1020 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1022 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1023 "%L sharing the identifier with global non-COMMON-block "
1024 "entity at %L", common_root
->n
.common
->name
,
1025 &common_root
->n
.common
->where
, &gsym
->where
);
1030 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1031 gsym
->type
= GSYM_COMMON
;
1032 gsym
->where
= common_root
->n
.common
->where
;
1038 if (common_root
->n
.common
->binding_label
)
1040 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1041 common_root
->n
.common
->binding_label
);
1042 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1044 gfc_error ("COMMON block at %L with binding label %s uses the same "
1045 "global identifier as entity at %L",
1046 &common_root
->n
.common
->where
,
1047 common_root
->n
.common
->binding_label
, &gsym
->where
);
1052 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1053 gsym
->type
= GSYM_COMMON
;
1054 gsym
->where
= common_root
->n
.common
->where
;
1060 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1064 if (sym
->attr
.flavor
== FL_PARAMETER
)
1065 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1066 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1068 if (sym
->attr
.external
)
1069 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1070 sym
->name
, &common_root
->n
.common
->where
);
1072 if (sym
->attr
.intrinsic
)
1073 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1074 sym
->name
, &common_root
->n
.common
->where
);
1075 else if (sym
->attr
.result
1076 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1077 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1078 "that is also a function result", sym
->name
,
1079 &common_root
->n
.common
->where
);
1080 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1081 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1082 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1083 "that is also a global procedure", sym
->name
,
1084 &common_root
->n
.common
->where
);
1088 /* Resolve contained function types. Because contained functions can call one
1089 another, they have to be worked out before any of the contained procedures
1092 The good news is that if a function doesn't already have a type, the only
1093 way it can get one is through an IMPLICIT type or a RESULT variable, because
1094 by definition contained functions are contained namespace they're contained
1095 in, not in a sibling or parent namespace. */
1098 resolve_contained_functions (gfc_namespace
*ns
)
1100 gfc_namespace
*child
;
1103 resolve_formal_arglists (ns
);
1105 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1107 /* Resolve alternate entry points first. */
1108 resolve_entries (child
);
1110 /* Then check function return types. */
1111 resolve_contained_fntype (child
->proc_name
, child
);
1112 for (el
= child
->entries
; el
; el
= el
->next
)
1113 resolve_contained_fntype (el
->sym
, child
);
1118 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1119 static bool resolve_fl_struct (gfc_symbol
*sym
);
1122 /* Resolve all of the elements of a structure constructor and make sure that
1123 the types are correct. The 'init' flag indicates that the given
1124 constructor is an initializer. */
1127 resolve_structure_cons (gfc_expr
*expr
, int init
)
1129 gfc_constructor
*cons
;
1130 gfc_component
*comp
;
1136 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1138 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1139 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1141 resolve_fl_struct (expr
->ts
.u
.derived
);
1144 cons
= gfc_constructor_first (expr
->value
.constructor
);
1146 /* A constructor may have references if it is the result of substituting a
1147 parameter variable. In this case we just pull out the component we
1150 comp
= expr
->ref
->u
.c
.sym
->components
;
1152 comp
= expr
->ts
.u
.derived
->components
;
1154 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1161 if (!gfc_resolve_expr (cons
->expr
))
1167 rank
= comp
->as
? comp
->as
->rank
: 0;
1168 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1169 rank
= CLASS_DATA (comp
)->as
->rank
;
1171 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1172 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1174 gfc_error ("The rank of the element in the structure "
1175 "constructor at %L does not match that of the "
1176 "component (%d/%d)", &cons
->expr
->where
,
1177 cons
->expr
->rank
, rank
);
1181 /* If we don't have the right type, try to convert it. */
1183 if (!comp
->attr
.proc_pointer
&&
1184 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1186 if (strcmp (comp
->name
, "_extends") == 0)
1188 /* Can afford to be brutal with the _extends initializer.
1189 The derived type can get lost because it is PRIVATE
1190 but it is not usage constrained by the standard. */
1191 cons
->expr
->ts
= comp
->ts
;
1193 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1195 gfc_error ("The element in the structure constructor at %L, "
1196 "for pointer component %qs, is %s but should be %s",
1197 &cons
->expr
->where
, comp
->name
,
1198 gfc_basic_typename (cons
->expr
->ts
.type
),
1199 gfc_basic_typename (comp
->ts
.type
));
1204 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1210 /* For strings, the length of the constructor should be the same as
1211 the one of the structure, ensure this if the lengths are known at
1212 compile time and when we are dealing with PARAMETER or structure
1214 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1215 && comp
->ts
.u
.cl
->length
1216 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1217 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1218 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1219 && cons
->expr
->rank
!= 0
1220 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1221 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1223 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1224 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1226 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1227 to make use of the gfc_resolve_character_array_constructor
1228 machinery. The expression is later simplified away to
1229 an array of string literals. */
1230 gfc_expr
*para
= cons
->expr
;
1231 cons
->expr
= gfc_get_expr ();
1232 cons
->expr
->ts
= para
->ts
;
1233 cons
->expr
->where
= para
->where
;
1234 cons
->expr
->expr_type
= EXPR_ARRAY
;
1235 cons
->expr
->rank
= para
->rank
;
1236 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1237 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1238 para
, &cons
->expr
->where
);
1240 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1243 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1244 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1246 gfc_charlen
*cl
, *cl2
;
1249 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1251 if (cl
== cons
->expr
->ts
.u
.cl
)
1259 cl2
->next
= cl
->next
;
1261 gfc_free_expr (cl
->length
);
1265 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1266 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1267 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1268 gfc_resolve_character_array_constructor (cons
->expr
);
1272 if (cons
->expr
->expr_type
== EXPR_NULL
1273 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1274 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1275 || (comp
->ts
.type
== BT_CLASS
1276 && (CLASS_DATA (comp
)->attr
.class_pointer
1277 || CLASS_DATA (comp
)->attr
.allocatable
))))
1280 gfc_error ("The NULL in the structure constructor at %L is "
1281 "being applied to component %qs, which is neither "
1282 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1286 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1288 /* Check procedure pointer interface. */
1289 gfc_symbol
*s2
= NULL
;
1294 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1297 s2
= c2
->ts
.interface
;
1300 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1302 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1303 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1305 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1307 s2
= cons
->expr
->symtree
->n
.sym
;
1308 name
= cons
->expr
->symtree
->n
.sym
->name
;
1311 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1312 err
, sizeof (err
), NULL
, NULL
))
1314 gfc_error ("Interface mismatch for procedure-pointer component "
1315 "%qs in structure constructor at %L: %s",
1316 comp
->name
, &cons
->expr
->where
, err
);
1321 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1322 || cons
->expr
->expr_type
== EXPR_NULL
)
1325 a
= gfc_expr_attr (cons
->expr
);
1327 if (!a
.pointer
&& !a
.target
)
1330 gfc_error ("The element in the structure constructor at %L, "
1331 "for pointer component %qs should be a POINTER or "
1332 "a TARGET", &cons
->expr
->where
, comp
->name
);
1337 /* F08:C461. Additional checks for pointer initialization. */
1341 gfc_error ("Pointer initialization target at %L "
1342 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1347 gfc_error ("Pointer initialization target at %L "
1348 "must have the SAVE attribute", &cons
->expr
->where
);
1352 /* F2003, C1272 (3). */
1353 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1354 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1355 || gfc_is_coindexed (cons
->expr
));
1356 if (impure
&& gfc_pure (NULL
))
1359 gfc_error ("Invalid expression in the structure constructor for "
1360 "pointer component %qs at %L in PURE procedure",
1361 comp
->name
, &cons
->expr
->where
);
1365 gfc_unset_implicit_pure (NULL
);
1372 /****************** Expression name resolution ******************/
1374 /* Returns 0 if a symbol was not declared with a type or
1375 attribute declaration statement, nonzero otherwise. */
1378 was_declared (gfc_symbol
*sym
)
1384 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1387 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1388 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1389 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1390 || a
.asynchronous
|| a
.codimension
)
1397 /* Determine if a symbol is generic or not. */
1400 generic_sym (gfc_symbol
*sym
)
1404 if (sym
->attr
.generic
||
1405 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1408 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1411 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1418 return generic_sym (s
);
1425 /* Determine if a symbol is specific or not. */
1428 specific_sym (gfc_symbol
*sym
)
1432 if (sym
->attr
.if_source
== IFSRC_IFBODY
1433 || sym
->attr
.proc
== PROC_MODULE
1434 || sym
->attr
.proc
== PROC_INTERNAL
1435 || sym
->attr
.proc
== PROC_ST_FUNCTION
1436 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1437 || sym
->attr
.external
)
1440 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1443 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1445 return (s
== NULL
) ? 0 : specific_sym (s
);
1449 /* Figure out if the procedure is specific, generic or unknown. */
1452 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1455 procedure_kind (gfc_symbol
*sym
)
1457 if (generic_sym (sym
))
1458 return PTYPE_GENERIC
;
1460 if (specific_sym (sym
))
1461 return PTYPE_SPECIFIC
;
1463 return PTYPE_UNKNOWN
;
1466 /* Check references to assumed size arrays. The flag need_full_assumed_size
1467 is nonzero when matching actual arguments. */
1469 static int need_full_assumed_size
= 0;
1472 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1474 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1477 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1478 What should it be? */
1479 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1480 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1481 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1483 gfc_error ("The upper bound in the last dimension must "
1484 "appear in the reference to the assumed size "
1485 "array %qs at %L", sym
->name
, &e
->where
);
1492 /* Look for bad assumed size array references in argument expressions
1493 of elemental and array valued intrinsic procedures. Since this is
1494 called from procedure resolution functions, it only recurses at
1498 resolve_assumed_size_actual (gfc_expr
*e
)
1503 switch (e
->expr_type
)
1506 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1511 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1512 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1523 /* Check a generic procedure, passed as an actual argument, to see if
1524 there is a matching specific name. If none, it is an error, and if
1525 more than one, the reference is ambiguous. */
1527 count_specific_procs (gfc_expr
*e
)
1534 sym
= e
->symtree
->n
.sym
;
1536 for (p
= sym
->generic
; p
; p
= p
->next
)
1537 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1539 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1545 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1549 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1550 "argument at %L", sym
->name
, &e
->where
);
1556 /* See if a call to sym could possibly be a not allowed RECURSION because of
1557 a missing RECURSIVE declaration. This means that either sym is the current
1558 context itself, or sym is the parent of a contained procedure calling its
1559 non-RECURSIVE containing procedure.
1560 This also works if sym is an ENTRY. */
1563 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1565 gfc_symbol
* proc_sym
;
1566 gfc_symbol
* context_proc
;
1567 gfc_namespace
* real_context
;
1569 if (sym
->attr
.flavor
== FL_PROGRAM
1570 || gfc_fl_struct (sym
->attr
.flavor
))
1573 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1575 /* If we've got an ENTRY, find real procedure. */
1576 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1577 proc_sym
= sym
->ns
->entries
->sym
;
1581 /* If sym is RECURSIVE, all is well of course. */
1582 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1585 /* Find the context procedure's "real" symbol if it has entries.
1586 We look for a procedure symbol, so recurse on the parents if we don't
1587 find one (like in case of a BLOCK construct). */
1588 for (real_context
= context
; ; real_context
= real_context
->parent
)
1590 /* We should find something, eventually! */
1591 gcc_assert (real_context
);
1593 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1594 : real_context
->proc_name
);
1596 /* In some special cases, there may not be a proc_name, like for this
1598 real(bad_kind()) function foo () ...
1599 when checking the call to bad_kind ().
1600 In these cases, we simply return here and assume that the
1605 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1609 /* A call from sym's body to itself is recursion, of course. */
1610 if (context_proc
== proc_sym
)
1613 /* The same is true if context is a contained procedure and sym the
1615 if (context_proc
->attr
.contained
)
1617 gfc_symbol
* parent_proc
;
1619 gcc_assert (context
->parent
);
1620 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1621 : context
->parent
->proc_name
);
1623 if (parent_proc
== proc_sym
)
1631 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1632 its typespec and formal argument list. */
1635 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1637 gfc_intrinsic_sym
* isym
= NULL
;
1643 /* Already resolved. */
1644 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1647 /* We already know this one is an intrinsic, so we don't call
1648 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1649 gfc_find_subroutine directly to check whether it is a function or
1652 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1654 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1655 isym
= gfc_intrinsic_subroutine_by_id (id
);
1657 else if (sym
->intmod_sym_id
)
1659 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1660 isym
= gfc_intrinsic_function_by_id (id
);
1662 else if (!sym
->attr
.subroutine
)
1663 isym
= gfc_find_function (sym
->name
);
1665 if (isym
&& !sym
->attr
.subroutine
)
1667 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1668 && !sym
->attr
.implicit_type
)
1669 gfc_warning (OPT_Wsurprising
,
1670 "Type specified for intrinsic function %qs at %L is"
1671 " ignored", sym
->name
, &sym
->declared_at
);
1673 if (!sym
->attr
.function
&&
1674 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1679 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1681 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1683 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1684 " specifier", sym
->name
, &sym
->declared_at
);
1688 if (!sym
->attr
.subroutine
&&
1689 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1694 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1699 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1701 sym
->attr
.pure
= isym
->pure
;
1702 sym
->attr
.elemental
= isym
->elemental
;
1704 /* Check it is actually available in the standard settings. */
1705 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1707 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1708 "available in the current standard settings but %s. Use "
1709 "an appropriate %<-std=*%> option or enable "
1710 "%<-fall-intrinsics%> in order to use it.",
1711 sym
->name
, &sym
->declared_at
, symstd
);
1719 /* Resolve a procedure expression, like passing it to a called procedure or as
1720 RHS for a procedure pointer assignment. */
1723 resolve_procedure_expression (gfc_expr
* expr
)
1727 if (expr
->expr_type
!= EXPR_VARIABLE
)
1729 gcc_assert (expr
->symtree
);
1731 sym
= expr
->symtree
->n
.sym
;
1733 if (sym
->attr
.intrinsic
)
1734 gfc_resolve_intrinsic (sym
, &expr
->where
);
1736 if (sym
->attr
.flavor
!= FL_PROCEDURE
1737 || (sym
->attr
.function
&& sym
->result
== sym
))
1740 /* A non-RECURSIVE procedure that is used as procedure expression within its
1741 own body is in danger of being called recursively. */
1742 if (is_illegal_recursion (sym
, gfc_current_ns
))
1743 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1744 " itself recursively. Declare it RECURSIVE or use"
1745 " %<-frecursive%>", sym
->name
, &expr
->where
);
1751 /* Resolve an actual argument list. Most of the time, this is just
1752 resolving the expressions in the list.
1753 The exception is that we sometimes have to decide whether arguments
1754 that look like procedure arguments are really simple variable
1758 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1759 bool no_formal_args
)
1762 gfc_symtree
*parent_st
;
1764 gfc_component
*comp
;
1765 int save_need_full_assumed_size
;
1766 bool return_value
= false;
1767 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1770 first_actual_arg
= true;
1772 for (; arg
; arg
= arg
->next
)
1777 /* Check the label is a valid branching target. */
1780 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1782 gfc_error ("Label %d referenced at %L is never defined",
1783 arg
->label
->value
, &arg
->label
->where
);
1787 first_actual_arg
= false;
1791 if (e
->expr_type
== EXPR_VARIABLE
1792 && e
->symtree
->n
.sym
->attr
.generic
1794 && count_specific_procs (e
) != 1)
1797 if (e
->ts
.type
!= BT_PROCEDURE
)
1799 save_need_full_assumed_size
= need_full_assumed_size
;
1800 if (e
->expr_type
!= EXPR_VARIABLE
)
1801 need_full_assumed_size
= 0;
1802 if (!gfc_resolve_expr (e
))
1804 need_full_assumed_size
= save_need_full_assumed_size
;
1808 /* See if the expression node should really be a variable reference. */
1810 sym
= e
->symtree
->n
.sym
;
1812 if (sym
->attr
.flavor
== FL_PROCEDURE
1813 || sym
->attr
.intrinsic
1814 || sym
->attr
.external
)
1818 /* If a procedure is not already determined to be something else
1819 check if it is intrinsic. */
1820 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1821 sym
->attr
.intrinsic
= 1;
1823 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1825 gfc_error ("Statement function %qs at %L is not allowed as an "
1826 "actual argument", sym
->name
, &e
->where
);
1829 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1830 sym
->attr
.subroutine
);
1831 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1833 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1834 "actual argument", sym
->name
, &e
->where
);
1837 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1838 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1840 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1841 " used as actual argument at %L",
1842 sym
->name
, &e
->where
))
1846 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1848 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1849 "allowed as an actual argument at %L", sym
->name
,
1853 /* Check if a generic interface has a specific procedure
1854 with the same name before emitting an error. */
1855 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1858 /* Just in case a specific was found for the expression. */
1859 sym
= e
->symtree
->n
.sym
;
1861 /* If the symbol is the function that names the current (or
1862 parent) scope, then we really have a variable reference. */
1864 if (gfc_is_function_return_value (sym
, sym
->ns
))
1867 /* If all else fails, see if we have a specific intrinsic. */
1868 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1870 gfc_intrinsic_sym
*isym
;
1872 isym
= gfc_find_function (sym
->name
);
1873 if (isym
== NULL
|| !isym
->specific
)
1875 gfc_error ("Unable to find a specific INTRINSIC procedure "
1876 "for the reference %qs at %L", sym
->name
,
1881 sym
->attr
.intrinsic
= 1;
1882 sym
->attr
.function
= 1;
1885 if (!gfc_resolve_expr (e
))
1890 /* See if the name is a module procedure in a parent unit. */
1892 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1895 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1897 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1901 if (parent_st
== NULL
)
1904 sym
= parent_st
->n
.sym
;
1905 e
->symtree
= parent_st
; /* Point to the right thing. */
1907 if (sym
->attr
.flavor
== FL_PROCEDURE
1908 || sym
->attr
.intrinsic
1909 || sym
->attr
.external
)
1911 if (!gfc_resolve_expr (e
))
1917 e
->expr_type
= EXPR_VARIABLE
;
1919 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1920 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1921 && CLASS_DATA (sym
)->as
))
1923 e
->rank
= sym
->ts
.type
== BT_CLASS
1924 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1925 e
->ref
= gfc_get_ref ();
1926 e
->ref
->type
= REF_ARRAY
;
1927 e
->ref
->u
.ar
.type
= AR_FULL
;
1928 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1929 ? CLASS_DATA (sym
)->as
: sym
->as
;
1932 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1933 primary.c (match_actual_arg). If above code determines that it
1934 is a variable instead, it needs to be resolved as it was not
1935 done at the beginning of this function. */
1936 save_need_full_assumed_size
= need_full_assumed_size
;
1937 if (e
->expr_type
!= EXPR_VARIABLE
)
1938 need_full_assumed_size
= 0;
1939 if (!gfc_resolve_expr (e
))
1941 need_full_assumed_size
= save_need_full_assumed_size
;
1944 /* Check argument list functions %VAL, %LOC and %REF. There is
1945 nothing to do for %REF. */
1946 if (arg
->name
&& arg
->name
[0] == '%')
1948 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1950 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1952 gfc_error ("By-value argument at %L is not of numeric "
1959 gfc_error ("By-value argument at %L cannot be an array or "
1960 "an array section", &e
->where
);
1964 /* Intrinsics are still PROC_UNKNOWN here. However,
1965 since same file external procedures are not resolvable
1966 in gfortran, it is a good deal easier to leave them to
1968 if (ptype
!= PROC_UNKNOWN
1969 && ptype
!= PROC_DUMMY
1970 && ptype
!= PROC_EXTERNAL
1971 && ptype
!= PROC_MODULE
)
1973 gfc_error ("By-value argument at %L is not allowed "
1974 "in this context", &e
->where
);
1979 /* Statement functions have already been excluded above. */
1980 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1981 && e
->ts
.type
== BT_PROCEDURE
)
1983 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1985 gfc_error ("Passing internal procedure at %L by location "
1986 "not allowed", &e
->where
);
1992 comp
= gfc_get_proc_ptr_comp(e
);
1993 if (e
->expr_type
== EXPR_VARIABLE
1994 && comp
&& comp
->attr
.elemental
)
1996 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1997 "allowed as an actual argument at %L", comp
->name
,
2001 /* Fortran 2008, C1237. */
2002 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2003 && gfc_has_ultimate_pointer (e
))
2005 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2006 "component", &e
->where
);
2010 first_actual_arg
= false;
2013 return_value
= true;
2016 actual_arg
= actual_arg_sav
;
2017 first_actual_arg
= first_actual_arg_sav
;
2019 return return_value
;
2023 /* Do the checks of the actual argument list that are specific to elemental
2024 procedures. If called with c == NULL, we have a function, otherwise if
2025 expr == NULL, we have a subroutine. */
2028 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2030 gfc_actual_arglist
*arg0
;
2031 gfc_actual_arglist
*arg
;
2032 gfc_symbol
*esym
= NULL
;
2033 gfc_intrinsic_sym
*isym
= NULL
;
2035 gfc_intrinsic_arg
*iformal
= NULL
;
2036 gfc_formal_arglist
*eformal
= NULL
;
2037 bool formal_optional
= false;
2038 bool set_by_optional
= false;
2042 /* Is this an elemental procedure? */
2043 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2045 if (expr
->value
.function
.esym
!= NULL
2046 && expr
->value
.function
.esym
->attr
.elemental
)
2048 arg0
= expr
->value
.function
.actual
;
2049 esym
= expr
->value
.function
.esym
;
2051 else if (expr
->value
.function
.isym
!= NULL
2052 && expr
->value
.function
.isym
->elemental
)
2054 arg0
= expr
->value
.function
.actual
;
2055 isym
= expr
->value
.function
.isym
;
2060 else if (c
&& c
->ext
.actual
!= NULL
)
2062 arg0
= c
->ext
.actual
;
2064 if (c
->resolved_sym
)
2065 esym
= c
->resolved_sym
;
2067 esym
= c
->symtree
->n
.sym
;
2070 if (!esym
->attr
.elemental
)
2076 /* The rank of an elemental is the rank of its array argument(s). */
2077 for (arg
= arg0
; arg
; arg
= arg
->next
)
2079 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2081 rank
= arg
->expr
->rank
;
2082 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2083 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2084 set_by_optional
= true;
2086 /* Function specific; set the result rank and shape. */
2090 if (!expr
->shape
&& arg
->expr
->shape
)
2092 expr
->shape
= gfc_get_shape (rank
);
2093 for (i
= 0; i
< rank
; i
++)
2094 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2101 /* If it is an array, it shall not be supplied as an actual argument
2102 to an elemental procedure unless an array of the same rank is supplied
2103 as an actual argument corresponding to a nonoptional dummy argument of
2104 that elemental procedure(12.4.1.5). */
2105 formal_optional
= false;
2107 iformal
= isym
->formal
;
2109 eformal
= esym
->formal
;
2111 for (arg
= arg0
; arg
; arg
= arg
->next
)
2115 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2116 formal_optional
= true;
2117 eformal
= eformal
->next
;
2119 else if (isym
&& iformal
)
2121 if (iformal
->optional
)
2122 formal_optional
= true;
2123 iformal
= iformal
->next
;
2126 formal_optional
= true;
2128 if (pedantic
&& arg
->expr
!= NULL
2129 && arg
->expr
->expr_type
== EXPR_VARIABLE
2130 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2133 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2134 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2136 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2137 "MISSING, it cannot be the actual argument of an "
2138 "ELEMENTAL procedure unless there is a non-optional "
2139 "argument with the same rank (12.4.1.5)",
2140 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2144 for (arg
= arg0
; arg
; arg
= arg
->next
)
2146 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2149 /* Being elemental, the last upper bound of an assumed size array
2150 argument must be present. */
2151 if (resolve_assumed_size_actual (arg
->expr
))
2154 /* Elemental procedure's array actual arguments must conform. */
2157 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2164 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2165 is an array, the intent inout/out variable needs to be also an array. */
2166 if (rank
> 0 && esym
&& expr
== NULL
)
2167 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2168 arg
= arg
->next
, eformal
= eformal
->next
)
2169 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2170 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2171 && arg
->expr
&& arg
->expr
->rank
== 0)
2173 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2174 "ELEMENTAL subroutine %qs is a scalar, but another "
2175 "actual argument is an array", &arg
->expr
->where
,
2176 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2177 : "INOUT", eformal
->sym
->name
, esym
->name
);
2184 /* This function does the checking of references to global procedures
2185 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2186 77 and 95 standards. It checks for a gsymbol for the name, making
2187 one if it does not already exist. If it already exists, then the
2188 reference being resolved must correspond to the type of gsymbol.
2189 Otherwise, the new symbol is equipped with the attributes of the
2190 reference. The corresponding code that is called in creating
2191 global entities is parse.c.
2193 In addition, for all but -std=legacy, the gsymbols are used to
2194 check the interfaces of external procedures from the same file.
2195 The namespace of the gsymbol is resolved and then, once this is
2196 done the interface is checked. */
2200 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2202 if (!gsym_ns
->proc_name
->attr
.recursive
)
2205 if (sym
->ns
== gsym_ns
)
2208 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2215 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2217 if (gsym_ns
->entries
)
2219 gfc_entry_list
*entry
= gsym_ns
->entries
;
2221 for (; entry
; entry
= entry
->next
)
2223 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2225 if (strcmp (gsym_ns
->proc_name
->name
,
2226 sym
->ns
->proc_name
->name
) == 0)
2230 && strcmp (gsym_ns
->proc_name
->name
,
2231 sym
->ns
->parent
->proc_name
->name
) == 0)
2240 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2243 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2245 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2247 for ( ; arg
; arg
= arg
->next
)
2252 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2254 strncpy (errmsg
, _("allocatable argument"), err_len
);
2257 else if (arg
->sym
->attr
.asynchronous
)
2259 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2262 else if (arg
->sym
->attr
.optional
)
2264 strncpy (errmsg
, _("optional argument"), err_len
);
2267 else if (arg
->sym
->attr
.pointer
)
2269 strncpy (errmsg
, _("pointer argument"), err_len
);
2272 else if (arg
->sym
->attr
.target
)
2274 strncpy (errmsg
, _("target argument"), err_len
);
2277 else if (arg
->sym
->attr
.value
)
2279 strncpy (errmsg
, _("value argument"), err_len
);
2282 else if (arg
->sym
->attr
.volatile_
)
2284 strncpy (errmsg
, _("volatile argument"), err_len
);
2287 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2289 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2292 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2294 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2297 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2299 strncpy (errmsg
, _("coarray argument"), err_len
);
2302 else if (false) /* (2d) TODO: parametrized derived type */
2304 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2307 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2309 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2312 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2314 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2317 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2319 /* As assumed-type is unlimited polymorphic (cf. above).
2320 See also TS 29113, Note 6.1. */
2321 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2326 if (sym
->attr
.function
)
2328 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2330 if (res
->attr
.dimension
) /* (3a) */
2332 strncpy (errmsg
, _("array result"), err_len
);
2335 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2337 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2340 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2341 && res
->ts
.u
.cl
->length
2342 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2344 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2349 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2351 strncpy (errmsg
, _("elemental procedure"), err_len
);
2354 else if (sym
->attr
.is_bind_c
) /* (5) */
2356 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2365 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2366 gfc_actual_arglist
**actual
, int sub
)
2370 enum gfc_symbol_type type
;
2373 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2375 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2377 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2378 gfc_global_used (gsym
, where
);
2380 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2381 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2382 && gsym
->type
!= GSYM_UNKNOWN
2383 && !gsym
->binding_label
2385 && gsym
->ns
->resolved
!= -1
2386 && gsym
->ns
->proc_name
2387 && not_in_recursive (sym
, gsym
->ns
)
2388 && not_entry_self_reference (sym
, gsym
->ns
))
2390 gfc_symbol
*def_sym
;
2392 /* Resolve the gsymbol namespace if needed. */
2393 if (!gsym
->ns
->resolved
)
2395 gfc_dt_list
*old_dt_list
;
2397 /* Stash away derived types so that the backend_decls do not
2399 old_dt_list
= gfc_derived_types
;
2400 gfc_derived_types
= NULL
;
2402 gfc_resolve (gsym
->ns
);
2404 /* Store the new derived types with the global namespace. */
2405 if (gfc_derived_types
)
2406 gsym
->ns
->derived_types
= gfc_derived_types
;
2408 /* Restore the derived types of this namespace. */
2409 gfc_derived_types
= old_dt_list
;
2412 /* Make sure that translation for the gsymbol occurs before
2413 the procedure currently being resolved. */
2414 ns
= gfc_global_ns_list
;
2415 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2417 if (ns
->sibling
== gsym
->ns
)
2419 ns
->sibling
= gsym
->ns
->sibling
;
2420 gsym
->ns
->sibling
= gfc_global_ns_list
;
2421 gfc_global_ns_list
= gsym
->ns
;
2426 def_sym
= gsym
->ns
->proc_name
;
2428 /* This can happen if a binding name has been specified. */
2429 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2430 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2432 if (def_sym
->attr
.entry_master
)
2434 gfc_entry_list
*entry
;
2435 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2436 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2438 def_sym
= entry
->sym
;
2443 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2445 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2446 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2447 gfc_typename (&def_sym
->ts
));
2451 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2452 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2454 gfc_error ("Explicit interface required for %qs at %L: %s",
2455 sym
->name
, &sym
->declared_at
, reason
);
2459 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2460 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2461 gfc_errors_to_warnings (true);
2463 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2464 reason
, sizeof(reason
), NULL
, NULL
))
2466 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2467 sym
->name
, &sym
->declared_at
, reason
);
2472 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2473 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2474 gfc_errors_to_warnings (true);
2476 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2477 gfc_procedure_use (def_sym
, actual
, where
);
2481 gfc_errors_to_warnings (false);
2483 if (gsym
->type
== GSYM_UNKNOWN
)
2486 gsym
->where
= *where
;
2493 /************* Function resolution *************/
2495 /* Resolve a function call known to be generic.
2496 Section 14.1.2.4.1. */
2499 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2503 if (sym
->attr
.generic
)
2505 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2508 expr
->value
.function
.name
= s
->name
;
2509 expr
->value
.function
.esym
= s
;
2511 if (s
->ts
.type
!= BT_UNKNOWN
)
2513 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2514 expr
->ts
= s
->result
->ts
;
2517 expr
->rank
= s
->as
->rank
;
2518 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2519 expr
->rank
= s
->result
->as
->rank
;
2521 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2526 /* TODO: Need to search for elemental references in generic
2530 if (sym
->attr
.intrinsic
)
2531 return gfc_intrinsic_func_interface (expr
, 0);
2538 resolve_generic_f (gfc_expr
*expr
)
2542 gfc_interface
*intr
= NULL
;
2544 sym
= expr
->symtree
->n
.sym
;
2548 m
= resolve_generic_f0 (expr
, sym
);
2551 else if (m
== MATCH_ERROR
)
2556 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2557 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2560 if (sym
->ns
->parent
== NULL
)
2562 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2566 if (!generic_sym (sym
))
2570 /* Last ditch attempt. See if the reference is to an intrinsic
2571 that possesses a matching interface. 14.1.2.4 */
2572 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2574 if (gfc_init_expr_flag
)
2575 gfc_error ("Function %qs in initialization expression at %L "
2576 "must be an intrinsic function",
2577 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2579 gfc_error ("There is no specific function for the generic %qs "
2580 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2586 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2589 return resolve_structure_cons (expr
, 0);
2592 m
= gfc_intrinsic_func_interface (expr
, 0);
2597 gfc_error ("Generic function %qs at %L is not consistent with a "
2598 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2605 /* Resolve a function call known to be specific. */
2608 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2612 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2614 if (sym
->attr
.dummy
)
2616 sym
->attr
.proc
= PROC_DUMMY
;
2620 sym
->attr
.proc
= PROC_EXTERNAL
;
2624 if (sym
->attr
.proc
== PROC_MODULE
2625 || sym
->attr
.proc
== PROC_ST_FUNCTION
2626 || sym
->attr
.proc
== PROC_INTERNAL
)
2629 if (sym
->attr
.intrinsic
)
2631 m
= gfc_intrinsic_func_interface (expr
, 1);
2635 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2636 "with an intrinsic", sym
->name
, &expr
->where
);
2644 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2647 expr
->ts
= sym
->result
->ts
;
2650 expr
->value
.function
.name
= sym
->name
;
2651 expr
->value
.function
.esym
= sym
;
2652 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2654 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2656 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2657 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2658 else if (sym
->as
!= NULL
)
2659 expr
->rank
= sym
->as
->rank
;
2666 resolve_specific_f (gfc_expr
*expr
)
2671 sym
= expr
->symtree
->n
.sym
;
2675 m
= resolve_specific_f0 (sym
, expr
);
2678 if (m
== MATCH_ERROR
)
2681 if (sym
->ns
->parent
== NULL
)
2684 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2690 gfc_error ("Unable to resolve the specific function %qs at %L",
2691 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2697 /* Resolve a procedure call not known to be generic nor specific. */
2700 resolve_unknown_f (gfc_expr
*expr
)
2705 sym
= expr
->symtree
->n
.sym
;
2707 if (sym
->attr
.dummy
)
2709 sym
->attr
.proc
= PROC_DUMMY
;
2710 expr
->value
.function
.name
= sym
->name
;
2714 /* See if we have an intrinsic function reference. */
2716 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2718 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2723 /* The reference is to an external name. */
2725 sym
->attr
.proc
= PROC_EXTERNAL
;
2726 expr
->value
.function
.name
= sym
->name
;
2727 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2729 if (sym
->as
!= NULL
)
2730 expr
->rank
= sym
->as
->rank
;
2732 /* Type of the expression is either the type of the symbol or the
2733 default type of the symbol. */
2736 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2738 if (sym
->ts
.type
!= BT_UNKNOWN
)
2742 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2744 if (ts
->type
== BT_UNKNOWN
)
2746 gfc_error ("Function %qs at %L has no IMPLICIT type",
2747 sym
->name
, &expr
->where
);
2758 /* Return true, if the symbol is an external procedure. */
2760 is_external_proc (gfc_symbol
*sym
)
2762 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2763 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2764 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2765 && !sym
->attr
.proc_pointer
2766 && !sym
->attr
.use_assoc
2774 /* Figure out if a function reference is pure or not. Also set the name
2775 of the function for a potential error message. Return nonzero if the
2776 function is PURE, zero if not. */
2778 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2781 pure_function (gfc_expr
*e
, const char **name
)
2784 gfc_component
*comp
;
2788 if (e
->symtree
!= NULL
2789 && e
->symtree
->n
.sym
!= NULL
2790 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2791 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2793 comp
= gfc_get_proc_ptr_comp (e
);
2796 pure
= gfc_pure (comp
->ts
.interface
);
2799 else if (e
->value
.function
.esym
)
2801 pure
= gfc_pure (e
->value
.function
.esym
);
2802 *name
= e
->value
.function
.esym
->name
;
2804 else if (e
->value
.function
.isym
)
2806 pure
= e
->value
.function
.isym
->pure
2807 || e
->value
.function
.isym
->elemental
;
2808 *name
= e
->value
.function
.isym
->name
;
2812 /* Implicit functions are not pure. */
2814 *name
= e
->value
.function
.name
;
2822 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2823 int *f ATTRIBUTE_UNUSED
)
2827 /* Don't bother recursing into other statement functions
2828 since they will be checked individually for purity. */
2829 if (e
->expr_type
!= EXPR_FUNCTION
2831 || e
->symtree
->n
.sym
== sym
2832 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2835 return pure_function (e
, &name
) ? false : true;
2840 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2842 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2846 /* Check if an impure function is allowed in the current context. */
2848 static bool check_pure_function (gfc_expr
*e
)
2850 const char *name
= NULL
;
2851 if (!pure_function (e
, &name
) && name
)
2855 gfc_error ("Reference to impure function %qs at %L inside a "
2856 "FORALL %s", name
, &e
->where
,
2857 forall_flag
== 2 ? "mask" : "block");
2860 else if (gfc_do_concurrent_flag
)
2862 gfc_error ("Reference to impure function %qs at %L inside a "
2863 "DO CONCURRENT %s", name
, &e
->where
,
2864 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2867 else if (gfc_pure (NULL
))
2869 gfc_error ("Reference to impure function %qs at %L "
2870 "within a PURE procedure", name
, &e
->where
);
2873 gfc_unset_implicit_pure (NULL
);
2879 /* Update current procedure's array_outer_dependency flag, considering
2880 a call to procedure SYM. */
2883 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2885 /* Check to see if this is a sibling function that has not yet
2887 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2888 for (; sibling
; sibling
= sibling
->sibling
)
2890 if (sibling
->proc_name
== sym
)
2892 gfc_resolve (sibling
);
2897 /* If SYM has references to outer arrays, so has the procedure calling
2898 SYM. If SYM is a procedure pointer, we can assume the worst. */
2899 if (sym
->attr
.array_outer_dependency
2900 || sym
->attr
.proc_pointer
)
2901 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2905 /* Resolve a function call, which means resolving the arguments, then figuring
2906 out which entity the name refers to. */
2909 resolve_function (gfc_expr
*expr
)
2911 gfc_actual_arglist
*arg
;
2915 procedure_type p
= PROC_INTRINSIC
;
2916 bool no_formal_args
;
2920 sym
= expr
->symtree
->n
.sym
;
2922 /* If this is a procedure pointer component, it has already been resolved. */
2923 if (gfc_is_proc_ptr_comp (expr
))
2926 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
2928 if (sym
&& sym
->attr
.intrinsic
2929 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
2930 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
2933 if (sym
&& sym
->attr
.intrinsic
2934 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2937 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2939 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2943 /* If this ia a deferred TBP with an abstract interface (which may
2944 of course be referenced), expr->value.function.esym will be set. */
2945 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2947 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2948 sym
->name
, &expr
->where
);
2952 /* Switch off assumed size checking and do this again for certain kinds
2953 of procedure, once the procedure itself is resolved. */
2954 need_full_assumed_size
++;
2956 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2957 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2959 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2960 inquiry_argument
= true;
2961 no_formal_args
= sym
&& is_external_proc (sym
)
2962 && gfc_sym_get_dummy_args (sym
) == NULL
;
2964 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2967 inquiry_argument
= false;
2971 inquiry_argument
= false;
2973 /* Resume assumed_size checking. */
2974 need_full_assumed_size
--;
2976 /* If the procedure is external, check for usage. */
2977 if (sym
&& is_external_proc (sym
))
2978 resolve_global_procedure (sym
, &expr
->where
,
2979 &expr
->value
.function
.actual
, 0);
2981 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2983 && sym
->ts
.u
.cl
->length
== NULL
2985 && !sym
->ts
.deferred
2986 && expr
->value
.function
.esym
== NULL
2987 && !sym
->attr
.contained
)
2989 /* Internal procedures are taken care of in resolve_contained_fntype. */
2990 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2991 "be used at %L since it is not a dummy argument",
2992 sym
->name
, &expr
->where
);
2996 /* See if function is already resolved. */
2998 if (expr
->value
.function
.name
!= NULL
2999 || expr
->value
.function
.isym
!= NULL
)
3001 if (expr
->ts
.type
== BT_UNKNOWN
)
3007 /* Apply the rules of section 14.1.2. */
3009 switch (procedure_kind (sym
))
3012 t
= resolve_generic_f (expr
);
3015 case PTYPE_SPECIFIC
:
3016 t
= resolve_specific_f (expr
);
3020 t
= resolve_unknown_f (expr
);
3024 gfc_internal_error ("resolve_function(): bad function type");
3028 /* If the expression is still a function (it might have simplified),
3029 then we check to see if we are calling an elemental function. */
3031 if (expr
->expr_type
!= EXPR_FUNCTION
)
3034 temp
= need_full_assumed_size
;
3035 need_full_assumed_size
= 0;
3037 if (!resolve_elemental_actual (expr
, NULL
))
3040 if (omp_workshare_flag
3041 && expr
->value
.function
.esym
3042 && ! gfc_elemental (expr
->value
.function
.esym
))
3044 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3045 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3050 #define GENERIC_ID expr->value.function.isym->id
3051 else if (expr
->value
.function
.actual
!= NULL
3052 && expr
->value
.function
.isym
!= NULL
3053 && GENERIC_ID
!= GFC_ISYM_LBOUND
3054 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3055 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3056 && GENERIC_ID
!= GFC_ISYM_LEN
3057 && GENERIC_ID
!= GFC_ISYM_LOC
3058 && GENERIC_ID
!= GFC_ISYM_C_LOC
3059 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3061 /* Array intrinsics must also have the last upper bound of an
3062 assumed size array argument. UBOUND and SIZE have to be
3063 excluded from the check if the second argument is anything
3066 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3068 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3069 && arg
== expr
->value
.function
.actual
3070 && arg
->next
!= NULL
&& arg
->next
->expr
)
3072 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3075 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3078 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3083 if (arg
->expr
!= NULL
3084 && arg
->expr
->rank
> 0
3085 && resolve_assumed_size_actual (arg
->expr
))
3091 need_full_assumed_size
= temp
;
3093 if (!check_pure_function(expr
))
3096 /* Functions without the RECURSIVE attribution are not allowed to
3097 * call themselves. */
3098 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3101 esym
= expr
->value
.function
.esym
;
3103 if (is_illegal_recursion (esym
, gfc_current_ns
))
3105 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3106 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3107 " function %qs is not RECURSIVE",
3108 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3110 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3111 " is not RECURSIVE", esym
->name
, &expr
->where
);
3117 /* Character lengths of use associated functions may contains references to
3118 symbols not referenced from the current program unit otherwise. Make sure
3119 those symbols are marked as referenced. */
3121 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3122 && expr
->value
.function
.esym
->attr
.use_assoc
)
3124 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3127 /* Make sure that the expression has a typespec that works. */
3128 if (expr
->ts
.type
== BT_UNKNOWN
)
3130 if (expr
->symtree
->n
.sym
->result
3131 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3132 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3133 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3136 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3138 if (expr
->value
.function
.esym
)
3139 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3141 update_current_proc_array_outer_dependency (sym
);
3144 /* typebound procedure: Assume the worst. */
3145 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3151 /************* Subroutine resolution *************/
3154 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3161 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3165 else if (gfc_do_concurrent_flag
)
3167 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3171 else if (gfc_pure (NULL
))
3173 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3177 gfc_unset_implicit_pure (NULL
);
3183 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3187 if (sym
->attr
.generic
)
3189 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3192 c
->resolved_sym
= s
;
3193 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3198 /* TODO: Need to search for elemental references in generic interface. */
3201 if (sym
->attr
.intrinsic
)
3202 return gfc_intrinsic_sub_interface (c
, 0);
3209 resolve_generic_s (gfc_code
*c
)
3214 sym
= c
->symtree
->n
.sym
;
3218 m
= resolve_generic_s0 (c
, sym
);
3221 else if (m
== MATCH_ERROR
)
3225 if (sym
->ns
->parent
== NULL
)
3227 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3231 if (!generic_sym (sym
))
3235 /* Last ditch attempt. See if the reference is to an intrinsic
3236 that possesses a matching interface. 14.1.2.4 */
3237 sym
= c
->symtree
->n
.sym
;
3239 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3241 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3242 sym
->name
, &c
->loc
);
3246 m
= gfc_intrinsic_sub_interface (c
, 0);
3250 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3251 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3257 /* Resolve a subroutine call known to be specific. */
3260 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3264 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3266 if (sym
->attr
.dummy
)
3268 sym
->attr
.proc
= PROC_DUMMY
;
3272 sym
->attr
.proc
= PROC_EXTERNAL
;
3276 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3279 if (sym
->attr
.intrinsic
)
3281 m
= gfc_intrinsic_sub_interface (c
, 1);
3285 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3286 "with an intrinsic", sym
->name
, &c
->loc
);
3294 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3296 c
->resolved_sym
= sym
;
3297 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3305 resolve_specific_s (gfc_code
*c
)
3310 sym
= c
->symtree
->n
.sym
;
3314 m
= resolve_specific_s0 (c
, sym
);
3317 if (m
== MATCH_ERROR
)
3320 if (sym
->ns
->parent
== NULL
)
3323 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3329 sym
= c
->symtree
->n
.sym
;
3330 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3331 sym
->name
, &c
->loc
);
3337 /* Resolve a subroutine call not known to be generic nor specific. */
3340 resolve_unknown_s (gfc_code
*c
)
3344 sym
= c
->symtree
->n
.sym
;
3346 if (sym
->attr
.dummy
)
3348 sym
->attr
.proc
= PROC_DUMMY
;
3352 /* See if we have an intrinsic function reference. */
3354 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3356 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3361 /* The reference is to an external name. */
3364 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3366 c
->resolved_sym
= sym
;
3368 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3372 /* Resolve a subroutine call. Although it was tempting to use the same code
3373 for functions, subroutines and functions are stored differently and this
3374 makes things awkward. */
3377 resolve_call (gfc_code
*c
)
3380 procedure_type ptype
= PROC_INTRINSIC
;
3381 gfc_symbol
*csym
, *sym
;
3382 bool no_formal_args
;
3384 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3386 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3388 gfc_error ("%qs at %L has a type, which is not consistent with "
3389 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3393 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3396 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3397 sym
= st
? st
->n
.sym
: NULL
;
3398 if (sym
&& csym
!= sym
3399 && sym
->ns
== gfc_current_ns
3400 && sym
->attr
.flavor
== FL_PROCEDURE
3401 && sym
->attr
.contained
)
3404 if (csym
->attr
.generic
)
3405 c
->symtree
->n
.sym
= sym
;
3408 csym
= c
->symtree
->n
.sym
;
3412 /* If this ia a deferred TBP, c->expr1 will be set. */
3413 if (!c
->expr1
&& csym
)
3415 if (csym
->attr
.abstract
)
3417 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3418 csym
->name
, &c
->loc
);
3422 /* Subroutines without the RECURSIVE attribution are not allowed to
3424 if (is_illegal_recursion (csym
, gfc_current_ns
))
3426 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3427 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3428 "as subroutine %qs is not RECURSIVE",
3429 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3431 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3432 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3438 /* Switch off assumed size checking and do this again for certain kinds
3439 of procedure, once the procedure itself is resolved. */
3440 need_full_assumed_size
++;
3443 ptype
= csym
->attr
.proc
;
3445 no_formal_args
= csym
&& is_external_proc (csym
)
3446 && gfc_sym_get_dummy_args (csym
) == NULL
;
3447 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3450 /* Resume assumed_size checking. */
3451 need_full_assumed_size
--;
3453 /* If external, check for usage. */
3454 if (csym
&& is_external_proc (csym
))
3455 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3458 if (c
->resolved_sym
== NULL
)
3460 c
->resolved_isym
= NULL
;
3461 switch (procedure_kind (csym
))
3464 t
= resolve_generic_s (c
);
3467 case PTYPE_SPECIFIC
:
3468 t
= resolve_specific_s (c
);
3472 t
= resolve_unknown_s (c
);
3476 gfc_internal_error ("resolve_subroutine(): bad function type");
3480 /* Some checks of elemental subroutine actual arguments. */
3481 if (!resolve_elemental_actual (NULL
, c
))
3485 update_current_proc_array_outer_dependency (csym
);
3487 /* Typebound procedure: Assume the worst. */
3488 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3494 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3495 op1->shape and op2->shape are non-NULL return true if their shapes
3496 match. If both op1->shape and op2->shape are non-NULL return false
3497 if their shapes do not match. If either op1->shape or op2->shape is
3498 NULL, return true. */
3501 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3508 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3510 for (i
= 0; i
< op1
->rank
; i
++)
3512 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3514 gfc_error ("Shapes for operands at %L and %L are not conformable",
3515 &op1
->where
, &op2
->where
);
3526 /* Resolve an operator expression node. This can involve replacing the
3527 operation with a user defined function call. */
3530 resolve_operator (gfc_expr
*e
)
3532 gfc_expr
*op1
, *op2
;
3534 bool dual_locus_error
;
3537 /* Resolve all subnodes-- give them types. */
3539 switch (e
->value
.op
.op
)
3542 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3548 case INTRINSIC_UPLUS
:
3549 case INTRINSIC_UMINUS
:
3550 case INTRINSIC_PARENTHESES
:
3551 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3556 /* Typecheck the new node. */
3558 op1
= e
->value
.op
.op1
;
3559 op2
= e
->value
.op
.op2
;
3560 dual_locus_error
= false;
3562 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3563 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3565 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3569 switch (e
->value
.op
.op
)
3571 case INTRINSIC_UPLUS
:
3572 case INTRINSIC_UMINUS
:
3573 if (op1
->ts
.type
== BT_INTEGER
3574 || op1
->ts
.type
== BT_REAL
3575 || op1
->ts
.type
== BT_COMPLEX
)
3581 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3582 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3585 case INTRINSIC_PLUS
:
3586 case INTRINSIC_MINUS
:
3587 case INTRINSIC_TIMES
:
3588 case INTRINSIC_DIVIDE
:
3589 case INTRINSIC_POWER
:
3590 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3592 gfc_type_convert_binary (e
, 1);
3597 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3598 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3599 gfc_typename (&op2
->ts
));
3602 case INTRINSIC_CONCAT
:
3603 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3604 && op1
->ts
.kind
== op2
->ts
.kind
)
3606 e
->ts
.type
= BT_CHARACTER
;
3607 e
->ts
.kind
= op1
->ts
.kind
;
3612 _("Operands of string concatenation operator at %%L are %s/%s"),
3613 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3619 case INTRINSIC_NEQV
:
3620 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3622 e
->ts
.type
= BT_LOGICAL
;
3623 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3624 if (op1
->ts
.kind
< e
->ts
.kind
)
3625 gfc_convert_type (op1
, &e
->ts
, 2);
3626 else if (op2
->ts
.kind
< e
->ts
.kind
)
3627 gfc_convert_type (op2
, &e
->ts
, 2);
3631 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3632 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3633 gfc_typename (&op2
->ts
));
3638 if (op1
->ts
.type
== BT_LOGICAL
)
3640 e
->ts
.type
= BT_LOGICAL
;
3641 e
->ts
.kind
= op1
->ts
.kind
;
3645 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3646 gfc_typename (&op1
->ts
));
3650 case INTRINSIC_GT_OS
:
3652 case INTRINSIC_GE_OS
:
3654 case INTRINSIC_LT_OS
:
3656 case INTRINSIC_LE_OS
:
3657 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3659 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3666 case INTRINSIC_EQ_OS
:
3668 case INTRINSIC_NE_OS
:
3669 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3670 && op1
->ts
.kind
== op2
->ts
.kind
)
3672 e
->ts
.type
= BT_LOGICAL
;
3673 e
->ts
.kind
= gfc_default_logical_kind
;
3677 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3679 gfc_type_convert_binary (e
, 1);
3681 e
->ts
.type
= BT_LOGICAL
;
3682 e
->ts
.kind
= gfc_default_logical_kind
;
3684 if (warn_compare_reals
)
3686 gfc_intrinsic_op op
= e
->value
.op
.op
;
3688 /* Type conversion has made sure that the types of op1 and op2
3689 agree, so it is only necessary to check the first one. */
3690 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3691 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3692 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3696 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3697 msg
= "Equality comparison for %s at %L";
3699 msg
= "Inequality comparison for %s at %L";
3701 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3708 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3710 _("Logicals at %%L must be compared with %s instead of %s"),
3711 (e
->value
.op
.op
== INTRINSIC_EQ
3712 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3713 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3716 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
3717 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3718 gfc_typename (&op2
->ts
));
3722 case INTRINSIC_USER
:
3723 if (e
->value
.op
.uop
->op
== NULL
)
3724 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"),
3725 e
->value
.op
.uop
->name
);
3726 else if (op2
== NULL
)
3727 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
3728 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3731 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
3732 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3733 gfc_typename (&op2
->ts
));
3734 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3739 case INTRINSIC_PARENTHESES
:
3741 if (e
->ts
.type
== BT_CHARACTER
)
3742 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3746 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3749 /* Deal with arrayness of an operand through an operator. */
3753 switch (e
->value
.op
.op
)
3755 case INTRINSIC_PLUS
:
3756 case INTRINSIC_MINUS
:
3757 case INTRINSIC_TIMES
:
3758 case INTRINSIC_DIVIDE
:
3759 case INTRINSIC_POWER
:
3760 case INTRINSIC_CONCAT
:
3764 case INTRINSIC_NEQV
:
3766 case INTRINSIC_EQ_OS
:
3768 case INTRINSIC_NE_OS
:
3770 case INTRINSIC_GT_OS
:
3772 case INTRINSIC_GE_OS
:
3774 case INTRINSIC_LT_OS
:
3776 case INTRINSIC_LE_OS
:
3778 if (op1
->rank
== 0 && op2
->rank
== 0)
3781 if (op1
->rank
== 0 && op2
->rank
!= 0)
3783 e
->rank
= op2
->rank
;
3785 if (e
->shape
== NULL
)
3786 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3789 if (op1
->rank
!= 0 && op2
->rank
== 0)
3791 e
->rank
= op1
->rank
;
3793 if (e
->shape
== NULL
)
3794 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3797 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3799 if (op1
->rank
== op2
->rank
)
3801 e
->rank
= op1
->rank
;
3802 if (e
->shape
== NULL
)
3804 t
= compare_shapes (op1
, op2
);
3808 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3813 /* Allow higher level expressions to work. */
3816 /* Try user-defined operators, and otherwise throw an error. */
3817 dual_locus_error
= true;
3819 _("Inconsistent ranks for operator at %%L and %%L"));
3826 case INTRINSIC_PARENTHESES
:
3828 case INTRINSIC_UPLUS
:
3829 case INTRINSIC_UMINUS
:
3830 /* Simply copy arrayness attribute */
3831 e
->rank
= op1
->rank
;
3833 if (e
->shape
== NULL
)
3834 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3842 /* Attempt to simplify the expression. */
3845 t
= gfc_simplify_expr (e
, 0);
3846 /* Some calls do not succeed in simplification and return false
3847 even though there is no error; e.g. variable references to
3848 PARAMETER arrays. */
3849 if (!gfc_is_constant_expr (e
))
3857 match m
= gfc_extend_expr (e
);
3860 if (m
== MATCH_ERROR
)
3864 if (dual_locus_error
)
3865 gfc_error (msg
, &op1
->where
, &op2
->where
);
3867 gfc_error (msg
, &e
->where
);
3873 /************** Array resolution subroutines **************/
3876 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
3878 /* Compare two integer expressions. */
3880 static compare_result
3881 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3885 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3886 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3889 /* If either of the types isn't INTEGER, we must have
3890 raised an error earlier. */
3892 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3895 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3905 /* Compare an integer expression with an integer. */
3907 static compare_result
3908 compare_bound_int (gfc_expr
*a
, int b
)
3912 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3915 if (a
->ts
.type
!= BT_INTEGER
)
3916 gfc_internal_error ("compare_bound_int(): Bad expression");
3918 i
= mpz_cmp_si (a
->value
.integer
, b
);
3928 /* Compare an integer expression with a mpz_t. */
3930 static compare_result
3931 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3935 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3938 if (a
->ts
.type
!= BT_INTEGER
)
3939 gfc_internal_error ("compare_bound_int(): Bad expression");
3941 i
= mpz_cmp (a
->value
.integer
, b
);
3951 /* Compute the last value of a sequence given by a triplet.
3952 Return 0 if it wasn't able to compute the last value, or if the
3953 sequence if empty, and 1 otherwise. */
3956 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3957 gfc_expr
*stride
, mpz_t last
)
3961 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3962 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3963 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3966 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3967 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3970 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3972 if (compare_bound (start
, end
) == CMP_GT
)
3974 mpz_set (last
, end
->value
.integer
);
3978 if (compare_bound_int (stride
, 0) == CMP_GT
)
3980 /* Stride is positive */
3981 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3986 /* Stride is negative */
3987 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3992 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3993 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3994 mpz_sub (last
, end
->value
.integer
, rem
);
4001 /* Compare a single dimension of an array reference to the array
4005 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4009 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4011 gcc_assert (ar
->stride
[i
] == NULL
);
4012 /* This implies [*] as [*:] and [*:3] are not possible. */
4013 if (ar
->start
[i
] == NULL
)
4015 gcc_assert (ar
->end
[i
] == NULL
);
4020 /* Given start, end and stride values, calculate the minimum and
4021 maximum referenced indexes. */
4023 switch (ar
->dimen_type
[i
])
4026 case DIMEN_THIS_IMAGE
:
4031 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4034 gfc_warning (0, "Array reference at %L is out of bounds "
4035 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4036 mpz_get_si (ar
->start
[i
]->value
.integer
),
4037 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4039 gfc_warning (0, "Array reference at %L is out of bounds "
4040 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4041 mpz_get_si (ar
->start
[i
]->value
.integer
),
4042 mpz_get_si (as
->lower
[i
]->value
.integer
),
4046 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4049 gfc_warning (0, "Array reference at %L is out of bounds "
4050 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4051 mpz_get_si (ar
->start
[i
]->value
.integer
),
4052 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4054 gfc_warning (0, "Array reference at %L is out of bounds "
4055 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4056 mpz_get_si (ar
->start
[i
]->value
.integer
),
4057 mpz_get_si (as
->upper
[i
]->value
.integer
),
4066 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4067 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4069 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4071 /* Check for zero stride, which is not allowed. */
4072 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4074 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4078 /* if start == len || (stride > 0 && start < len)
4079 || (stride < 0 && start > len),
4080 then the array section contains at least one element. In this
4081 case, there is an out-of-bounds access if
4082 (start < lower || start > upper). */
4083 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4084 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4085 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4086 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4087 && comp_start_end
== CMP_GT
))
4089 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4091 gfc_warning (0, "Lower array reference at %L is out of bounds "
4092 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4093 mpz_get_si (AR_START
->value
.integer
),
4094 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4097 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4099 gfc_warning (0, "Lower array reference at %L is out of bounds "
4100 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4101 mpz_get_si (AR_START
->value
.integer
),
4102 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4107 /* If we can compute the highest index of the array section,
4108 then it also has to be between lower and upper. */
4109 mpz_init (last_value
);
4110 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4113 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4115 gfc_warning (0, "Upper array reference at %L is out of bounds "
4116 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4117 mpz_get_si (last_value
),
4118 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4119 mpz_clear (last_value
);
4122 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4124 gfc_warning (0, "Upper array reference at %L is out of bounds "
4125 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4126 mpz_get_si (last_value
),
4127 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4128 mpz_clear (last_value
);
4132 mpz_clear (last_value
);
4140 gfc_internal_error ("check_dimension(): Bad array reference");
4147 /* Compare an array reference with an array specification. */
4150 compare_spec_to_ref (gfc_array_ref
*ar
)
4157 /* TODO: Full array sections are only allowed as actual parameters. */
4158 if (as
->type
== AS_ASSUMED_SIZE
4159 && (/*ar->type == AR_FULL
4160 ||*/ (ar
->type
== AR_SECTION
4161 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4163 gfc_error ("Rightmost upper bound of assumed size array section "
4164 "not specified at %L", &ar
->where
);
4168 if (ar
->type
== AR_FULL
)
4171 if (as
->rank
!= ar
->dimen
)
4173 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4174 &ar
->where
, ar
->dimen
, as
->rank
);
4178 /* ar->codimen == 0 is a local array. */
4179 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4181 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4182 &ar
->where
, ar
->codimen
, as
->corank
);
4186 for (i
= 0; i
< as
->rank
; i
++)
4187 if (!check_dimension (i
, ar
, as
))
4190 /* Local access has no coarray spec. */
4191 if (ar
->codimen
!= 0)
4192 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4194 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4195 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4197 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4198 i
+ 1 - as
->rank
, &ar
->where
);
4201 if (!check_dimension (i
, ar
, as
))
4209 /* Resolve one part of an array index. */
4212 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4213 int force_index_integer_kind
)
4220 if (!gfc_resolve_expr (index
))
4223 if (check_scalar
&& index
->rank
!= 0)
4225 gfc_error ("Array index at %L must be scalar", &index
->where
);
4229 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4231 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4232 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4236 if (index
->ts
.type
== BT_REAL
)
4237 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4241 if ((index
->ts
.kind
!= gfc_index_integer_kind
4242 && force_index_integer_kind
)
4243 || index
->ts
.type
!= BT_INTEGER
)
4246 ts
.type
= BT_INTEGER
;
4247 ts
.kind
= gfc_index_integer_kind
;
4249 gfc_convert_type_warn (index
, &ts
, 2, 0);
4255 /* Resolve one part of an array index. */
4258 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4260 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4263 /* Resolve a dim argument to an intrinsic function. */
4266 gfc_resolve_dim_arg (gfc_expr
*dim
)
4271 if (!gfc_resolve_expr (dim
))
4276 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4281 if (dim
->ts
.type
!= BT_INTEGER
)
4283 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4287 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4292 ts
.type
= BT_INTEGER
;
4293 ts
.kind
= gfc_index_integer_kind
;
4295 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4301 /* Given an expression that contains array references, update those array
4302 references to point to the right array specifications. While this is
4303 filled in during matching, this information is difficult to save and load
4304 in a module, so we take care of it here.
4306 The idea here is that the original array reference comes from the
4307 base symbol. We traverse the list of reference structures, setting
4308 the stored reference to references. Component references can
4309 provide an additional array specification. */
4312 find_array_spec (gfc_expr
*e
)
4318 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4319 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4321 as
= e
->symtree
->n
.sym
->as
;
4323 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4328 gfc_internal_error ("find_array_spec(): Missing spec");
4335 c
= ref
->u
.c
.component
;
4336 if (c
->attr
.dimension
)
4339 gfc_internal_error ("find_array_spec(): unused as(1)");
4350 gfc_internal_error ("find_array_spec(): unused as(2)");
4354 /* Resolve an array reference. */
4357 resolve_array_ref (gfc_array_ref
*ar
)
4359 int i
, check_scalar
;
4362 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4364 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4366 /* Do not force gfc_index_integer_kind for the start. We can
4367 do fine with any integer kind. This avoids temporary arrays
4368 created for indexing with a vector. */
4369 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4371 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4373 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4378 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4382 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4386 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4387 if (e
->expr_type
== EXPR_VARIABLE
4388 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4389 ar
->start
[i
] = gfc_get_parentheses (e
);
4393 gfc_error ("Array index at %L is an array of rank %d",
4394 &ar
->c_where
[i
], e
->rank
);
4398 /* Fill in the upper bound, which may be lower than the
4399 specified one for something like a(2:10:5), which is
4400 identical to a(2:7:5). Only relevant for strides not equal
4401 to one. Don't try a division by zero. */
4402 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4403 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4404 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4405 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4409 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4411 if (ar
->end
[i
] == NULL
)
4414 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4416 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4418 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4419 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4421 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4432 if (ar
->type
== AR_FULL
)
4434 if (ar
->as
->rank
== 0)
4435 ar
->type
= AR_ELEMENT
;
4437 /* Make sure array is the same as array(:,:), this way
4438 we don't need to special case all the time. */
4439 ar
->dimen
= ar
->as
->rank
;
4440 for (i
= 0; i
< ar
->dimen
; i
++)
4442 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4444 gcc_assert (ar
->start
[i
] == NULL
);
4445 gcc_assert (ar
->end
[i
] == NULL
);
4446 gcc_assert (ar
->stride
[i
] == NULL
);
4450 /* If the reference type is unknown, figure out what kind it is. */
4452 if (ar
->type
== AR_UNKNOWN
)
4454 ar
->type
= AR_ELEMENT
;
4455 for (i
= 0; i
< ar
->dimen
; i
++)
4456 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4457 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4459 ar
->type
= AR_SECTION
;
4464 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4467 if (ar
->as
->corank
&& ar
->codimen
== 0)
4470 ar
->codimen
= ar
->as
->corank
;
4471 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4472 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4480 resolve_substring (gfc_ref
*ref
)
4482 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4484 if (ref
->u
.ss
.start
!= NULL
)
4486 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4489 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4491 gfc_error ("Substring start index at %L must be of type INTEGER",
4492 &ref
->u
.ss
.start
->where
);
4496 if (ref
->u
.ss
.start
->rank
!= 0)
4498 gfc_error ("Substring start index at %L must be scalar",
4499 &ref
->u
.ss
.start
->where
);
4503 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4504 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4505 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4507 gfc_error ("Substring start index at %L is less than one",
4508 &ref
->u
.ss
.start
->where
);
4513 if (ref
->u
.ss
.end
!= NULL
)
4515 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4518 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4520 gfc_error ("Substring end index at %L must be of type INTEGER",
4521 &ref
->u
.ss
.end
->where
);
4525 if (ref
->u
.ss
.end
->rank
!= 0)
4527 gfc_error ("Substring end index at %L must be scalar",
4528 &ref
->u
.ss
.end
->where
);
4532 if (ref
->u
.ss
.length
!= NULL
4533 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4534 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4535 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4537 gfc_error ("Substring end index at %L exceeds the string length",
4538 &ref
->u
.ss
.start
->where
);
4542 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4543 gfc_integer_kinds
[k
].huge
) == CMP_GT
4544 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4545 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4547 gfc_error ("Substring end index at %L is too large",
4548 &ref
->u
.ss
.end
->where
);
4557 /* This function supplies missing substring charlens. */
4560 gfc_resolve_substring_charlen (gfc_expr
*e
)
4563 gfc_expr
*start
, *end
;
4564 gfc_typespec
*ts
= NULL
;
4566 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4568 if (char_ref
->type
== REF_SUBSTRING
)
4570 if (char_ref
->type
== REF_COMPONENT
)
4571 ts
= &char_ref
->u
.c
.component
->ts
;
4577 gcc_assert (char_ref
->next
== NULL
);
4581 if (e
->ts
.u
.cl
->length
)
4582 gfc_free_expr (e
->ts
.u
.cl
->length
);
4583 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4587 e
->ts
.type
= BT_CHARACTER
;
4588 e
->ts
.kind
= gfc_default_character_kind
;
4591 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4593 if (char_ref
->u
.ss
.start
)
4594 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4596 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4598 if (char_ref
->u
.ss
.end
)
4599 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4600 else if (e
->expr_type
== EXPR_VARIABLE
)
4603 ts
= &e
->symtree
->n
.sym
->ts
;
4604 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4611 gfc_free_expr (start
);
4612 gfc_free_expr (end
);
4616 /* Length = (end - start + 1). */
4617 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4618 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4619 gfc_get_int_expr (gfc_default_integer_kind
,
4622 /* F2008, 6.4.1: Both the starting point and the ending point shall
4623 be within the range 1, 2, ..., n unless the starting point exceeds
4624 the ending point, in which case the substring has length zero. */
4626 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4627 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4629 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4630 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4632 /* Make sure that the length is simplified. */
4633 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4634 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4638 /* Resolve subtype references. */
4641 resolve_ref (gfc_expr
*expr
)
4643 int current_part_dimension
, n_components
, seen_part_dimension
;
4646 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4647 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4649 find_array_spec (expr
);
4653 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4657 if (!resolve_array_ref (&ref
->u
.ar
))
4665 if (!resolve_substring (ref
))
4670 /* Check constraints on part references. */
4672 current_part_dimension
= 0;
4673 seen_part_dimension
= 0;
4676 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4681 switch (ref
->u
.ar
.type
)
4684 /* Coarray scalar. */
4685 if (ref
->u
.ar
.as
->rank
== 0)
4687 current_part_dimension
= 0;
4692 current_part_dimension
= 1;
4696 current_part_dimension
= 0;
4700 gfc_internal_error ("resolve_ref(): Bad array reference");
4706 if (current_part_dimension
|| seen_part_dimension
)
4709 if (ref
->u
.c
.component
->attr
.pointer
4710 || ref
->u
.c
.component
->attr
.proc_pointer
4711 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4712 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4714 gfc_error ("Component to the right of a part reference "
4715 "with nonzero rank must not have the POINTER "
4716 "attribute at %L", &expr
->where
);
4719 else if (ref
->u
.c
.component
->attr
.allocatable
4720 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4721 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4724 gfc_error ("Component to the right of a part reference "
4725 "with nonzero rank must not have the ALLOCATABLE "
4726 "attribute at %L", &expr
->where
);
4738 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4739 || ref
->next
== NULL
)
4740 && current_part_dimension
4741 && seen_part_dimension
)
4743 gfc_error ("Two or more part references with nonzero rank must "
4744 "not be specified at %L", &expr
->where
);
4748 if (ref
->type
== REF_COMPONENT
)
4750 if (current_part_dimension
)
4751 seen_part_dimension
= 1;
4753 /* reset to make sure */
4754 current_part_dimension
= 0;
4762 /* Given an expression, determine its shape. This is easier than it sounds.
4763 Leaves the shape array NULL if it is not possible to determine the shape. */
4766 expression_shape (gfc_expr
*e
)
4768 mpz_t array
[GFC_MAX_DIMENSIONS
];
4771 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4774 for (i
= 0; i
< e
->rank
; i
++)
4775 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4778 e
->shape
= gfc_get_shape (e
->rank
);
4780 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4785 for (i
--; i
>= 0; i
--)
4786 mpz_clear (array
[i
]);
4790 /* Given a variable expression node, compute the rank of the expression by
4791 examining the base symbol and any reference structures it may have. */
4794 expression_rank (gfc_expr
*e
)
4799 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4800 could lead to serious confusion... */
4801 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4805 if (e
->expr_type
== EXPR_ARRAY
)
4807 /* Constructors can have a rank different from one via RESHAPE(). */
4809 if (e
->symtree
== NULL
)
4815 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4816 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4822 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4824 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4825 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4826 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4828 if (ref
->type
!= REF_ARRAY
)
4831 if (ref
->u
.ar
.type
== AR_FULL
)
4833 rank
= ref
->u
.ar
.as
->rank
;
4837 if (ref
->u
.ar
.type
== AR_SECTION
)
4839 /* Figure out the rank of the section. */
4841 gfc_internal_error ("expression_rank(): Two array specs");
4843 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4844 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4845 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4855 expression_shape (e
);
4860 add_caf_get_intrinsic (gfc_expr
*e
)
4862 gfc_expr
*wrapper
, *tmp_expr
;
4866 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4867 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4872 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4873 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4876 tmp_expr
= XCNEW (gfc_expr
);
4878 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4879 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4880 wrapper
->ts
= e
->ts
;
4881 wrapper
->rank
= e
->rank
;
4883 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4890 remove_caf_get_intrinsic (gfc_expr
*e
)
4892 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4893 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4894 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4895 e
->value
.function
.actual
->expr
= NULL
;
4896 gfc_free_actual_arglist (e
->value
.function
.actual
);
4897 gfc_free_shape (&e
->shape
, e
->rank
);
4903 /* Resolve a variable expression. */
4906 resolve_variable (gfc_expr
*e
)
4913 if (e
->symtree
== NULL
)
4915 sym
= e
->symtree
->n
.sym
;
4917 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4918 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4919 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4921 if (!actual_arg
|| inquiry_argument
)
4923 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4924 "be used as actual argument", sym
->name
, &e
->where
);
4928 /* TS 29113, 407b. */
4929 else if (e
->ts
.type
== BT_ASSUMED
)
4933 gfc_error ("Assumed-type variable %s at %L may only be used "
4934 "as actual argument", sym
->name
, &e
->where
);
4937 else if (inquiry_argument
&& !first_actual_arg
)
4939 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4940 for all inquiry functions in resolve_function; the reason is
4941 that the function-name resolution happens too late in that
4943 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4944 "an inquiry function shall be the first argument",
4945 sym
->name
, &e
->where
);
4949 /* TS 29113, C535b. */
4950 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4951 && CLASS_DATA (sym
)->as
4952 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4953 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4954 && sym
->as
->type
== AS_ASSUMED_RANK
))
4958 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4959 "actual argument", sym
->name
, &e
->where
);
4962 else if (inquiry_argument
&& !first_actual_arg
)
4964 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4965 for all inquiry functions in resolve_function; the reason is
4966 that the function-name resolution happens too late in that
4968 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4969 "to an inquiry function shall be the first argument",
4970 sym
->name
, &e
->where
);
4975 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4976 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4977 && e
->ref
->next
== NULL
))
4979 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4980 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4983 /* TS 29113, 407b. */
4984 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4985 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4986 && e
->ref
->next
== NULL
))
4988 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4989 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4993 /* TS 29113, C535b. */
4994 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4995 && CLASS_DATA (sym
)->as
4996 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4997 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4998 && sym
->as
->type
== AS_ASSUMED_RANK
))
5000 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5001 && e
->ref
->next
== NULL
))
5003 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5004 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5008 /* For variables that are used in an associate (target => object) where
5009 the object's basetype is array valued while the target is scalar,
5010 the ts' type of the component refs is still array valued, which
5011 can't be translated that way. */
5012 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5013 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5014 && CLASS_DATA (sym
->assoc
->target
)->as
)
5016 gfc_ref
*ref
= e
->ref
;
5022 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5023 /* Stop the loop. */
5033 /* If this is an associate-name, it may be parsed with an array reference
5034 in error even though the target is scalar. Fail directly in this case.
5035 TODO Understand why class scalar expressions must be excluded. */
5036 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5038 if (sym
->ts
.type
== BT_CLASS
)
5039 gfc_fix_class_refs (e
);
5040 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5044 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5045 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5047 /* On the other hand, the parser may not have known this is an array;
5048 in this case, we have to add a FULL reference. */
5049 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5051 e
->ref
= gfc_get_ref ();
5052 e
->ref
->type
= REF_ARRAY
;
5053 e
->ref
->u
.ar
.type
= AR_FULL
;
5054 e
->ref
->u
.ar
.dimen
= 0;
5057 /* Like above, but for class types, where the checking whether an array
5058 ref is present is more complicated. Furthermore make sure not to add
5059 the full array ref to _vptr or _len refs. */
5060 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5061 && CLASS_DATA (sym
)->attr
.dimension
5062 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5064 gfc_ref
*ref
, *newref
;
5066 newref
= gfc_get_ref ();
5067 newref
->type
= REF_ARRAY
;
5068 newref
->u
.ar
.type
= AR_FULL
;
5069 newref
->u
.ar
.dimen
= 0;
5070 /* Because this is an associate var and the first ref either is a ref to
5071 the _data component or not, no traversal of the ref chain is
5072 needed. The array ref needs to be inserted after the _data ref,
5073 or when that is not present, which may happend for polymorphic
5074 types, then at the first position. */
5078 else if (ref
->type
== REF_COMPONENT
5079 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5081 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5083 newref
->next
= ref
->next
;
5087 /* Array ref present already. */
5088 gfc_free_ref_list (newref
);
5090 else if (ref
->type
== REF_ARRAY
)
5091 /* Array ref present already. */
5092 gfc_free_ref_list (newref
);
5100 if (e
->ref
&& !resolve_ref (e
))
5103 if (sym
->attr
.flavor
== FL_PROCEDURE
5104 && (!sym
->attr
.function
5105 || (sym
->attr
.function
&& sym
->result
5106 && sym
->result
->attr
.proc_pointer
5107 && !sym
->result
->attr
.function
)))
5109 e
->ts
.type
= BT_PROCEDURE
;
5110 goto resolve_procedure
;
5113 if (sym
->ts
.type
!= BT_UNKNOWN
)
5114 gfc_variable_attr (e
, &e
->ts
);
5115 else if (sym
->attr
.flavor
== FL_PROCEDURE
5116 && sym
->attr
.function
&& sym
->result
5117 && sym
->result
->ts
.type
!= BT_UNKNOWN
5118 && sym
->result
->attr
.proc_pointer
)
5119 e
->ts
= sym
->result
->ts
;
5122 /* Must be a simple variable reference. */
5123 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5128 if (check_assumed_size_reference (sym
, e
))
5131 /* Deal with forward references to entries during gfc_resolve_code, to
5132 satisfy, at least partially, 12.5.2.5. */
5133 if (gfc_current_ns
->entries
5134 && current_entry_id
== sym
->entry_id
5137 && cs_base
->current
->op
!= EXEC_ENTRY
)
5139 gfc_entry_list
*entry
;
5140 gfc_formal_arglist
*formal
;
5142 bool seen
, saved_specification_expr
;
5144 /* If the symbol is a dummy... */
5145 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5147 entry
= gfc_current_ns
->entries
;
5150 /* ...test if the symbol is a parameter of previous entries. */
5151 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5152 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5154 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5161 /* If it has not been seen as a dummy, this is an error. */
5164 if (specification_expr
)
5165 gfc_error ("Variable %qs, used in a specification expression"
5166 ", is referenced at %L before the ENTRY statement "
5167 "in which it is a parameter",
5168 sym
->name
, &cs_base
->current
->loc
);
5170 gfc_error ("Variable %qs is used at %L before the ENTRY "
5171 "statement in which it is a parameter",
5172 sym
->name
, &cs_base
->current
->loc
);
5177 /* Now do the same check on the specification expressions. */
5178 saved_specification_expr
= specification_expr
;
5179 specification_expr
= true;
5180 if (sym
->ts
.type
== BT_CHARACTER
5181 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5185 for (n
= 0; n
< sym
->as
->rank
; n
++)
5187 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5189 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5192 specification_expr
= saved_specification_expr
;
5195 /* Update the symbol's entry level. */
5196 sym
->entry_id
= current_entry_id
+ 1;
5199 /* If a symbol has been host_associated mark it. This is used latter,
5200 to identify if aliasing is possible via host association. */
5201 if (sym
->attr
.flavor
== FL_VARIABLE
5202 && gfc_current_ns
->parent
5203 && (gfc_current_ns
->parent
== sym
->ns
5204 || (gfc_current_ns
->parent
->parent
5205 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5206 sym
->attr
.host_assoc
= 1;
5208 if (gfc_current_ns
->proc_name
5209 && sym
->attr
.dimension
5210 && (sym
->ns
!= gfc_current_ns
5211 || sym
->attr
.use_assoc
5212 || sym
->attr
.in_common
))
5213 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5216 if (t
&& !resolve_procedure_expression (e
))
5219 /* F2008, C617 and C1229. */
5220 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5221 && gfc_is_coindexed (e
))
5223 gfc_ref
*ref
, *ref2
= NULL
;
5225 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5227 if (ref
->type
== REF_COMPONENT
)
5229 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5233 for ( ; ref
; ref
= ref
->next
)
5234 if (ref
->type
== REF_COMPONENT
)
5237 /* Expression itself is not coindexed object. */
5238 if (ref
&& e
->ts
.type
== BT_CLASS
)
5240 gfc_error ("Polymorphic subobject of coindexed object at %L",
5245 /* Expression itself is coindexed object. */
5249 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5250 for ( ; c
; c
= c
->next
)
5251 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5253 gfc_error ("Coindexed object with polymorphic allocatable "
5254 "subcomponent at %L", &e
->where
);
5262 expression_rank (e
);
5264 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5265 add_caf_get_intrinsic (e
);
5271 /* Checks to see that the correct symbol has been host associated.
5272 The only situation where this arises is that in which a twice
5273 contained function is parsed after the host association is made.
5274 Therefore, on detecting this, change the symbol in the expression
5275 and convert the array reference into an actual arglist if the old
5276 symbol is a variable. */
5278 check_host_association (gfc_expr
*e
)
5280 gfc_symbol
*sym
, *old_sym
;
5284 gfc_actual_arglist
*arg
, *tail
= NULL
;
5285 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5287 /* If the expression is the result of substitution in
5288 interface.c(gfc_extend_expr) because there is no way in
5289 which the host association can be wrong. */
5290 if (e
->symtree
== NULL
5291 || e
->symtree
->n
.sym
== NULL
5292 || e
->user_operator
)
5295 old_sym
= e
->symtree
->n
.sym
;
5297 if (gfc_current_ns
->parent
5298 && old_sym
->ns
!= gfc_current_ns
)
5300 /* Use the 'USE' name so that renamed module symbols are
5301 correctly handled. */
5302 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5304 if (sym
&& old_sym
!= sym
5305 && sym
->ts
.type
== old_sym
->ts
.type
5306 && sym
->attr
.flavor
== FL_PROCEDURE
5307 && sym
->attr
.contained
)
5309 /* Clear the shape, since it might not be valid. */
5310 gfc_free_shape (&e
->shape
, e
->rank
);
5312 /* Give the expression the right symtree! */
5313 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5314 gcc_assert (st
!= NULL
);
5316 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5317 || e
->expr_type
== EXPR_FUNCTION
)
5319 /* Original was function so point to the new symbol, since
5320 the actual argument list is already attached to the
5322 e
->value
.function
.esym
= NULL
;
5327 /* Original was variable so convert array references into
5328 an actual arglist. This does not need any checking now
5329 since resolve_function will take care of it. */
5330 e
->value
.function
.actual
= NULL
;
5331 e
->expr_type
= EXPR_FUNCTION
;
5334 /* Ambiguity will not arise if the array reference is not
5335 the last reference. */
5336 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5337 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5340 gcc_assert (ref
->type
== REF_ARRAY
);
5342 /* Grab the start expressions from the array ref and
5343 copy them into actual arguments. */
5344 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5346 arg
= gfc_get_actual_arglist ();
5347 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5348 if (e
->value
.function
.actual
== NULL
)
5349 tail
= e
->value
.function
.actual
= arg
;
5357 /* Dump the reference list and set the rank. */
5358 gfc_free_ref_list (e
->ref
);
5360 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5363 gfc_resolve_expr (e
);
5367 /* This might have changed! */
5368 return e
->expr_type
== EXPR_FUNCTION
;
5373 gfc_resolve_character_operator (gfc_expr
*e
)
5375 gfc_expr
*op1
= e
->value
.op
.op1
;
5376 gfc_expr
*op2
= e
->value
.op
.op2
;
5377 gfc_expr
*e1
= NULL
;
5378 gfc_expr
*e2
= NULL
;
5380 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5382 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5383 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5384 else if (op1
->expr_type
== EXPR_CONSTANT
)
5385 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5386 op1
->value
.character
.length
);
5388 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5389 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5390 else if (op2
->expr_type
== EXPR_CONSTANT
)
5391 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5392 op2
->value
.character
.length
);
5394 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5404 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5405 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5406 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5407 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5408 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5414 /* Ensure that an character expression has a charlen and, if possible, a
5415 length expression. */
5418 fixup_charlen (gfc_expr
*e
)
5420 /* The cases fall through so that changes in expression type and the need
5421 for multiple fixes are picked up. In all circumstances, a charlen should
5422 be available for the middle end to hang a backend_decl on. */
5423 switch (e
->expr_type
)
5426 gfc_resolve_character_operator (e
);
5430 if (e
->expr_type
== EXPR_ARRAY
)
5431 gfc_resolve_character_array_constructor (e
);
5434 case EXPR_SUBSTRING
:
5435 if (!e
->ts
.u
.cl
&& e
->ref
)
5436 gfc_resolve_substring_charlen (e
);
5441 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5448 /* Update an actual argument to include the passed-object for type-bound
5449 procedures at the right position. */
5451 static gfc_actual_arglist
*
5452 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5455 gcc_assert (argpos
> 0);
5459 gfc_actual_arglist
* result
;
5461 result
= gfc_get_actual_arglist ();
5465 result
->name
= name
;
5471 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5473 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5478 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5481 extract_compcall_passed_object (gfc_expr
* e
)
5485 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5487 if (e
->value
.compcall
.base_object
)
5488 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5491 po
= gfc_get_expr ();
5492 po
->expr_type
= EXPR_VARIABLE
;
5493 po
->symtree
= e
->symtree
;
5494 po
->ref
= gfc_copy_ref (e
->ref
);
5495 po
->where
= e
->where
;
5498 if (!gfc_resolve_expr (po
))
5505 /* Update the arglist of an EXPR_COMPCALL expression to include the
5509 update_compcall_arglist (gfc_expr
* e
)
5512 gfc_typebound_proc
* tbp
;
5514 tbp
= e
->value
.compcall
.tbp
;
5519 po
= extract_compcall_passed_object (e
);
5523 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5529 gcc_assert (tbp
->pass_arg_num
> 0);
5530 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5538 /* Extract the passed object from a PPC call (a copy of it). */
5541 extract_ppc_passed_object (gfc_expr
*e
)
5546 po
= gfc_get_expr ();
5547 po
->expr_type
= EXPR_VARIABLE
;
5548 po
->symtree
= e
->symtree
;
5549 po
->ref
= gfc_copy_ref (e
->ref
);
5550 po
->where
= e
->where
;
5552 /* Remove PPC reference. */
5554 while ((*ref
)->next
)
5555 ref
= &(*ref
)->next
;
5556 gfc_free_ref_list (*ref
);
5559 if (!gfc_resolve_expr (po
))
5566 /* Update the actual arglist of a procedure pointer component to include the
5570 update_ppc_arglist (gfc_expr
* e
)
5574 gfc_typebound_proc
* tb
;
5576 ppc
= gfc_get_proc_ptr_comp (e
);
5584 else if (tb
->nopass
)
5587 po
= extract_ppc_passed_object (e
);
5594 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5599 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5601 gfc_error ("Base object for procedure-pointer component call at %L is of"
5602 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5606 gcc_assert (tb
->pass_arg_num
> 0);
5607 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5615 /* Check that the object a TBP is called on is valid, i.e. it must not be
5616 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5619 check_typebound_baseobject (gfc_expr
* e
)
5622 bool return_value
= false;
5624 base
= extract_compcall_passed_object (e
);
5628 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5630 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5634 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5636 gfc_error ("Base object for type-bound procedure call at %L is of"
5637 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5641 /* F08:C1230. If the procedure called is NOPASS,
5642 the base object must be scalar. */
5643 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5645 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5646 " be scalar", &e
->where
);
5650 return_value
= true;
5653 gfc_free_expr (base
);
5654 return return_value
;
5658 /* Resolve a call to a type-bound procedure, either function or subroutine,
5659 statically from the data in an EXPR_COMPCALL expression. The adapted
5660 arglist and the target-procedure symtree are returned. */
5663 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5664 gfc_actual_arglist
** actual
)
5666 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5667 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5669 /* Update the actual arglist for PASS. */
5670 if (!update_compcall_arglist (e
))
5673 *actual
= e
->value
.compcall
.actual
;
5674 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5676 gfc_free_ref_list (e
->ref
);
5678 e
->value
.compcall
.actual
= NULL
;
5680 /* If we find a deferred typebound procedure, check for derived types
5681 that an overriding typebound procedure has not been missed. */
5682 if (e
->value
.compcall
.name
5683 && !e
->value
.compcall
.tbp
->non_overridable
5684 && e
->value
.compcall
.base_object
5685 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5688 gfc_symbol
*derived
;
5690 /* Use the derived type of the base_object. */
5691 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5694 /* If necessary, go through the inheritance chain. */
5695 while (!st
&& derived
)
5697 /* Look for the typebound procedure 'name'. */
5698 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5699 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5700 e
->value
.compcall
.name
);
5702 derived
= gfc_get_derived_super_type (derived
);
5705 /* Now find the specific name in the derived type namespace. */
5706 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5707 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5708 derived
->ns
, 1, &st
);
5716 /* Get the ultimate declared type from an expression. In addition,
5717 return the last class/derived type reference and the copy of the
5718 reference list. If check_types is set true, derived types are
5719 identified as well as class references. */
5721 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5722 gfc_expr
*e
, bool check_types
)
5724 gfc_symbol
*declared
;
5731 *new_ref
= gfc_copy_ref (e
->ref
);
5733 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5735 if (ref
->type
!= REF_COMPONENT
)
5738 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5739 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
5740 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5742 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5748 if (declared
== NULL
)
5749 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5755 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5756 which of the specific bindings (if any) matches the arglist and transform
5757 the expression into a call of that binding. */
5760 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5762 gfc_typebound_proc
* genproc
;
5763 const char* genname
;
5765 gfc_symbol
*derived
;
5767 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5768 genname
= e
->value
.compcall
.name
;
5769 genproc
= e
->value
.compcall
.tbp
;
5771 if (!genproc
->is_generic
)
5774 /* Try the bindings on this type and in the inheritance hierarchy. */
5775 for (; genproc
; genproc
= genproc
->overridden
)
5779 gcc_assert (genproc
->is_generic
);
5780 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5783 gfc_actual_arglist
* args
;
5786 gcc_assert (g
->specific
);
5788 if (g
->specific
->error
)
5791 target
= g
->specific
->u
.specific
->n
.sym
;
5793 /* Get the right arglist by handling PASS/NOPASS. */
5794 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5795 if (!g
->specific
->nopass
)
5798 po
= extract_compcall_passed_object (e
);
5801 gfc_free_actual_arglist (args
);
5805 gcc_assert (g
->specific
->pass_arg_num
> 0);
5806 gcc_assert (!g
->specific
->error
);
5807 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5808 g
->specific
->pass_arg
);
5810 resolve_actual_arglist (args
, target
->attr
.proc
,
5811 is_external_proc (target
)
5812 && gfc_sym_get_dummy_args (target
) == NULL
);
5814 /* Check if this arglist matches the formal. */
5815 matches
= gfc_arglist_matches_symbol (&args
, target
);
5817 /* Clean up and break out of the loop if we've found it. */
5818 gfc_free_actual_arglist (args
);
5821 e
->value
.compcall
.tbp
= g
->specific
;
5822 genname
= g
->specific_st
->name
;
5823 /* Pass along the name for CLASS methods, where the vtab
5824 procedure pointer component has to be referenced. */
5832 /* Nothing matching found! */
5833 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5834 " %qs at %L", genname
, &e
->where
);
5838 /* Make sure that we have the right specific instance for the name. */
5839 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5841 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5843 e
->value
.compcall
.tbp
= st
->n
.tb
;
5849 /* Resolve a call to a type-bound subroutine. */
5852 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5854 gfc_actual_arglist
* newactual
;
5855 gfc_symtree
* target
;
5857 /* Check that's really a SUBROUTINE. */
5858 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5860 gfc_error ("%qs at %L should be a SUBROUTINE",
5861 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5865 if (!check_typebound_baseobject (c
->expr1
))
5868 /* Pass along the name for CLASS methods, where the vtab
5869 procedure pointer component has to be referenced. */
5871 *name
= c
->expr1
->value
.compcall
.name
;
5873 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5876 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5878 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5880 /* Transform into an ordinary EXEC_CALL for now. */
5882 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5885 c
->ext
.actual
= newactual
;
5886 c
->symtree
= target
;
5887 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5889 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5891 gfc_free_expr (c
->expr1
);
5892 c
->expr1
= gfc_get_expr ();
5893 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5894 c
->expr1
->symtree
= target
;
5895 c
->expr1
->where
= c
->loc
;
5897 return resolve_call (c
);
5901 /* Resolve a component-call expression. */
5903 resolve_compcall (gfc_expr
* e
, const char **name
)
5905 gfc_actual_arglist
* newactual
;
5906 gfc_symtree
* target
;
5908 /* Check that's really a FUNCTION. */
5909 if (!e
->value
.compcall
.tbp
->function
)
5911 gfc_error ("%qs at %L should be a FUNCTION",
5912 e
->value
.compcall
.name
, &e
->where
);
5916 /* These must not be assign-calls! */
5917 gcc_assert (!e
->value
.compcall
.assign
);
5919 if (!check_typebound_baseobject (e
))
5922 /* Pass along the name for CLASS methods, where the vtab
5923 procedure pointer component has to be referenced. */
5925 *name
= e
->value
.compcall
.name
;
5927 if (!resolve_typebound_generic_call (e
, name
))
5929 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5931 /* Take the rank from the function's symbol. */
5932 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5933 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5935 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5936 arglist to the TBP's binding target. */
5938 if (!resolve_typebound_static (e
, &target
, &newactual
))
5941 e
->value
.function
.actual
= newactual
;
5942 e
->value
.function
.name
= NULL
;
5943 e
->value
.function
.esym
= target
->n
.sym
;
5944 e
->value
.function
.isym
= NULL
;
5945 e
->symtree
= target
;
5946 e
->ts
= target
->n
.sym
->ts
;
5947 e
->expr_type
= EXPR_FUNCTION
;
5949 /* Resolution is not necessary if this is a class subroutine; this
5950 function only has to identify the specific proc. Resolution of
5951 the call will be done next in resolve_typebound_call. */
5952 return gfc_resolve_expr (e
);
5956 static bool resolve_fl_derived (gfc_symbol
*sym
);
5959 /* Resolve a typebound function, or 'method'. First separate all
5960 the non-CLASS references by calling resolve_compcall directly. */
5963 resolve_typebound_function (gfc_expr
* e
)
5965 gfc_symbol
*declared
;
5977 /* Deal with typebound operators for CLASS objects. */
5978 expr
= e
->value
.compcall
.base_object
;
5979 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5980 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5982 /* If the base_object is not a variable, the corresponding actual
5983 argument expression must be stored in e->base_expression so
5984 that the corresponding tree temporary can be used as the base
5985 object in gfc_conv_procedure_call. */
5986 if (expr
->expr_type
!= EXPR_VARIABLE
)
5988 gfc_actual_arglist
*args
;
5990 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5992 if (expr
== args
->expr
)
5997 /* Since the typebound operators are generic, we have to ensure
5998 that any delays in resolution are corrected and that the vtab
6001 declared
= ts
.u
.derived
;
6002 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6003 if (c
->ts
.u
.derived
== NULL
)
6004 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6006 if (!resolve_compcall (e
, &name
))
6009 /* Use the generic name if it is there. */
6010 name
= name
? name
: e
->value
.function
.esym
->name
;
6011 e
->symtree
= expr
->symtree
;
6012 e
->ref
= gfc_copy_ref (expr
->ref
);
6013 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6015 /* Trim away the extraneous references that emerge from nested
6016 use of interface.c (extend_expr). */
6017 if (class_ref
&& class_ref
->next
)
6019 gfc_free_ref_list (class_ref
->next
);
6020 class_ref
->next
= NULL
;
6022 else if (e
->ref
&& !class_ref
)
6024 gfc_free_ref_list (e
->ref
);
6028 gfc_add_vptr_component (e
);
6029 gfc_add_component_ref (e
, name
);
6030 e
->value
.function
.esym
= NULL
;
6031 if (expr
->expr_type
!= EXPR_VARIABLE
)
6032 e
->base_expr
= expr
;
6037 return resolve_compcall (e
, NULL
);
6039 if (!resolve_ref (e
))
6042 /* Get the CLASS declared type. */
6043 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6045 if (!resolve_fl_derived (declared
))
6048 /* Weed out cases of the ultimate component being a derived type. */
6049 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6050 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6052 gfc_free_ref_list (new_ref
);
6053 return resolve_compcall (e
, NULL
);
6056 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6057 declared
= c
->ts
.u
.derived
;
6059 /* Treat the call as if it is a typebound procedure, in order to roll
6060 out the correct name for the specific function. */
6061 if (!resolve_compcall (e
, &name
))
6063 gfc_free_ref_list (new_ref
);
6070 /* Convert the expression to a procedure pointer component call. */
6071 e
->value
.function
.esym
= NULL
;
6077 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6078 gfc_add_vptr_component (e
);
6079 gfc_add_component_ref (e
, name
);
6081 /* Recover the typespec for the expression. This is really only
6082 necessary for generic procedures, where the additional call
6083 to gfc_add_component_ref seems to throw the collection of the
6084 correct typespec. */
6088 gfc_free_ref_list (new_ref
);
6093 /* Resolve a typebound subroutine, or 'method'. First separate all
6094 the non-CLASS references by calling resolve_typebound_call
6098 resolve_typebound_subroutine (gfc_code
*code
)
6100 gfc_symbol
*declared
;
6110 st
= code
->expr1
->symtree
;
6112 /* Deal with typebound operators for CLASS objects. */
6113 expr
= code
->expr1
->value
.compcall
.base_object
;
6114 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6115 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6117 /* If the base_object is not a variable, the corresponding actual
6118 argument expression must be stored in e->base_expression so
6119 that the corresponding tree temporary can be used as the base
6120 object in gfc_conv_procedure_call. */
6121 if (expr
->expr_type
!= EXPR_VARIABLE
)
6123 gfc_actual_arglist
*args
;
6125 args
= code
->expr1
->value
.function
.actual
;
6126 for (; args
; args
= args
->next
)
6127 if (expr
== args
->expr
)
6131 /* Since the typebound operators are generic, we have to ensure
6132 that any delays in resolution are corrected and that the vtab
6134 declared
= expr
->ts
.u
.derived
;
6135 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6136 if (c
->ts
.u
.derived
== NULL
)
6137 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6139 if (!resolve_typebound_call (code
, &name
, NULL
))
6142 /* Use the generic name if it is there. */
6143 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6144 code
->expr1
->symtree
= expr
->symtree
;
6145 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6147 /* Trim away the extraneous references that emerge from nested
6148 use of interface.c (extend_expr). */
6149 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6150 if (class_ref
&& class_ref
->next
)
6152 gfc_free_ref_list (class_ref
->next
);
6153 class_ref
->next
= NULL
;
6155 else if (code
->expr1
->ref
&& !class_ref
)
6157 gfc_free_ref_list (code
->expr1
->ref
);
6158 code
->expr1
->ref
= NULL
;
6161 /* Now use the procedure in the vtable. */
6162 gfc_add_vptr_component (code
->expr1
);
6163 gfc_add_component_ref (code
->expr1
, name
);
6164 code
->expr1
->value
.function
.esym
= NULL
;
6165 if (expr
->expr_type
!= EXPR_VARIABLE
)
6166 code
->expr1
->base_expr
= expr
;
6171 return resolve_typebound_call (code
, NULL
, NULL
);
6173 if (!resolve_ref (code
->expr1
))
6176 /* Get the CLASS declared type. */
6177 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6179 /* Weed out cases of the ultimate component being a derived type. */
6180 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6181 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6183 gfc_free_ref_list (new_ref
);
6184 return resolve_typebound_call (code
, NULL
, NULL
);
6187 if (!resolve_typebound_call (code
, &name
, &overridable
))
6189 gfc_free_ref_list (new_ref
);
6192 ts
= code
->expr1
->ts
;
6196 /* Convert the expression to a procedure pointer component call. */
6197 code
->expr1
->value
.function
.esym
= NULL
;
6198 code
->expr1
->symtree
= st
;
6201 code
->expr1
->ref
= new_ref
;
6203 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6204 gfc_add_vptr_component (code
->expr1
);
6205 gfc_add_component_ref (code
->expr1
, name
);
6207 /* Recover the typespec for the expression. This is really only
6208 necessary for generic procedures, where the additional call
6209 to gfc_add_component_ref seems to throw the collection of the
6210 correct typespec. */
6211 code
->expr1
->ts
= ts
;
6214 gfc_free_ref_list (new_ref
);
6220 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6223 resolve_ppc_call (gfc_code
* c
)
6225 gfc_component
*comp
;
6227 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6228 gcc_assert (comp
!= NULL
);
6230 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6231 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6233 if (!comp
->attr
.subroutine
)
6234 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6236 if (!resolve_ref (c
->expr1
))
6239 if (!update_ppc_arglist (c
->expr1
))
6242 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6244 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6245 !(comp
->ts
.interface
6246 && comp
->ts
.interface
->formal
)))
6249 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6252 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6258 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6261 resolve_expr_ppc (gfc_expr
* e
)
6263 gfc_component
*comp
;
6265 comp
= gfc_get_proc_ptr_comp (e
);
6266 gcc_assert (comp
!= NULL
);
6268 /* Convert to EXPR_FUNCTION. */
6269 e
->expr_type
= EXPR_FUNCTION
;
6270 e
->value
.function
.isym
= NULL
;
6271 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6273 if (comp
->as
!= NULL
)
6274 e
->rank
= comp
->as
->rank
;
6276 if (!comp
->attr
.function
)
6277 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6279 if (!resolve_ref (e
))
6282 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6283 !(comp
->ts
.interface
6284 && comp
->ts
.interface
->formal
)))
6287 if (!update_ppc_arglist (e
))
6290 if (!check_pure_function(e
))
6293 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6300 gfc_is_expandable_expr (gfc_expr
*e
)
6302 gfc_constructor
*con
;
6304 if (e
->expr_type
== EXPR_ARRAY
)
6306 /* Traverse the constructor looking for variables that are flavor
6307 parameter. Parameters must be expanded since they are fully used at
6309 con
= gfc_constructor_first (e
->value
.constructor
);
6310 for (; con
; con
= gfc_constructor_next (con
))
6312 if (con
->expr
->expr_type
== EXPR_VARIABLE
6313 && con
->expr
->symtree
6314 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6315 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6317 if (con
->expr
->expr_type
== EXPR_ARRAY
6318 && gfc_is_expandable_expr (con
->expr
))
6326 /* Resolve an expression. That is, make sure that types of operands agree
6327 with their operators, intrinsic operators are converted to function calls
6328 for overloaded types and unresolved function references are resolved. */
6331 gfc_resolve_expr (gfc_expr
*e
)
6334 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6339 /* inquiry_argument only applies to variables. */
6340 inquiry_save
= inquiry_argument
;
6341 actual_arg_save
= actual_arg
;
6342 first_actual_arg_save
= first_actual_arg
;
6344 if (e
->expr_type
!= EXPR_VARIABLE
)
6346 inquiry_argument
= false;
6348 first_actual_arg
= false;
6351 switch (e
->expr_type
)
6354 t
= resolve_operator (e
);
6360 if (check_host_association (e
))
6361 t
= resolve_function (e
);
6363 t
= resolve_variable (e
);
6365 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6366 && e
->ref
->type
!= REF_SUBSTRING
)
6367 gfc_resolve_substring_charlen (e
);
6372 t
= resolve_typebound_function (e
);
6375 case EXPR_SUBSTRING
:
6376 t
= resolve_ref (e
);
6385 t
= resolve_expr_ppc (e
);
6390 if (!resolve_ref (e
))
6393 t
= gfc_resolve_array_constructor (e
);
6394 /* Also try to expand a constructor. */
6397 expression_rank (e
);
6398 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6399 gfc_expand_constructor (e
, false);
6402 /* This provides the opportunity for the length of constructors with
6403 character valued function elements to propagate the string length
6404 to the expression. */
6405 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6407 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6408 here rather then add a duplicate test for it above. */
6409 gfc_expand_constructor (e
, false);
6410 t
= gfc_resolve_character_array_constructor (e
);
6415 case EXPR_STRUCTURE
:
6416 t
= resolve_ref (e
);
6420 t
= resolve_structure_cons (e
, 0);
6424 t
= gfc_simplify_expr (e
, 0);
6428 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6431 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6434 inquiry_argument
= inquiry_save
;
6435 actual_arg
= actual_arg_save
;
6436 first_actual_arg
= first_actual_arg_save
;
6442 /* Resolve an expression from an iterator. They must be scalar and have
6443 INTEGER or (optionally) REAL type. */
6446 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6447 const char *name_msgid
)
6449 if (!gfc_resolve_expr (expr
))
6452 if (expr
->rank
!= 0)
6454 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6458 if (expr
->ts
.type
!= BT_INTEGER
)
6460 if (expr
->ts
.type
== BT_REAL
)
6463 return gfc_notify_std (GFC_STD_F95_DEL
,
6464 "%s at %L must be integer",
6465 _(name_msgid
), &expr
->where
);
6468 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6475 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6483 /* Resolve the expressions in an iterator structure. If REAL_OK is
6484 false allow only INTEGER type iterators, otherwise allow REAL types.
6485 Set own_scope to true for ac-implied-do and data-implied-do as those
6486 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6489 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6491 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6494 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6495 _("iterator variable")))
6498 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6499 "Start expression in DO loop"))
6502 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6503 "End expression in DO loop"))
6506 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6507 "Step expression in DO loop"))
6510 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6512 if ((iter
->step
->ts
.type
== BT_INTEGER
6513 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6514 || (iter
->step
->ts
.type
== BT_REAL
6515 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6517 gfc_error ("Step expression in DO loop at %L cannot be zero",
6518 &iter
->step
->where
);
6523 /* Convert start, end, and step to the same type as var. */
6524 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6525 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6526 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6528 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6529 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6530 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6532 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6533 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6534 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
6536 if (iter
->start
->expr_type
== EXPR_CONSTANT
6537 && iter
->end
->expr_type
== EXPR_CONSTANT
6538 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6541 if (iter
->start
->ts
.type
== BT_INTEGER
)
6543 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6544 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6548 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6549 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6551 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6552 gfc_warning (OPT_Wzerotrip
,
6553 "DO loop at %L will be executed zero times",
6554 &iter
->step
->where
);
6557 if (iter
->end
->expr_type
== EXPR_CONSTANT
6558 && iter
->end
->ts
.type
== BT_INTEGER
6559 && iter
->step
->expr_type
== EXPR_CONSTANT
6560 && iter
->step
->ts
.type
== BT_INTEGER
6561 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
6562 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
6564 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
6565 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
6567 if (is_step_positive
6568 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
6569 gfc_warning (OPT_Wundefined_do_loop
,
6570 "DO loop at %L is undefined as it overflows",
6571 &iter
->step
->where
);
6572 else if (!is_step_positive
6573 && mpz_cmp (iter
->end
->value
.integer
,
6574 gfc_integer_kinds
[k
].min_int
) == 0)
6575 gfc_warning (OPT_Wundefined_do_loop
,
6576 "DO loop at %L is undefined as it underflows",
6577 &iter
->step
->where
);
6584 /* Traversal function for find_forall_index. f == 2 signals that
6585 that variable itself is not to be checked - only the references. */
6588 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6590 if (expr
->expr_type
!= EXPR_VARIABLE
)
6593 /* A scalar assignment */
6594 if (!expr
->ref
|| *f
== 1)
6596 if (expr
->symtree
->n
.sym
== sym
)
6608 /* Check whether the FORALL index appears in the expression or not.
6609 Returns true if SYM is found in EXPR. */
6612 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6614 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6621 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6622 to be a scalar INTEGER variable. The subscripts and stride are scalar
6623 INTEGERs, and if stride is a constant it must be nonzero.
6624 Furthermore "A subscript or stride in a forall-triplet-spec shall
6625 not contain a reference to any index-name in the
6626 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6629 resolve_forall_iterators (gfc_forall_iterator
*it
)
6631 gfc_forall_iterator
*iter
, *iter2
;
6633 for (iter
= it
; iter
; iter
= iter
->next
)
6635 if (gfc_resolve_expr (iter
->var
)
6636 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6637 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6640 if (gfc_resolve_expr (iter
->start
)
6641 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6642 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6643 &iter
->start
->where
);
6644 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6645 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6647 if (gfc_resolve_expr (iter
->end
)
6648 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6649 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6651 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6652 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6654 if (gfc_resolve_expr (iter
->stride
))
6656 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6657 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6658 &iter
->stride
->where
, "INTEGER");
6660 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6661 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6662 gfc_error ("FORALL stride expression at %L cannot be zero",
6663 &iter
->stride
->where
);
6665 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6666 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6669 for (iter
= it
; iter
; iter
= iter
->next
)
6670 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6672 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6673 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6674 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6675 gfc_error ("FORALL index %qs may not appear in triplet "
6676 "specification at %L", iter
->var
->symtree
->name
,
6677 &iter2
->start
->where
);
6682 /* Given a pointer to a symbol that is a derived type, see if it's
6683 inaccessible, i.e. if it's defined in another module and the components are
6684 PRIVATE. The search is recursive if necessary. Returns zero if no
6685 inaccessible components are found, nonzero otherwise. */
6688 derived_inaccessible (gfc_symbol
*sym
)
6692 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6695 for (c
= sym
->components
; c
; c
= c
->next
)
6697 /* Prevent an infinite loop through this function. */
6698 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
6699 && sym
== c
->ts
.u
.derived
)
6702 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6710 /* Resolve the argument of a deallocate expression. The expression must be
6711 a pointer or a full array. */
6714 resolve_deallocate_expr (gfc_expr
*e
)
6716 symbol_attribute attr
;
6717 int allocatable
, pointer
;
6723 if (!gfc_resolve_expr (e
))
6726 if (e
->expr_type
!= EXPR_VARIABLE
)
6729 sym
= e
->symtree
->n
.sym
;
6730 unlimited
= UNLIMITED_POLY(sym
);
6732 if (sym
->ts
.type
== BT_CLASS
)
6734 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6735 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6739 allocatable
= sym
->attr
.allocatable
;
6740 pointer
= sym
->attr
.pointer
;
6742 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6747 if (ref
->u
.ar
.type
!= AR_FULL
6748 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6749 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6754 c
= ref
->u
.c
.component
;
6755 if (c
->ts
.type
== BT_CLASS
)
6757 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6758 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6762 allocatable
= c
->attr
.allocatable
;
6763 pointer
= c
->attr
.pointer
;
6773 attr
= gfc_expr_attr (e
);
6775 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6778 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6784 if (gfc_is_coindexed (e
))
6786 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6791 && !gfc_check_vardef_context (e
, true, true, false,
6792 _("DEALLOCATE object")))
6794 if (!gfc_check_vardef_context (e
, false, true, false,
6795 _("DEALLOCATE object")))
6802 /* Returns true if the expression e contains a reference to the symbol sym. */
6804 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6806 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6813 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6815 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6819 /* Given the expression node e for an allocatable/pointer of derived type to be
6820 allocated, get the expression node to be initialized afterwards (needed for
6821 derived types with default initializers, and derived types with allocatable
6822 components that need nullification.) */
6825 gfc_expr_to_initialize (gfc_expr
*e
)
6831 result
= gfc_copy_expr (e
);
6833 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6834 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6835 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6837 ref
->u
.ar
.type
= AR_FULL
;
6839 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6840 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6845 gfc_free_shape (&result
->shape
, result
->rank
);
6847 /* Recalculate rank, shape, etc. */
6848 gfc_resolve_expr (result
);
6853 /* If the last ref of an expression is an array ref, return a copy of the
6854 expression with that one removed. Otherwise, a copy of the original
6855 expression. This is used for allocate-expressions and pointer assignment
6856 LHS, where there may be an array specification that needs to be stripped
6857 off when using gfc_check_vardef_context. */
6860 remove_last_array_ref (gfc_expr
* e
)
6865 e2
= gfc_copy_expr (e
);
6866 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6867 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6869 gfc_free_ref_list (*r
);
6878 /* Used in resolve_allocate_expr to check that a allocation-object and
6879 a source-expr are conformable. This does not catch all possible
6880 cases; in particular a runtime checking is needed. */
6883 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6886 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6888 /* First compare rank. */
6889 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6890 || (!tail
&& e1
->rank
!= e2
->rank
))
6892 gfc_error ("Source-expr at %L must be scalar or have the "
6893 "same rank as the allocate-object at %L",
6894 &e1
->where
, &e2
->where
);
6905 for (i
= 0; i
< e1
->rank
; i
++)
6907 if (tail
->u
.ar
.start
[i
] == NULL
)
6910 if (tail
->u
.ar
.end
[i
])
6912 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6913 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6914 mpz_add_ui (s
, s
, 1);
6918 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6921 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6923 gfc_error ("Source-expr at %L and allocate-object at %L must "
6924 "have the same shape", &e1
->where
, &e2
->where
);
6937 cond_init (gfc_code
*code
, gfc_expr
*e
, int pointer
, gfc_expr
*init_e
)
6942 gfc_expr
*e_to_init
= gfc_expr_to_initialize (e
);
6945 ? gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_ASSOCIATED
,
6946 "associated", code
->loc
, 2, gfc_copy_expr (e_to_init
), NULL
)
6947 : gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_ALLOCATED
,
6948 "allocated", code
->loc
, 1, gfc_copy_expr (e_to_init
));
6950 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6951 init_st
->loc
= code
->loc
;
6952 init_st
->expr1
= e_to_init
;
6953 init_st
->expr2
= init_e
;
6955 block
= gfc_get_code (EXEC_IF
);
6956 block
->loc
= code
->loc
;
6957 block
->block
= gfc_get_code (EXEC_IF
);
6958 block
->block
->loc
= code
->loc
;
6959 block
->block
->expr1
= cond
;
6960 block
->block
->next
= init_st
;
6961 block
->next
= code
->next
;
6966 /* Resolve the expression in an ALLOCATE statement, doing the additional
6967 checks to see whether the expression is OK or not. The expression must
6968 have a trailing array reference that gives the size of the array. */
6971 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
6973 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6977 symbol_attribute attr
;
6978 gfc_ref
*ref
, *ref2
;
6981 gfc_symbol
*sym
= NULL
;
6986 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6987 checking of coarrays. */
6988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6989 if (ref
->next
== NULL
)
6992 if (ref
&& ref
->type
== REF_ARRAY
)
6993 ref
->u
.ar
.in_allocate
= true;
6995 if (!gfc_resolve_expr (e
))
6998 /* Make sure the expression is allocatable or a pointer. If it is
6999 pointer, the next-to-last reference must be a pointer. */
7003 sym
= e
->symtree
->n
.sym
;
7005 /* Check whether ultimate component is abstract and CLASS. */
7008 /* Is the allocate-object unlimited polymorphic? */
7009 unlimited
= UNLIMITED_POLY(e
);
7011 if (e
->expr_type
!= EXPR_VARIABLE
)
7014 attr
= gfc_expr_attr (e
);
7015 pointer
= attr
.pointer
;
7016 dimension
= attr
.dimension
;
7017 codimension
= attr
.codimension
;
7021 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7023 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7024 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7025 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7026 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7027 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7031 allocatable
= sym
->attr
.allocatable
;
7032 pointer
= sym
->attr
.pointer
;
7033 dimension
= sym
->attr
.dimension
;
7034 codimension
= sym
->attr
.codimension
;
7039 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7044 if (ref
->u
.ar
.codimen
> 0)
7047 for (n
= ref
->u
.ar
.dimen
;
7048 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7049 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7056 if (ref
->next
!= NULL
)
7064 gfc_error ("Coindexed allocatable object at %L",
7069 c
= ref
->u
.c
.component
;
7070 if (c
->ts
.type
== BT_CLASS
)
7072 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7073 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7074 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7075 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7076 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7080 allocatable
= c
->attr
.allocatable
;
7081 pointer
= c
->attr
.pointer
;
7082 dimension
= c
->attr
.dimension
;
7083 codimension
= c
->attr
.codimension
;
7084 is_abstract
= c
->attr
.abstract
;
7096 /* Check for F08:C628. */
7097 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7099 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7104 /* Some checks for the SOURCE tag. */
7107 /* Check F03:C631. */
7108 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7110 gfc_error ("Type of entity at %L is type incompatible with "
7111 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7115 /* Check F03:C632 and restriction following Note 6.18. */
7116 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7119 /* Check F03:C633. */
7120 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7122 gfc_error ("The allocate-object at %L and the source-expr at %L "
7123 "shall have the same kind type parameter",
7124 &e
->where
, &code
->expr3
->where
);
7128 /* Check F2008, C642. */
7129 if (code
->expr3
->ts
.type
== BT_DERIVED
7130 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7131 || (code
->expr3
->ts
.u
.derived
->from_intmod
7132 == INTMOD_ISO_FORTRAN_ENV
7133 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7134 == ISOFORTRAN_LOCK_TYPE
)))
7136 gfc_error ("The source-expr at %L shall neither be of type "
7137 "LOCK_TYPE nor have a LOCK_TYPE component if "
7138 "allocate-object at %L is a coarray",
7139 &code
->expr3
->where
, &e
->where
);
7143 /* Check TS18508, C702/C703. */
7144 if (code
->expr3
->ts
.type
== BT_DERIVED
7145 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7146 || (code
->expr3
->ts
.u
.derived
->from_intmod
7147 == INTMOD_ISO_FORTRAN_ENV
7148 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7149 == ISOFORTRAN_EVENT_TYPE
)))
7151 gfc_error ("The source-expr at %L shall neither be of type "
7152 "EVENT_TYPE nor have a EVENT_TYPE component if "
7153 "allocate-object at %L is a coarray",
7154 &code
->expr3
->where
, &e
->where
);
7159 /* Check F08:C629. */
7160 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7163 gcc_assert (e
->ts
.type
== BT_CLASS
);
7164 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7165 "type-spec or source-expr", sym
->name
, &e
->where
);
7169 /* Check F08:C632. */
7170 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7171 && !UNLIMITED_POLY (e
))
7173 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7174 code
->ext
.alloc
.ts
.u
.cl
->length
);
7175 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7177 gfc_error ("Allocating %s at %L with type-spec requires the same "
7178 "character-length parameter as in the declaration",
7179 sym
->name
, &e
->where
);
7184 /* In the variable definition context checks, gfc_expr_attr is used
7185 on the expression. This is fooled by the array specification
7186 present in e, thus we have to eliminate that one temporarily. */
7187 e2
= remove_last_array_ref (e
);
7190 t
= gfc_check_vardef_context (e2
, true, true, false,
7191 _("ALLOCATE object"));
7193 t
= gfc_check_vardef_context (e2
, false, true, false,
7194 _("ALLOCATE object"));
7199 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7200 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7202 /* For class arrays, the initialization with SOURCE is done
7203 using _copy and trans_call. It is convenient to exploit that
7204 when the allocated type is different from the declared type but
7205 no SOURCE exists by setting expr3. */
7206 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7208 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7209 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7210 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7212 /* We have to zero initialize the integer variable. */
7213 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7215 else if (!code
->expr3
)
7217 /* Set up default initializer if needed. */
7221 if (gfc_bt_struct (code
->ext
.alloc
.ts
.type
))
7222 ts
= code
->ext
.alloc
.ts
;
7226 if (ts
.type
== BT_CLASS
)
7227 ts
= ts
.u
.derived
->components
->ts
;
7229 if (gfc_bt_struct (ts
.type
) && (init_e
= gfc_default_initializer (&ts
)))
7230 cond_init (code
, e
, pointer
, init_e
);
7232 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7234 /* Default initialization via MOLD (non-polymorphic). */
7235 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7238 gfc_resolve_expr (rhs
);
7239 gfc_free_expr (code
->expr3
);
7244 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7246 /* Make sure the vtab symbol is present when
7247 the module variables are generated. */
7248 gfc_typespec ts
= e
->ts
;
7250 ts
= code
->expr3
->ts
;
7251 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7252 ts
= code
->ext
.alloc
.ts
;
7254 gfc_find_derived_vtab (ts
.u
.derived
);
7257 e
= gfc_expr_to_initialize (e
);
7259 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7261 /* Again, make sure the vtab symbol is present when
7262 the module variables are generated. */
7263 gfc_typespec
*ts
= NULL
;
7265 ts
= &code
->expr3
->ts
;
7267 ts
= &code
->ext
.alloc
.ts
;
7274 e
= gfc_expr_to_initialize (e
);
7277 if (dimension
== 0 && codimension
== 0)
7280 /* Make sure the last reference node is an array specification. */
7282 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7283 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7288 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7289 "in ALLOCATE statement at %L", &e
->where
))
7291 if (code
->expr3
->rank
!= 0)
7292 *array_alloc_wo_spec
= true;
7295 gfc_error ("Array specification or array-valued SOURCE= "
7296 "expression required in ALLOCATE statement at %L",
7303 gfc_error ("Array specification required in ALLOCATE statement "
7304 "at %L", &e
->where
);
7309 /* Make sure that the array section reference makes sense in the
7310 context of an ALLOCATE specification. */
7315 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7316 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7318 gfc_error ("Coarray specification required in ALLOCATE statement "
7319 "at %L", &e
->where
);
7323 for (i
= 0; i
< ar
->dimen
; i
++)
7325 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7328 switch (ar
->dimen_type
[i
])
7334 if (ar
->start
[i
] != NULL
7335 && ar
->end
[i
] != NULL
7336 && ar
->stride
[i
] == NULL
)
7344 case DIMEN_THIS_IMAGE
:
7345 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7351 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7353 sym
= a
->expr
->symtree
->n
.sym
;
7355 /* TODO - check derived type components. */
7356 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7359 if ((ar
->start
[i
] != NULL
7360 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7361 || (ar
->end
[i
] != NULL
7362 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7364 gfc_error ("%qs must not appear in the array specification at "
7365 "%L in the same ALLOCATE statement where it is "
7366 "itself allocated", sym
->name
, &ar
->where
);
7372 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7374 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7375 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7377 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7379 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7380 "statement at %L", &e
->where
);
7386 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7387 && ar
->stride
[i
] == NULL
)
7390 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7404 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7406 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7407 gfc_alloc
*a
, *p
, *q
;
7410 errmsg
= code
->expr2
;
7412 /* Check the stat variable. */
7415 gfc_check_vardef_context (stat
, false, false, false,
7416 _("STAT variable"));
7418 if ((stat
->ts
.type
!= BT_INTEGER
7419 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7420 || stat
->ref
->type
== REF_COMPONENT
)))
7422 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7423 "variable", &stat
->where
);
7425 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7426 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7428 gfc_ref
*ref1
, *ref2
;
7431 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7432 ref1
= ref1
->next
, ref2
= ref2
->next
)
7434 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7436 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7445 gfc_error ("Stat-variable at %L shall not be %sd within "
7446 "the same %s statement", &stat
->where
, fcn
, fcn
);
7452 /* Check the errmsg variable. */
7456 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7459 gfc_check_vardef_context (errmsg
, false, false, false,
7460 _("ERRMSG variable"));
7462 if ((errmsg
->ts
.type
!= BT_CHARACTER
7464 && (errmsg
->ref
->type
== REF_ARRAY
7465 || errmsg
->ref
->type
== REF_COMPONENT
)))
7466 || errmsg
->rank
> 0 )
7467 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7468 "variable", &errmsg
->where
);
7470 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7471 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7473 gfc_ref
*ref1
, *ref2
;
7476 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7477 ref1
= ref1
->next
, ref2
= ref2
->next
)
7479 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7481 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7490 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7491 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7497 /* Check that an allocate-object appears only once in the statement. */
7499 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7502 for (q
= p
->next
; q
; q
= q
->next
)
7505 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7507 /* This is a potential collision. */
7508 gfc_ref
*pr
= pe
->ref
;
7509 gfc_ref
*qr
= qe
->ref
;
7511 /* Follow the references until
7512 a) They start to differ, in which case there is no error;
7513 you can deallocate a%b and a%c in a single statement
7514 b) Both of them stop, which is an error
7515 c) One of them stops, which is also an error. */
7518 if (pr
== NULL
&& qr
== NULL
)
7520 gfc_error ("Allocate-object at %L also appears at %L",
7521 &pe
->where
, &qe
->where
);
7524 else if (pr
!= NULL
&& qr
== NULL
)
7526 gfc_error ("Allocate-object at %L is subobject of"
7527 " object at %L", &pe
->where
, &qe
->where
);
7530 else if (pr
== NULL
&& qr
!= NULL
)
7532 gfc_error ("Allocate-object at %L is subobject of"
7533 " object at %L", &qe
->where
, &pe
->where
);
7536 /* Here, pr != NULL && qr != NULL */
7537 gcc_assert(pr
->type
== qr
->type
);
7538 if (pr
->type
== REF_ARRAY
)
7540 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7542 gcc_assert (qr
->type
== REF_ARRAY
);
7544 if (pr
->next
&& qr
->next
)
7547 gfc_array_ref
*par
= &(pr
->u
.ar
);
7548 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7550 for (i
=0; i
<par
->dimen
; i
++)
7552 if ((par
->start
[i
] != NULL
7553 || qar
->start
[i
] != NULL
)
7554 && gfc_dep_compare_expr (par
->start
[i
],
7555 qar
->start
[i
]) != 0)
7562 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7575 if (strcmp (fcn
, "ALLOCATE") == 0)
7577 bool arr_alloc_wo_spec
= false;
7578 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7579 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7581 if (arr_alloc_wo_spec
&& code
->expr3
)
7583 /* Mark the allocate to have to take the array specification
7585 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7590 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7591 resolve_deallocate_expr (a
->expr
);
7596 /************ SELECT CASE resolution subroutines ************/
7598 /* Callback function for our mergesort variant. Determines interval
7599 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7600 op1 > op2. Assumes we're not dealing with the default case.
7601 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7602 There are nine situations to check. */
7605 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7609 if (op1
->low
== NULL
) /* op1 = (:L) */
7611 /* op2 = (:N), so overlap. */
7613 /* op2 = (M:) or (M:N), L < M */
7614 if (op2
->low
!= NULL
7615 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7618 else if (op1
->high
== NULL
) /* op1 = (K:) */
7620 /* op2 = (M:), so overlap. */
7622 /* op2 = (:N) or (M:N), K > N */
7623 if (op2
->high
!= NULL
7624 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7627 else /* op1 = (K:L) */
7629 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7630 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7632 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7633 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7635 else /* op2 = (M:N) */
7639 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7642 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7651 /* Merge-sort a double linked case list, detecting overlap in the
7652 process. LIST is the head of the double linked case list before it
7653 is sorted. Returns the head of the sorted list if we don't see any
7654 overlap, or NULL otherwise. */
7657 check_case_overlap (gfc_case
*list
)
7659 gfc_case
*p
, *q
, *e
, *tail
;
7660 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7662 /* If the passed list was empty, return immediately. */
7669 /* Loop unconditionally. The only exit from this loop is a return
7670 statement, when we've finished sorting the case list. */
7677 /* Count the number of merges we do in this pass. */
7680 /* Loop while there exists a merge to be done. */
7685 /* Count this merge. */
7688 /* Cut the list in two pieces by stepping INSIZE places
7689 forward in the list, starting from P. */
7692 for (i
= 0; i
< insize
; i
++)
7701 /* Now we have two lists. Merge them! */
7702 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7704 /* See from which the next case to merge comes from. */
7707 /* P is empty so the next case must come from Q. */
7712 else if (qsize
== 0 || q
== NULL
)
7721 cmp
= compare_cases (p
, q
);
7724 /* The whole case range for P is less than the
7732 /* The whole case range for Q is greater than
7733 the case range for P. */
7740 /* The cases overlap, or they are the same
7741 element in the list. Either way, we must
7742 issue an error and get the next case from P. */
7743 /* FIXME: Sort P and Q by line number. */
7744 gfc_error ("CASE label at %L overlaps with CASE "
7745 "label at %L", &p
->where
, &q
->where
);
7753 /* Add the next element to the merged list. */
7762 /* P has now stepped INSIZE places along, and so has Q. So
7763 they're the same. */
7768 /* If we have done only one merge or none at all, we've
7769 finished sorting the cases. */
7778 /* Otherwise repeat, merging lists twice the size. */
7784 /* Check to see if an expression is suitable for use in a CASE statement.
7785 Makes sure that all case expressions are scalar constants of the same
7786 type. Return false if anything is wrong. */
7789 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7791 if (e
== NULL
) return true;
7793 if (e
->ts
.type
!= case_expr
->ts
.type
)
7795 gfc_error ("Expression in CASE statement at %L must be of type %s",
7796 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7800 /* C805 (R808) For a given case-construct, each case-value shall be of
7801 the same type as case-expr. For character type, length differences
7802 are allowed, but the kind type parameters shall be the same. */
7804 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7806 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7807 &e
->where
, case_expr
->ts
.kind
);
7811 /* Convert the case value kind to that of case expression kind,
7814 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7815 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7819 gfc_error ("Expression in CASE statement at %L must be scalar",
7828 /* Given a completely parsed select statement, we:
7830 - Validate all expressions and code within the SELECT.
7831 - Make sure that the selection expression is not of the wrong type.
7832 - Make sure that no case ranges overlap.
7833 - Eliminate unreachable cases and unreachable code resulting from
7834 removing case labels.
7836 The standard does allow unreachable cases, e.g. CASE (5:3). But
7837 they are a hassle for code generation, and to prevent that, we just
7838 cut them out here. This is not necessary for overlapping cases
7839 because they are illegal and we never even try to generate code.
7841 We have the additional caveat that a SELECT construct could have
7842 been a computed GOTO in the source code. Fortunately we can fairly
7843 easily work around that here: The case_expr for a "real" SELECT CASE
7844 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7845 we have to do is make sure that the case_expr is a scalar integer
7849 resolve_select (gfc_code
*code
, bool select_type
)
7852 gfc_expr
*case_expr
;
7853 gfc_case
*cp
, *default_case
, *tail
, *head
;
7854 int seen_unreachable
;
7860 if (code
->expr1
== NULL
)
7862 /* This was actually a computed GOTO statement. */
7863 case_expr
= code
->expr2
;
7864 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7865 gfc_error ("Selection expression in computed GOTO statement "
7866 "at %L must be a scalar integer expression",
7869 /* Further checking is not necessary because this SELECT was built
7870 by the compiler, so it should always be OK. Just move the
7871 case_expr from expr2 to expr so that we can handle computed
7872 GOTOs as normal SELECTs from here on. */
7873 code
->expr1
= code
->expr2
;
7878 case_expr
= code
->expr1
;
7879 type
= case_expr
->ts
.type
;
7882 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7884 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7885 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7887 /* Punt. Going on here just produce more garbage error messages. */
7892 if (!select_type
&& case_expr
->rank
!= 0)
7894 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7895 "expression", &case_expr
->where
);
7901 /* Raise a warning if an INTEGER case value exceeds the range of
7902 the case-expr. Later, all expressions will be promoted to the
7903 largest kind of all case-labels. */
7905 if (type
== BT_INTEGER
)
7906 for (body
= code
->block
; body
; body
= body
->block
)
7907 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7910 && gfc_check_integer_range (cp
->low
->value
.integer
,
7911 case_expr
->ts
.kind
) != ARITH_OK
)
7912 gfc_warning (0, "Expression in CASE statement at %L is "
7913 "not in the range of %s", &cp
->low
->where
,
7914 gfc_typename (&case_expr
->ts
));
7917 && cp
->low
!= cp
->high
7918 && gfc_check_integer_range (cp
->high
->value
.integer
,
7919 case_expr
->ts
.kind
) != ARITH_OK
)
7920 gfc_warning (0, "Expression in CASE statement at %L is "
7921 "not in the range of %s", &cp
->high
->where
,
7922 gfc_typename (&case_expr
->ts
));
7925 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7926 of the SELECT CASE expression and its CASE values. Walk the lists
7927 of case values, and if we find a mismatch, promote case_expr to
7928 the appropriate kind. */
7930 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7932 for (body
= code
->block
; body
; body
= body
->block
)
7934 /* Walk the case label list. */
7935 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7937 /* Intercept the DEFAULT case. It does not have a kind. */
7938 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7941 /* Unreachable case ranges are discarded, so ignore. */
7942 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7943 && cp
->low
!= cp
->high
7944 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7948 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7949 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7951 if (cp
->high
!= NULL
7952 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7953 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7958 /* Assume there is no DEFAULT case. */
7959 default_case
= NULL
;
7964 for (body
= code
->block
; body
; body
= body
->block
)
7966 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7968 seen_unreachable
= 0;
7970 /* Walk the case label list, making sure that all case labels
7972 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7974 /* Count the number of cases in the whole construct. */
7977 /* Intercept the DEFAULT case. */
7978 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7980 if (default_case
!= NULL
)
7982 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7983 "by a second DEFAULT CASE at %L",
7984 &default_case
->where
, &cp
->where
);
7995 /* Deal with single value cases and case ranges. Errors are
7996 issued from the validation function. */
7997 if (!validate_case_label_expr (cp
->low
, case_expr
)
7998 || !validate_case_label_expr (cp
->high
, case_expr
))
8004 if (type
== BT_LOGICAL
8005 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8006 || cp
->low
!= cp
->high
))
8008 gfc_error ("Logical range in CASE statement at %L is not "
8009 "allowed", &cp
->low
->where
);
8014 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8017 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8018 if (value
& seen_logical
)
8020 gfc_error ("Constant logical value in CASE statement "
8021 "is repeated at %L",
8026 seen_logical
|= value
;
8029 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8030 && cp
->low
!= cp
->high
8031 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8033 if (warn_surprising
)
8034 gfc_warning (OPT_Wsurprising
,
8035 "Range specification at %L can never be matched",
8038 cp
->unreachable
= 1;
8039 seen_unreachable
= 1;
8043 /* If the case range can be matched, it can also overlap with
8044 other cases. To make sure it does not, we put it in a
8045 double linked list here. We sort that with a merge sort
8046 later on to detect any overlapping cases. */
8050 head
->right
= head
->left
= NULL
;
8055 tail
->right
->left
= tail
;
8062 /* It there was a failure in the previous case label, give up
8063 for this case label list. Continue with the next block. */
8067 /* See if any case labels that are unreachable have been seen.
8068 If so, we eliminate them. This is a bit of a kludge because
8069 the case lists for a single case statement (label) is a
8070 single forward linked lists. */
8071 if (seen_unreachable
)
8073 /* Advance until the first case in the list is reachable. */
8074 while (body
->ext
.block
.case_list
!= NULL
8075 && body
->ext
.block
.case_list
->unreachable
)
8077 gfc_case
*n
= body
->ext
.block
.case_list
;
8078 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8080 gfc_free_case_list (n
);
8083 /* Strip all other unreachable cases. */
8084 if (body
->ext
.block
.case_list
)
8086 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8088 if (cp
->next
->unreachable
)
8090 gfc_case
*n
= cp
->next
;
8091 cp
->next
= cp
->next
->next
;
8093 gfc_free_case_list (n
);
8100 /* See if there were overlapping cases. If the check returns NULL,
8101 there was overlap. In that case we don't do anything. If head
8102 is non-NULL, we prepend the DEFAULT case. The sorted list can
8103 then used during code generation for SELECT CASE constructs with
8104 a case expression of a CHARACTER type. */
8107 head
= check_case_overlap (head
);
8109 /* Prepend the default_case if it is there. */
8110 if (head
!= NULL
&& default_case
)
8112 default_case
->left
= NULL
;
8113 default_case
->right
= head
;
8114 head
->left
= default_case
;
8118 /* Eliminate dead blocks that may be the result if we've seen
8119 unreachable case labels for a block. */
8120 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8122 if (body
->block
->ext
.block
.case_list
== NULL
)
8124 /* Cut the unreachable block from the code chain. */
8125 gfc_code
*c
= body
->block
;
8126 body
->block
= c
->block
;
8128 /* Kill the dead block, but not the blocks below it. */
8130 gfc_free_statements (c
);
8134 /* More than two cases is legal but insane for logical selects.
8135 Issue a warning for it. */
8136 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8137 gfc_warning (OPT_Wsurprising
,
8138 "Logical SELECT CASE block at %L has more that two cases",
8143 /* Check if a derived type is extensible. */
8146 gfc_type_is_extensible (gfc_symbol
*sym
)
8148 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8149 || (sym
->attr
.is_class
8150 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8155 resolve_types (gfc_namespace
*ns
);
8157 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8158 correct as well as possibly the array-spec. */
8161 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8165 gcc_assert (sym
->assoc
);
8166 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8168 /* If this is for SELECT TYPE, the target may not yet be set. In that
8169 case, return. Resolution will be called later manually again when
8171 target
= sym
->assoc
->target
;
8174 gcc_assert (!sym
->assoc
->dangling
);
8176 if (resolve_target
&& !gfc_resolve_expr (target
))
8179 /* For variable targets, we get some attributes from the target. */
8180 if (target
->expr_type
== EXPR_VARIABLE
)
8184 gcc_assert (target
->symtree
);
8185 tsym
= target
->symtree
->n
.sym
;
8187 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8188 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8190 sym
->attr
.target
= tsym
->attr
.target
8191 || gfc_expr_attr (target
).pointer
;
8192 if (is_subref_array (target
))
8193 sym
->attr
.subref_array_pointer
= 1;
8196 /* Get type if this was not already set. Note that it can be
8197 some other type than the target in case this is a SELECT TYPE
8198 selector! So we must not update when the type is already there. */
8199 if (sym
->ts
.type
== BT_UNKNOWN
)
8200 sym
->ts
= target
->ts
;
8201 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8203 /* See if this is a valid association-to-variable. */
8204 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8205 && !gfc_has_vector_subscript (target
));
8207 /* Finally resolve if this is an array or not. */
8208 if (sym
->attr
.dimension
&& target
->rank
== 0)
8210 /* primary.c makes the assumption that a reference to an associate
8211 name followed by a left parenthesis is an array reference. */
8212 if (sym
->ts
.type
!= BT_CHARACTER
)
8213 gfc_error ("Associate-name %qs at %L is used as array",
8214 sym
->name
, &sym
->declared_at
);
8215 sym
->attr
.dimension
= 0;
8220 /* We cannot deal with class selectors that need temporaries. */
8221 if (target
->ts
.type
== BT_CLASS
8222 && gfc_ref_needs_temporary_p (target
->ref
))
8224 gfc_error ("CLASS selector at %L needs a temporary which is not "
8225 "yet implemented", &target
->where
);
8229 if (target
->ts
.type
== BT_CLASS
)
8230 gfc_fix_class_refs (target
);
8232 if (target
->rank
!= 0)
8235 /* The rank may be incorrectly guessed at parsing, therefore make sure
8236 it is corrected now. */
8237 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8240 sym
->as
= gfc_get_array_spec ();
8242 as
->rank
= target
->rank
;
8243 as
->type
= AS_DEFERRED
;
8244 as
->corank
= gfc_get_corank (target
);
8245 sym
->attr
.dimension
= 1;
8246 if (as
->corank
!= 0)
8247 sym
->attr
.codimension
= 1;
8252 /* target's rank is 0, but the type of the sym is still array valued,
8253 which has to be corrected. */
8254 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8257 symbol_attribute attr
;
8258 /* The associated variable's type is still the array type
8259 correct this now. */
8260 gfc_typespec
*ts
= &target
->ts
;
8263 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8268 ts
= &ref
->u
.c
.component
->ts
;
8271 if (ts
->type
== BT_CLASS
)
8272 ts
= &ts
->u
.derived
->components
->ts
;
8278 /* Create a scalar instance of the current class type. Because the
8279 rank of a class array goes into its name, the type has to be
8280 rebuild. The alternative of (re-)setting just the attributes
8281 and as in the current type, destroys the type also in other
8285 sym
->ts
.type
= BT_CLASS
;
8286 attr
= CLASS_DATA (sym
)->attr
;
8288 attr
.associate_var
= 1;
8289 attr
.dimension
= attr
.codimension
= 0;
8290 attr
.class_pointer
= 1;
8291 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8293 /* Make sure the _vptr is set. */
8294 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8295 if (c
->ts
.u
.derived
== NULL
)
8296 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8297 CLASS_DATA (sym
)->attr
.pointer
= 1;
8298 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8299 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8300 gfc_commit_symbol (sym
->ts
.u
.derived
);
8301 /* _vptr now has the _vtab in it, change it to the _vtype. */
8302 if (c
->ts
.u
.derived
->attr
.vtab
)
8303 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8304 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8305 resolve_types (c
->ts
.u
.derived
->ns
);
8309 /* Mark this as an associate variable. */
8310 sym
->attr
.associate_var
= 1;
8312 /* Fix up the type-spec for CHARACTER types. */
8313 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8316 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8318 if (!sym
->ts
.u
.cl
->length
)
8319 sym
->ts
.u
.cl
->length
8320 = gfc_get_int_expr (gfc_default_integer_kind
,
8321 NULL
, target
->value
.character
.length
);
8324 /* If the target is a good class object, so is the associate variable. */
8325 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8326 sym
->attr
.class_ok
= 1;
8330 /* Resolve a SELECT TYPE statement. */
8333 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8335 gfc_symbol
*selector_type
;
8336 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8337 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8340 char name
[GFC_MAX_SYMBOL_LEN
];
8345 ns
= code
->ext
.block
.ns
;
8348 /* Check for F03:C813. */
8349 if (code
->expr1
->ts
.type
!= BT_CLASS
8350 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8352 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8353 "at %L", &code
->loc
);
8357 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8362 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8363 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8364 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8366 /* F2008: C803 The selector expression must not be coindexed. */
8367 if (gfc_is_coindexed (code
->expr2
))
8369 gfc_error ("Selector at %L must not be coindexed",
8370 &code
->expr2
->where
);
8377 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8379 if (gfc_is_coindexed (code
->expr1
))
8381 gfc_error ("Selector at %L must not be coindexed",
8382 &code
->expr1
->where
);
8387 /* Loop over TYPE IS / CLASS IS cases. */
8388 for (body
= code
->block
; body
; body
= body
->block
)
8390 c
= body
->ext
.block
.case_list
;
8392 /* Check F03:C815. */
8393 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8394 && !selector_type
->attr
.unlimited_polymorphic
8395 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8397 gfc_error ("Derived type %qs at %L must be extensible",
8398 c
->ts
.u
.derived
->name
, &c
->where
);
8403 /* Check F03:C816. */
8404 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8405 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8406 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8408 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8409 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8410 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8412 gfc_error ("Unexpected intrinsic type %qs at %L",
8413 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8418 /* Check F03:C814. */
8419 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8421 gfc_error ("The type-spec at %L shall specify that each length "
8422 "type parameter is assumed", &c
->where
);
8427 /* Intercept the DEFAULT case. */
8428 if (c
->ts
.type
== BT_UNKNOWN
)
8430 /* Check F03:C818. */
8433 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8434 "by a second DEFAULT CASE at %L",
8435 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8440 default_case
= body
;
8447 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8448 target if present. If there are any EXIT statements referring to the
8449 SELECT TYPE construct, this is no problem because the gfc_code
8450 reference stays the same and EXIT is equally possible from the BLOCK
8451 it is changed to. */
8452 code
->op
= EXEC_BLOCK
;
8455 gfc_association_list
* assoc
;
8457 assoc
= gfc_get_association_list ();
8458 assoc
->st
= code
->expr1
->symtree
;
8459 assoc
->target
= gfc_copy_expr (code
->expr2
);
8460 assoc
->target
->where
= code
->expr2
->where
;
8461 /* assoc->variable will be set by resolve_assoc_var. */
8463 code
->ext
.block
.assoc
= assoc
;
8464 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8466 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8469 code
->ext
.block
.assoc
= NULL
;
8471 /* Add EXEC_SELECT to switch on type. */
8472 new_st
= gfc_get_code (code
->op
);
8473 new_st
->expr1
= code
->expr1
;
8474 new_st
->expr2
= code
->expr2
;
8475 new_st
->block
= code
->block
;
8476 code
->expr1
= code
->expr2
= NULL
;
8481 ns
->code
->next
= new_st
;
8483 code
->op
= EXEC_SELECT
;
8485 gfc_add_vptr_component (code
->expr1
);
8486 gfc_add_hash_component (code
->expr1
);
8488 /* Loop over TYPE IS / CLASS IS cases. */
8489 for (body
= code
->block
; body
; body
= body
->block
)
8491 c
= body
->ext
.block
.case_list
;
8493 if (c
->ts
.type
== BT_DERIVED
)
8494 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8495 c
->ts
.u
.derived
->hash_value
);
8496 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8501 ivtab
= gfc_find_vtab (&c
->ts
);
8502 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8503 e
= CLASS_DATA (ivtab
)->initializer
;
8504 c
->low
= c
->high
= gfc_copy_expr (e
);
8507 else if (c
->ts
.type
== BT_UNKNOWN
)
8510 /* Associate temporary to selector. This should only be done
8511 when this case is actually true, so build a new ASSOCIATE
8512 that does precisely this here (instead of using the
8515 if (c
->ts
.type
== BT_CLASS
)
8516 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8517 else if (c
->ts
.type
== BT_DERIVED
)
8518 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8519 else if (c
->ts
.type
== BT_CHARACTER
)
8521 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8522 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8523 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8524 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8525 charlen
, c
->ts
.kind
);
8528 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8531 st
= gfc_find_symtree (ns
->sym_root
, name
);
8532 gcc_assert (st
->n
.sym
->assoc
);
8533 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8534 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8535 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8536 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8538 new_st
= gfc_get_code (EXEC_BLOCK
);
8539 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8540 new_st
->ext
.block
.ns
->code
= body
->next
;
8541 body
->next
= new_st
;
8543 /* Chain in the new list only if it is marked as dangling. Otherwise
8544 there is a CASE label overlap and this is already used. Just ignore,
8545 the error is diagnosed elsewhere. */
8546 if (st
->n
.sym
->assoc
->dangling
)
8548 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8549 st
->n
.sym
->assoc
->dangling
= 0;
8552 resolve_assoc_var (st
->n
.sym
, false);
8555 /* Take out CLASS IS cases for separate treatment. */
8557 while (body
&& body
->block
)
8559 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8561 /* Add to class_is list. */
8562 if (class_is
== NULL
)
8564 class_is
= body
->block
;
8569 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8570 tail
->block
= body
->block
;
8573 /* Remove from EXEC_SELECT list. */
8574 body
->block
= body
->block
->block
;
8587 /* Add a default case to hold the CLASS IS cases. */
8588 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8589 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8591 tail
->ext
.block
.case_list
= gfc_get_case ();
8592 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8594 default_case
= tail
;
8597 /* More than one CLASS IS block? */
8598 if (class_is
->block
)
8602 /* Sort CLASS IS blocks by extension level. */
8606 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8609 /* F03:C817 (check for doubles). */
8610 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8611 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8613 gfc_error ("Double CLASS IS block in SELECT TYPE "
8615 &c2
->ext
.block
.case_list
->where
);
8618 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8619 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8622 (*c1
)->block
= c2
->block
;
8632 /* Generate IF chain. */
8633 if_st
= gfc_get_code (EXEC_IF
);
8635 for (body
= class_is
; body
; body
= body
->block
)
8637 new_st
->block
= gfc_get_code (EXEC_IF
);
8638 new_st
= new_st
->block
;
8639 /* Set up IF condition: Call _gfortran_is_extension_of. */
8640 new_st
->expr1
= gfc_get_expr ();
8641 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8642 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8643 new_st
->expr1
->ts
.kind
= 4;
8644 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8645 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8646 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8647 /* Set up arguments. */
8648 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8649 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8650 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8651 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8652 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8653 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8654 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8655 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8656 new_st
->next
= body
->next
;
8658 if (default_case
->next
)
8660 new_st
->block
= gfc_get_code (EXEC_IF
);
8661 new_st
= new_st
->block
;
8662 new_st
->next
= default_case
->next
;
8665 /* Replace CLASS DEFAULT code by the IF chain. */
8666 default_case
->next
= if_st
;
8669 /* Resolve the internal code. This can not be done earlier because
8670 it requires that the sym->assoc of selectors is set already. */
8671 gfc_current_ns
= ns
;
8672 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8673 gfc_current_ns
= old_ns
;
8675 resolve_select (code
, true);
8679 /* Resolve a transfer statement. This is making sure that:
8680 -- a derived type being transferred has only non-pointer components
8681 -- a derived type being transferred doesn't have private components, unless
8682 it's being transferred from the module where the type was defined
8683 -- we're not trying to transfer a whole assumed size array. */
8686 resolve_transfer (gfc_code
*code
)
8689 gfc_symbol
*sym
, *derived
;
8693 bool formatted
= false;
8694 gfc_dt
*dt
= code
->ext
.dt
;
8695 gfc_symbol
*dtio_sub
= NULL
;
8699 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8700 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8701 exp
= exp
->value
.op
.op1
;
8703 if (exp
&& exp
->expr_type
== EXPR_NULL
8706 gfc_error ("Invalid context for NULL () intrinsic at %L",
8711 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8712 && exp
->expr_type
!= EXPR_FUNCTION
8713 && exp
->expr_type
!= EXPR_STRUCTURE
))
8716 /* If we are reading, the variable will be changed. Note that
8717 code->ext.dt may be NULL if the TRANSFER is related to
8718 an INQUIRE statement -- but in this case, we are not reading, either. */
8719 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
8720 && !gfc_check_vardef_context (exp
, false, false, false,
8724 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8726 /* Go to actual component transferred. */
8727 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8728 if (ref
->type
== REF_COMPONENT
)
8729 ts
= &ref
->u
.c
.component
->ts
;
8731 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
8732 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
8734 if (ts
->type
== BT_DERIVED
)
8735 derived
= ts
->u
.derived
;
8737 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
8739 if (dt
->format_expr
)
8742 fmt
= gfc_widechar_to_char (dt
->format_expr
->value
.character
.string
,
8744 if (strtok (fmt
, "DT") != NULL
)
8747 else if (dt
->format_label
== &format_asterisk
)
8749 /* List directed io must call the formatted DTIO procedure. */
8753 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
8754 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
8755 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
8757 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
8760 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
8761 /* Check to see if this is a nested DTIO call, with the
8762 dummy as the io-list object. */
8763 if (sym
&& sym
== dtio_sub
&& sym
->formal
8764 && sym
->formal
->sym
== exp
->symtree
->n
.sym
8765 && exp
->ref
== NULL
)
8767 if (!sym
->attr
.recursive
)
8769 gfc_error ("DTIO %s procedure at %L must be recursive",
8770 sym
->name
, &sym
->declared_at
);
8777 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
8779 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8780 "it is processed by a defined input/output procedure",
8785 if (ts
->type
== BT_DERIVED
)
8787 /* Check that transferred derived type doesn't contain POINTER
8788 components unless it is processed by a defined input/output
8790 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
8792 gfc_error ("Data transfer element at %L cannot have POINTER "
8793 "components unless it is processed by a defined "
8794 "input/output procedure", &code
->loc
);
8799 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8801 gfc_error ("Data transfer element at %L cannot have "
8802 "procedure pointer components", &code
->loc
);
8806 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
8808 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8809 "components unless it is processed by a defined "
8810 "input/output procedure", &code
->loc
);
8814 /* C_PTR and C_FUNPTR have private components which means they can not
8815 be printed. However, if -std=gnu and not -pedantic, allow
8816 the component to be printed to help debugging. */
8817 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8819 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8820 "cannot have PRIVATE components", &code
->loc
))
8823 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
8825 gfc_error ("Data transfer element at %L cannot have "
8826 "PRIVATE components unless it is processed by "
8827 "a defined input/output procedure", &code
->loc
);
8832 if (exp
->expr_type
== EXPR_STRUCTURE
)
8835 sym
= exp
->symtree
->n
.sym
;
8837 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8838 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8840 gfc_error ("Data transfer element at %L cannot be a full reference to "
8841 "an assumed-size array", &code
->loc
);
8847 /*********** Toplevel code resolution subroutines ***********/
8849 /* Find the set of labels that are reachable from this block. We also
8850 record the last statement in each block. */
8853 find_reachable_labels (gfc_code
*block
)
8860 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8862 /* Collect labels in this block. We don't keep those corresponding
8863 to END {IF|SELECT}, these are checked in resolve_branch by going
8864 up through the code_stack. */
8865 for (c
= block
; c
; c
= c
->next
)
8867 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8868 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8871 /* Merge with labels from parent block. */
8874 gcc_assert (cs_base
->prev
->reachable_labels
);
8875 bitmap_ior_into (cs_base
->reachable_labels
,
8876 cs_base
->prev
->reachable_labels
);
8882 resolve_lock_unlock_event (gfc_code
*code
)
8884 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8885 && code
->expr1
->value
.function
.isym
8886 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8887 remove_caf_get_intrinsic (code
->expr1
);
8889 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
8890 && (code
->expr1
->ts
.type
!= BT_DERIVED
8891 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8892 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8893 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8894 || code
->expr1
->rank
!= 0
8895 || (!gfc_is_coarray (code
->expr1
) &&
8896 !gfc_is_coindexed (code
->expr1
))))
8897 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8898 &code
->expr1
->where
);
8899 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
8900 && (code
->expr1
->ts
.type
!= BT_DERIVED
8901 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8902 || code
->expr1
->ts
.u
.derived
->from_intmod
8903 != INTMOD_ISO_FORTRAN_ENV
8904 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
8905 != ISOFORTRAN_EVENT_TYPE
8906 || code
->expr1
->rank
!= 0))
8907 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
8908 &code
->expr1
->where
);
8909 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
8910 && !gfc_is_coindexed (code
->expr1
))
8911 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
8912 &code
->expr1
->where
);
8913 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
8914 gfc_error ("Event variable argument at %L must be a coarray but not "
8915 "coindexed", &code
->expr1
->where
);
8919 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8920 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8921 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8922 &code
->expr2
->where
);
8925 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8926 _("STAT variable")))
8931 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8932 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8933 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8934 &code
->expr3
->where
);
8937 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8938 _("ERRMSG variable")))
8941 /* Check for LOCK the ACQUIRED_LOCK. */
8942 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
8943 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8944 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8945 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8946 "variable", &code
->expr4
->where
);
8948 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
8949 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8950 _("ACQUIRED_LOCK variable")))
8953 /* Check for EVENT WAIT the UNTIL_COUNT. */
8954 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
8955 && (code
->expr4
->ts
.type
!= BT_INTEGER
|| code
->expr4
->rank
!= 0))
8956 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
8957 "expression", &code
->expr4
->where
);
8962 resolve_critical (gfc_code
*code
)
8964 gfc_symtree
*symtree
;
8965 gfc_symbol
*lock_type
;
8966 char name
[GFC_MAX_SYMBOL_LEN
];
8967 static int serial
= 0;
8969 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8972 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8973 GFC_PREFIX ("lock_type"));
8975 lock_type
= symtree
->n
.sym
;
8978 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8981 lock_type
= symtree
->n
.sym
;
8982 lock_type
->attr
.flavor
= FL_DERIVED
;
8983 lock_type
->attr
.zero_comp
= 1;
8984 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8985 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8988 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8989 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8992 code
->resolved_sym
= symtree
->n
.sym
;
8993 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8994 symtree
->n
.sym
->attr
.referenced
= 1;
8995 symtree
->n
.sym
->attr
.artificial
= 1;
8996 symtree
->n
.sym
->attr
.codimension
= 1;
8997 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8998 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8999 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9000 symtree
->n
.sym
->as
->corank
= 1;
9001 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9002 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9003 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9005 gfc_commit_symbols();
9010 resolve_sync (gfc_code
*code
)
9012 /* Check imageset. The * case matches expr1 == NULL. */
9015 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9016 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9017 "INTEGER expression", &code
->expr1
->where
);
9018 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9019 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9020 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9021 &code
->expr1
->where
);
9022 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9023 && gfc_simplify_expr (code
->expr1
, 0))
9025 gfc_constructor
*cons
;
9026 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9027 for (; cons
; cons
= gfc_constructor_next (cons
))
9028 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9029 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9030 gfc_error ("Imageset argument at %L must between 1 and "
9031 "num_images()", &cons
->expr
->where
);
9037 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9038 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9039 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9040 &code
->expr2
->where
);
9044 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9045 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9046 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9047 &code
->expr3
->where
);
9051 /* Given a branch to a label, see if the branch is conforming.
9052 The code node describes where the branch is located. */
9055 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9062 /* Step one: is this a valid branching target? */
9064 if (label
->defined
== ST_LABEL_UNKNOWN
)
9066 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9071 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9073 gfc_error ("Statement at %L is not a valid branch target statement "
9074 "for the branch statement at %L", &label
->where
, &code
->loc
);
9078 /* Step two: make sure this branch is not a branch to itself ;-) */
9080 if (code
->here
== label
)
9083 "Branch at %L may result in an infinite loop", &code
->loc
);
9087 /* Step three: See if the label is in the same block as the
9088 branching statement. The hard work has been done by setting up
9089 the bitmap reachable_labels. */
9091 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9093 /* Check now whether there is a CRITICAL construct; if so, check
9094 whether the label is still visible outside of the CRITICAL block,
9095 which is invalid. */
9096 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9098 if (stack
->current
->op
== EXEC_CRITICAL
9099 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9100 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9101 "label at %L", &code
->loc
, &label
->where
);
9102 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9103 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9104 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9105 "for label at %L", &code
->loc
, &label
->where
);
9111 /* Step four: If we haven't found the label in the bitmap, it may
9112 still be the label of the END of the enclosing block, in which
9113 case we find it by going up the code_stack. */
9115 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9117 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9119 if (stack
->current
->op
== EXEC_CRITICAL
)
9121 /* Note: A label at END CRITICAL does not leave the CRITICAL
9122 construct as END CRITICAL is still part of it. */
9123 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9124 " at %L", &code
->loc
, &label
->where
);
9127 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9129 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9130 "label at %L", &code
->loc
, &label
->where
);
9137 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9141 /* The label is not in an enclosing block, so illegal. This was
9142 allowed in Fortran 66, so we allow it as extension. No
9143 further checks are necessary in this case. */
9144 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9145 "as the GOTO statement at %L", &label
->where
,
9151 /* Check whether EXPR1 has the same shape as EXPR2. */
9154 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9156 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9157 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9158 bool result
= false;
9161 /* Compare the rank. */
9162 if (expr1
->rank
!= expr2
->rank
)
9165 /* Compare the size of each dimension. */
9166 for (i
=0; i
<expr1
->rank
; i
++)
9168 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9171 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9174 if (mpz_cmp (shape
[i
], shape2
[i
]))
9178 /* When either of the two expression is an assumed size array, we
9179 ignore the comparison of dimension sizes. */
9184 gfc_clear_shape (shape
, i
);
9185 gfc_clear_shape (shape2
, i
);
9190 /* Check whether a WHERE assignment target or a WHERE mask expression
9191 has the same shape as the outmost WHERE mask expression. */
9194 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9200 cblock
= code
->block
;
9202 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9203 In case of nested WHERE, only the outmost one is stored. */
9204 if (mask
== NULL
) /* outmost WHERE */
9206 else /* inner WHERE */
9213 /* Check if the mask-expr has a consistent shape with the
9214 outmost WHERE mask-expr. */
9215 if (!resolve_where_shape (cblock
->expr1
, e
))
9216 gfc_error ("WHERE mask at %L has inconsistent shape",
9217 &cblock
->expr1
->where
);
9220 /* the assignment statement of a WHERE statement, or the first
9221 statement in where-body-construct of a WHERE construct */
9222 cnext
= cblock
->next
;
9227 /* WHERE assignment statement */
9230 /* Check shape consistent for WHERE assignment target. */
9231 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9232 gfc_error ("WHERE assignment target at %L has "
9233 "inconsistent shape", &cnext
->expr1
->where
);
9237 case EXEC_ASSIGN_CALL
:
9238 resolve_call (cnext
);
9239 if (!cnext
->resolved_sym
->attr
.elemental
)
9240 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9241 &cnext
->ext
.actual
->expr
->where
);
9244 /* WHERE or WHERE construct is part of a where-body-construct */
9246 resolve_where (cnext
, e
);
9250 gfc_error ("Unsupported statement inside WHERE at %L",
9253 /* the next statement within the same where-body-construct */
9254 cnext
= cnext
->next
;
9256 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9257 cblock
= cblock
->block
;
9262 /* Resolve assignment in FORALL construct.
9263 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9264 FORALL index variables. */
9267 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9271 for (n
= 0; n
< nvar
; n
++)
9273 gfc_symbol
*forall_index
;
9275 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9277 /* Check whether the assignment target is one of the FORALL index
9279 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9280 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9281 gfc_error ("Assignment to a FORALL index variable at %L",
9282 &code
->expr1
->where
);
9285 /* If one of the FORALL index variables doesn't appear in the
9286 assignment variable, then there could be a many-to-one
9287 assignment. Emit a warning rather than an error because the
9288 mask could be resolving this problem. */
9289 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9290 gfc_warning (0, "The FORALL with index %qs is not used on the "
9291 "left side of the assignment at %L and so might "
9292 "cause multiple assignment to this object",
9293 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9299 /* Resolve WHERE statement in FORALL construct. */
9302 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9303 gfc_expr
**var_expr
)
9308 cblock
= code
->block
;
9311 /* the assignment statement of a WHERE statement, or the first
9312 statement in where-body-construct of a WHERE construct */
9313 cnext
= cblock
->next
;
9318 /* WHERE assignment statement */
9320 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9323 /* WHERE operator assignment statement */
9324 case EXEC_ASSIGN_CALL
:
9325 resolve_call (cnext
);
9326 if (!cnext
->resolved_sym
->attr
.elemental
)
9327 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9328 &cnext
->ext
.actual
->expr
->where
);
9331 /* WHERE or WHERE construct is part of a where-body-construct */
9333 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9337 gfc_error ("Unsupported statement inside WHERE at %L",
9340 /* the next statement within the same where-body-construct */
9341 cnext
= cnext
->next
;
9343 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9344 cblock
= cblock
->block
;
9349 /* Traverse the FORALL body to check whether the following errors exist:
9350 1. For assignment, check if a many-to-one assignment happens.
9351 2. For WHERE statement, check the WHERE body to see if there is any
9352 many-to-one assignment. */
9355 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9359 c
= code
->block
->next
;
9365 case EXEC_POINTER_ASSIGN
:
9366 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9369 case EXEC_ASSIGN_CALL
:
9373 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9374 there is no need to handle it here. */
9378 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9383 /* The next statement in the FORALL body. */
9389 /* Counts the number of iterators needed inside a forall construct, including
9390 nested forall constructs. This is used to allocate the needed memory
9391 in gfc_resolve_forall. */
9394 gfc_count_forall_iterators (gfc_code
*code
)
9396 int max_iters
, sub_iters
, current_iters
;
9397 gfc_forall_iterator
*fa
;
9399 gcc_assert(code
->op
== EXEC_FORALL
);
9403 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9406 code
= code
->block
->next
;
9410 if (code
->op
== EXEC_FORALL
)
9412 sub_iters
= gfc_count_forall_iterators (code
);
9413 if (sub_iters
> max_iters
)
9414 max_iters
= sub_iters
;
9419 return current_iters
+ max_iters
;
9423 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9424 gfc_resolve_forall_body to resolve the FORALL body. */
9427 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9429 static gfc_expr
**var_expr
;
9430 static int total_var
= 0;
9431 static int nvar
= 0;
9433 gfc_forall_iterator
*fa
;
9438 /* Start to resolve a FORALL construct */
9439 if (forall_save
== 0)
9441 /* Count the total number of FORALL index in the nested FORALL
9442 construct in order to allocate the VAR_EXPR with proper size. */
9443 total_var
= gfc_count_forall_iterators (code
);
9445 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9446 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9449 /* The information about FORALL iterator, including FORALL index start, end
9450 and stride. The FORALL index can not appear in start, end or stride. */
9451 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9453 /* Check if any outer FORALL index name is the same as the current
9455 for (i
= 0; i
< nvar
; i
++)
9457 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9459 gfc_error ("An outer FORALL construct already has an index "
9460 "with this name %L", &fa
->var
->where
);
9464 /* Record the current FORALL index. */
9465 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9469 /* No memory leak. */
9470 gcc_assert (nvar
<= total_var
);
9473 /* Resolve the FORALL body. */
9474 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9476 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9477 gfc_resolve_blocks (code
->block
, ns
);
9481 /* Free only the VAR_EXPRs allocated in this frame. */
9482 for (i
= nvar
; i
< tmp
; i
++)
9483 gfc_free_expr (var_expr
[i
]);
9487 /* We are in the outermost FORALL construct. */
9488 gcc_assert (forall_save
== 0);
9490 /* VAR_EXPR is not needed any more. */
9497 /* Resolve a BLOCK construct statement. */
9500 resolve_block_construct (gfc_code
* code
)
9502 /* Resolve the BLOCK's namespace. */
9503 gfc_resolve (code
->ext
.block
.ns
);
9505 /* For an ASSOCIATE block, the associations (and their targets) are already
9506 resolved during resolve_symbol. */
9510 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9514 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9518 for (; b
; b
= b
->block
)
9520 t
= gfc_resolve_expr (b
->expr1
);
9521 if (!gfc_resolve_expr (b
->expr2
))
9527 if (t
&& b
->expr1
!= NULL
9528 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9529 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9536 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9537 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9542 resolve_branch (b
->label1
, b
);
9546 resolve_block_construct (b
);
9550 case EXEC_SELECT_TYPE
:
9554 case EXEC_DO_CONCURRENT
:
9562 case EXEC_OMP_ATOMIC
:
9563 case EXEC_OACC_ATOMIC
:
9565 gfc_omp_atomic_op aop
9566 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
9568 /* Verify this before calling gfc_resolve_code, which might
9570 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
9571 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
9572 && b
->next
->next
== NULL
)
9573 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
9574 && b
->next
->next
!= NULL
9575 && b
->next
->next
->op
== EXEC_ASSIGN
9576 && b
->next
->next
->next
== NULL
));
9580 case EXEC_OACC_PARALLEL_LOOP
:
9581 case EXEC_OACC_PARALLEL
:
9582 case EXEC_OACC_KERNELS_LOOP
:
9583 case EXEC_OACC_KERNELS
:
9584 case EXEC_OACC_DATA
:
9585 case EXEC_OACC_HOST_DATA
:
9586 case EXEC_OACC_LOOP
:
9587 case EXEC_OACC_UPDATE
:
9588 case EXEC_OACC_WAIT
:
9589 case EXEC_OACC_CACHE
:
9590 case EXEC_OACC_ENTER_DATA
:
9591 case EXEC_OACC_EXIT_DATA
:
9592 case EXEC_OACC_ROUTINE
:
9593 case EXEC_OMP_CRITICAL
:
9594 case EXEC_OMP_DISTRIBUTE
:
9595 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9596 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9597 case EXEC_OMP_DISTRIBUTE_SIMD
:
9599 case EXEC_OMP_DO_SIMD
:
9600 case EXEC_OMP_MASTER
:
9601 case EXEC_OMP_ORDERED
:
9602 case EXEC_OMP_PARALLEL
:
9603 case EXEC_OMP_PARALLEL_DO
:
9604 case EXEC_OMP_PARALLEL_DO_SIMD
:
9605 case EXEC_OMP_PARALLEL_SECTIONS
:
9606 case EXEC_OMP_PARALLEL_WORKSHARE
:
9607 case EXEC_OMP_SECTIONS
:
9609 case EXEC_OMP_SINGLE
:
9610 case EXEC_OMP_TARGET
:
9611 case EXEC_OMP_TARGET_DATA
:
9612 case EXEC_OMP_TARGET_TEAMS
:
9613 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9614 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9615 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9616 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9617 case EXEC_OMP_TARGET_UPDATE
:
9619 case EXEC_OMP_TASKGROUP
:
9620 case EXEC_OMP_TASKWAIT
:
9621 case EXEC_OMP_TASKYIELD
:
9622 case EXEC_OMP_TEAMS
:
9623 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9624 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9625 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9626 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9627 case EXEC_OMP_WORKSHARE
:
9631 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9634 gfc_resolve_code (b
->next
, ns
);
9639 /* Does everything to resolve an ordinary assignment. Returns true
9640 if this is an interface assignment. */
9642 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9651 symbol_attribute attr
;
9653 if (gfc_extend_assign (code
, ns
))
9657 if (code
->op
== EXEC_ASSIGN_CALL
)
9659 lhs
= code
->ext
.actual
->expr
;
9660 rhsptr
= &code
->ext
.actual
->next
->expr
;
9664 gfc_actual_arglist
* args
;
9665 gfc_typebound_proc
* tbp
;
9667 gcc_assert (code
->op
== EXEC_COMPCALL
);
9669 args
= code
->expr1
->value
.compcall
.actual
;
9671 rhsptr
= &args
->next
->expr
;
9673 tbp
= code
->expr1
->value
.compcall
.tbp
;
9674 gcc_assert (!tbp
->is_generic
);
9677 /* Make a temporary rhs when there is a default initializer
9678 and rhs is the same symbol as the lhs. */
9679 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9680 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9681 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9682 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9683 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9692 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9693 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9697 /* Handle the case of a BOZ literal on the RHS. */
9698 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9701 if (warn_surprising
)
9702 gfc_warning (OPT_Wsurprising
,
9703 "BOZ literal at %L is bitwise transferred "
9704 "non-integer symbol %qs", &code
->loc
,
9705 lhs
->symtree
->n
.sym
->name
);
9707 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9709 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9711 if (rc
== ARITH_UNDERFLOW
)
9712 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9713 ". This check can be disabled with the option "
9714 "%<-fno-range-check%>", &rhs
->where
);
9715 else if (rc
== ARITH_OVERFLOW
)
9716 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9717 ". This check can be disabled with the option "
9718 "%<-fno-range-check%>", &rhs
->where
);
9719 else if (rc
== ARITH_NAN
)
9720 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9721 ". This check can be disabled with the option "
9722 "%<-fno-range-check%>", &rhs
->where
);
9727 if (lhs
->ts
.type
== BT_CHARACTER
9728 && warn_character_truncation
)
9730 if (lhs
->ts
.u
.cl
!= NULL
9731 && lhs
->ts
.u
.cl
->length
!= NULL
9732 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9733 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9735 if (rhs
->expr_type
== EXPR_CONSTANT
)
9736 rlen
= rhs
->value
.character
.length
;
9738 else if (rhs
->ts
.u
.cl
!= NULL
9739 && rhs
->ts
.u
.cl
->length
!= NULL
9740 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9741 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9743 if (rlen
&& llen
&& rlen
> llen
)
9744 gfc_warning_now (OPT_Wcharacter_truncation
,
9745 "CHARACTER expression will be truncated "
9746 "in assignment (%d/%d) at %L",
9747 llen
, rlen
, &code
->loc
);
9750 /* Ensure that a vector index expression for the lvalue is evaluated
9751 to a temporary if the lvalue symbol is referenced in it. */
9754 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9755 if (ref
->type
== REF_ARRAY
)
9757 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9758 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9759 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9760 ref
->u
.ar
.start
[n
]))
9762 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9766 if (gfc_pure (NULL
))
9768 if (lhs
->ts
.type
== BT_DERIVED
9769 && lhs
->expr_type
== EXPR_VARIABLE
9770 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9771 && rhs
->expr_type
== EXPR_VARIABLE
9772 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9773 || gfc_is_coindexed (rhs
)))
9776 if (gfc_is_coindexed (rhs
))
9777 gfc_error ("Coindexed expression at %L is assigned to "
9778 "a derived type variable with a POINTER "
9779 "component in a PURE procedure",
9782 gfc_error ("The impure variable at %L is assigned to "
9783 "a derived type variable with a POINTER "
9784 "component in a PURE procedure (12.6)",
9789 /* Fortran 2008, C1283. */
9790 if (gfc_is_coindexed (lhs
))
9792 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9793 "procedure", &rhs
->where
);
9798 if (gfc_implicit_pure (NULL
))
9800 if (lhs
->expr_type
== EXPR_VARIABLE
9801 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9802 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9803 gfc_unset_implicit_pure (NULL
);
9805 if (lhs
->ts
.type
== BT_DERIVED
9806 && lhs
->expr_type
== EXPR_VARIABLE
9807 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9808 && rhs
->expr_type
== EXPR_VARIABLE
9809 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9810 || gfc_is_coindexed (rhs
)))
9811 gfc_unset_implicit_pure (NULL
);
9813 /* Fortran 2008, C1283. */
9814 if (gfc_is_coindexed (lhs
))
9815 gfc_unset_implicit_pure (NULL
);
9818 /* F2008, 7.2.1.2. */
9819 attr
= gfc_expr_attr (lhs
);
9820 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9822 if (attr
.codimension
)
9824 gfc_error ("Assignment to polymorphic coarray at %L is not "
9825 "permitted", &lhs
->where
);
9828 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9829 "polymorphic variable at %L", &lhs
->where
))
9831 if (!flag_realloc_lhs
)
9833 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9834 "requires %<-frealloc-lhs%>", &lhs
->where
);
9838 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9839 "is not yet supported", &lhs
->where
);
9842 else if (lhs
->ts
.type
== BT_CLASS
)
9844 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9845 "assignment at %L - check that there is a matching specific "
9846 "subroutine for '=' operator", &lhs
->where
);
9850 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9852 /* F2008, Section 7.2.1.2. */
9853 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9855 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9856 "component in assignment at %L", &lhs
->where
);
9860 /* Assign the 'data' of a class object to a derived type. */
9861 if (lhs
->ts
.type
== BT_DERIVED
9862 && rhs
->ts
.type
== BT_CLASS
)
9863 gfc_add_data_component (rhs
);
9865 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
9867 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9868 && code
->expr2
->value
.function
.isym
9869 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9870 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9871 && !gfc_expr_attr (rhs
).allocatable
9872 && !gfc_has_vector_subscript (rhs
)));
9874 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
9876 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9877 Additionally, insert this code when the RHS is a CAF as we then use the
9878 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9879 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9880 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9882 if (caf_convert_to_send
)
9884 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9885 && code
->expr2
->value
.function
.isym
9886 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9887 remove_caf_get_intrinsic (code
->expr2
);
9888 code
->op
= EXEC_CALL
;
9889 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9890 code
->resolved_sym
= code
->symtree
->n
.sym
;
9891 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9892 code
->resolved_sym
->attr
.intrinsic
= 1;
9893 code
->resolved_sym
->attr
.subroutine
= 1;
9894 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9895 gfc_commit_symbol (code
->resolved_sym
);
9896 code
->ext
.actual
= gfc_get_actual_arglist ();
9897 code
->ext
.actual
->expr
= lhs
;
9898 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9899 code
->ext
.actual
->next
->expr
= rhs
;
9908 /* Add a component reference onto an expression. */
9911 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9916 ref
= &((*ref
)->next
);
9917 *ref
= gfc_get_ref ();
9918 (*ref
)->type
= REF_COMPONENT
;
9919 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9920 (*ref
)->u
.c
.component
= c
;
9923 /* Add a full array ref, as necessary. */
9926 gfc_add_full_array_ref (e
, c
->as
);
9927 e
->rank
= c
->as
->rank
;
9932 /* Build an assignment. Keep the argument 'op' for future use, so that
9933 pointer assignments can be made. */
9936 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9937 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9939 gfc_code
*this_code
;
9941 this_code
= gfc_get_code (op
);
9942 this_code
->next
= NULL
;
9943 this_code
->expr1
= gfc_copy_expr (expr1
);
9944 this_code
->expr2
= gfc_copy_expr (expr2
);
9945 this_code
->loc
= loc
;
9948 add_comp_ref (this_code
->expr1
, comp1
);
9949 add_comp_ref (this_code
->expr2
, comp2
);
9956 /* Makes a temporary variable expression based on the characteristics of
9957 a given variable expression. */
9960 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9962 static int serial
= 0;
9963 char name
[GFC_MAX_SYMBOL_LEN
];
9966 gfc_array_ref
*aref
;
9969 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9970 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9971 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9977 /* Obtain the arrayspec for the temporary. */
9978 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
9979 && e
->expr_type
!= EXPR_FUNCTION
9980 && e
->expr_type
!= EXPR_OP
)
9982 aref
= gfc_find_array_ref (e
);
9983 if (e
->expr_type
== EXPR_VARIABLE
9984 && e
->symtree
->n
.sym
->as
== aref
->as
)
9988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9989 if (ref
->type
== REF_COMPONENT
9990 && ref
->u
.c
.component
->as
== aref
->as
)
9998 /* Add the attributes and the arrayspec to the temporary. */
9999 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10000 tmp
->n
.sym
->attr
.function
= 0;
10001 tmp
->n
.sym
->attr
.result
= 0;
10002 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10006 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10009 if (as
->type
== AS_DEFERRED
)
10010 tmp
->n
.sym
->attr
.allocatable
= 1;
10012 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10013 || e
->expr_type
== EXPR_FUNCTION
10014 || e
->expr_type
== EXPR_OP
))
10016 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10017 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10018 tmp
->n
.sym
->as
->rank
= e
->rank
;
10019 tmp
->n
.sym
->attr
.allocatable
= 1;
10020 tmp
->n
.sym
->attr
.dimension
= 1;
10023 tmp
->n
.sym
->attr
.dimension
= 0;
10025 gfc_set_sym_referenced (tmp
->n
.sym
);
10026 gfc_commit_symbol (tmp
->n
.sym
);
10027 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10029 /* Should the lhs be a section, use its array ref for the
10030 temporary expression. */
10031 if (aref
&& aref
->type
!= AR_FULL
)
10033 gfc_free_ref_list (e
->ref
);
10034 e
->ref
= gfc_copy_ref (ref
);
10040 /* Add one line of code to the code chain, making sure that 'head' and
10041 'tail' are appropriately updated. */
10044 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10046 gcc_assert (this_code
);
10048 *head
= *tail
= *this_code
;
10050 *tail
= gfc_append_code (*tail
, *this_code
);
10055 /* Counts the potential number of part array references that would
10056 result from resolution of typebound defined assignments. */
10059 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10062 int c_depth
= 0, t_depth
;
10064 for (c
= derived
->components
; c
; c
= c
->next
)
10066 if ((!gfc_bt_struct (c
->ts
.type
)
10068 || c
->attr
.allocatable
10069 || c
->attr
.proc_pointer_comp
10070 || c
->attr
.class_pointer
10071 || c
->attr
.proc_pointer
)
10072 && !c
->attr
.defined_assign_comp
)
10075 if (c
->as
&& c_depth
== 0)
10078 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10079 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10084 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10086 return depth
+ c_depth
;
10090 /* Implement 7.2.1.3 of the F08 standard:
10091 "An intrinsic assignment where the variable is of derived type is
10092 performed as if each component of the variable were assigned from the
10093 corresponding component of expr using pointer assignment (7.2.2) for
10094 each pointer component, defined assignment for each nonpointer
10095 nonallocatable component of a type that has a type-bound defined
10096 assignment consistent with the component, intrinsic assignment for
10097 each other nonpointer nonallocatable component, ..."
10099 The pointer assignments are taken care of by the intrinsic
10100 assignment of the structure itself. This function recursively adds
10101 defined assignments where required. The recursion is accomplished
10102 by calling gfc_resolve_code.
10104 When the lhs in a defined assignment has intent INOUT, we need a
10105 temporary for the lhs. In pseudo-code:
10107 ! Only call function lhs once.
10108 if (lhs is not a constant or an variable)
10111 ! Do the intrinsic assignment
10113 ! Now do the defined assignments
10114 do over components with typebound defined assignment [%cmp]
10115 #if one component's assignment procedure is INOUT
10117 #if expr2 non-variable
10123 t1%cmp {defined=} expr2%cmp
10129 expr1%cmp {defined=} expr2%cmp
10133 /* The temporary assignments have to be put on top of the additional
10134 code to avoid the result being changed by the intrinsic assignment.
10136 static int component_assignment_level
= 0;
10137 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10140 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10142 gfc_component
*comp1
, *comp2
;
10143 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10145 int error_count
, depth
;
10147 gfc_get_errors (NULL
, &error_count
);
10149 /* Filter out continuing processing after an error. */
10151 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10152 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10155 /* TODO: Handle more than one part array reference in assignments. */
10156 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10157 (*code
)->expr1
->rank
? 1 : 0);
10160 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10161 "done because multiple part array references would "
10162 "occur in intermediate expressions.", &(*code
)->loc
);
10166 component_assignment_level
++;
10168 /* Create a temporary so that functions get called only once. */
10169 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10170 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10172 gfc_expr
*tmp_expr
;
10174 /* Assign the rhs to the temporary. */
10175 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10176 this_code
= build_assignment (EXEC_ASSIGN
,
10177 tmp_expr
, (*code
)->expr2
,
10178 NULL
, NULL
, (*code
)->loc
);
10179 /* Add the code and substitute the rhs expression. */
10180 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10181 gfc_free_expr ((*code
)->expr2
);
10182 (*code
)->expr2
= tmp_expr
;
10185 /* Do the intrinsic assignment. This is not needed if the lhs is one
10186 of the temporaries generated here, since the intrinsic assignment
10187 to the final result already does this. */
10188 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10190 this_code
= build_assignment (EXEC_ASSIGN
,
10191 (*code
)->expr1
, (*code
)->expr2
,
10192 NULL
, NULL
, (*code
)->loc
);
10193 add_code_to_chain (&this_code
, &head
, &tail
);
10196 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10197 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10200 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10202 bool inout
= false;
10204 /* The intrinsic assignment does the right thing for pointers
10205 of all kinds and allocatable components. */
10206 if (!gfc_bt_struct (comp1
->ts
.type
)
10207 || comp1
->attr
.pointer
10208 || comp1
->attr
.allocatable
10209 || comp1
->attr
.proc_pointer_comp
10210 || comp1
->attr
.class_pointer
10211 || comp1
->attr
.proc_pointer
)
10214 /* Make an assigment for this component. */
10215 this_code
= build_assignment (EXEC_ASSIGN
,
10216 (*code
)->expr1
, (*code
)->expr2
,
10217 comp1
, comp2
, (*code
)->loc
);
10219 /* Convert the assignment if there is a defined assignment for
10220 this type. Otherwise, using the call from gfc_resolve_code,
10221 recurse into its components. */
10222 gfc_resolve_code (this_code
, ns
);
10224 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10226 gfc_formal_arglist
*dummy_args
;
10228 /* Check that there is a typebound defined assignment. If not,
10229 then this must be a module defined assignment. We cannot
10230 use the defined_assign_comp attribute here because it must
10231 be this derived type that has the defined assignment and not
10233 if (!(comp1
->ts
.u
.derived
->f2k_derived
10234 && comp1
->ts
.u
.derived
->f2k_derived
10235 ->tb_op
[INTRINSIC_ASSIGN
]))
10237 gfc_free_statements (this_code
);
10242 /* If the first argument of the subroutine has intent INOUT
10243 a temporary must be generated and used instead. */
10244 rsym
= this_code
->resolved_sym
;
10245 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10247 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10249 gfc_code
*temp_code
;
10252 /* Build the temporary required for the assignment and put
10253 it at the head of the generated code. */
10256 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10257 temp_code
= build_assignment (EXEC_ASSIGN
,
10258 t1
, (*code
)->expr1
,
10259 NULL
, NULL
, (*code
)->loc
);
10261 /* For allocatable LHS, check whether it is allocated. Note
10262 that allocatable components with defined assignment are
10263 not yet support. See PR 57696. */
10264 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10268 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10269 block
= gfc_get_code (EXEC_IF
);
10270 block
->block
= gfc_get_code (EXEC_IF
);
10271 block
->block
->expr1
10272 = gfc_build_intrinsic_call (ns
,
10273 GFC_ISYM_ALLOCATED
, "allocated",
10274 (*code
)->loc
, 1, e
);
10275 block
->block
->next
= temp_code
;
10278 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10281 /* Replace the first actual arg with the component of the
10283 gfc_free_expr (this_code
->ext
.actual
->expr
);
10284 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10285 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10287 /* If the LHS variable is allocatable and wasn't allocated and
10288 the temporary is allocatable, pointer assign the address of
10289 the freshly allocated LHS to the temporary. */
10290 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10291 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10296 cond
= gfc_get_expr ();
10297 cond
->ts
.type
= BT_LOGICAL
;
10298 cond
->ts
.kind
= gfc_default_logical_kind
;
10299 cond
->expr_type
= EXPR_OP
;
10300 cond
->where
= (*code
)->loc
;
10301 cond
->value
.op
.op
= INTRINSIC_NOT
;
10302 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10303 GFC_ISYM_ALLOCATED
, "allocated",
10304 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10305 block
= gfc_get_code (EXEC_IF
);
10306 block
->block
= gfc_get_code (EXEC_IF
);
10307 block
->block
->expr1
= cond
;
10308 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10309 t1
, (*code
)->expr1
,
10310 NULL
, NULL
, (*code
)->loc
);
10311 add_code_to_chain (&block
, &head
, &tail
);
10315 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10317 /* Don't add intrinsic assignments since they are already
10318 effected by the intrinsic assignment of the structure. */
10319 gfc_free_statements (this_code
);
10324 add_code_to_chain (&this_code
, &head
, &tail
);
10328 /* Transfer the value to the final result. */
10329 this_code
= build_assignment (EXEC_ASSIGN
,
10330 (*code
)->expr1
, t1
,
10331 comp1
, comp2
, (*code
)->loc
);
10332 add_code_to_chain (&this_code
, &head
, &tail
);
10336 /* Put the temporary assignments at the top of the generated code. */
10337 if (tmp_head
&& component_assignment_level
== 1)
10339 gfc_append_code (tmp_head
, head
);
10341 tmp_head
= tmp_tail
= NULL
;
10344 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10345 // not accidentally deallocated. Hence, nullify t1.
10346 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10347 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10353 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10354 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10355 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10356 block
= gfc_get_code (EXEC_IF
);
10357 block
->block
= gfc_get_code (EXEC_IF
);
10358 block
->block
->expr1
= cond
;
10359 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10360 t1
, gfc_get_null_expr (&(*code
)->loc
),
10361 NULL
, NULL
, (*code
)->loc
);
10362 gfc_append_code (tail
, block
);
10366 /* Now attach the remaining code chain to the input code. Step on
10367 to the end of the new code since resolution is complete. */
10368 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10369 tail
->next
= (*code
)->next
;
10370 /* Overwrite 'code' because this would place the intrinsic assignment
10371 before the temporary for the lhs is created. */
10372 gfc_free_expr ((*code
)->expr1
);
10373 gfc_free_expr ((*code
)->expr2
);
10379 component_assignment_level
--;
10383 /* F2008: Pointer function assignments are of the form:
10384 ptr_fcn (args) = expr
10385 This function breaks these assignments into two statements:
10386 temporary_pointer => ptr_fcn(args)
10387 temporary_pointer = expr */
10390 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10392 gfc_expr
*tmp_ptr_expr
;
10393 gfc_code
*this_code
;
10394 gfc_component
*comp
;
10397 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10400 /* Even if standard does not support this feature, continue to build
10401 the two statements to avoid upsetting frontend_passes.c. */
10402 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10403 "%L", &(*code
)->loc
);
10405 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10408 s
= comp
->ts
.interface
;
10410 s
= (*code
)->expr1
->symtree
->n
.sym
;
10412 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10414 gfc_error ("The function result on the lhs of the assignment at "
10415 "%L must have the pointer attribute.",
10416 &(*code
)->expr1
->where
);
10417 (*code
)->op
= EXEC_NOP
;
10421 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10423 /* get_temp_from_expression is set up for ordinary assignments. To that
10424 end, where array bounds are not known, arrays are made allocatable.
10425 Change the temporary to a pointer here. */
10426 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10427 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10428 tmp_ptr_expr
->where
= (*code
)->loc
;
10430 this_code
= build_assignment (EXEC_ASSIGN
,
10431 tmp_ptr_expr
, (*code
)->expr2
,
10432 NULL
, NULL
, (*code
)->loc
);
10433 this_code
->next
= (*code
)->next
;
10434 (*code
)->next
= this_code
;
10435 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10436 (*code
)->expr2
= (*code
)->expr1
;
10437 (*code
)->expr1
= tmp_ptr_expr
;
10443 /* Deferred character length assignments from an operator expression
10444 require a temporary because the character length of the lhs can
10445 change in the course of the assignment. */
10448 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10450 gfc_expr
*tmp_expr
;
10451 gfc_code
*this_code
;
10453 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10454 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10455 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10458 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10461 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10462 tmp_expr
->where
= (*code
)->loc
;
10464 /* A new charlen is required to ensure that the variable string
10465 length is different to that of the original lhs. */
10466 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10467 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10468 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10469 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10471 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10473 this_code
= build_assignment (EXEC_ASSIGN
,
10475 gfc_copy_expr (tmp_expr
),
10476 NULL
, NULL
, (*code
)->loc
);
10478 (*code
)->expr1
= tmp_expr
;
10480 this_code
->next
= (*code
)->next
;
10481 (*code
)->next
= this_code
;
10487 /* Given a block of code, recursively resolve everything pointed to by this
10491 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10493 int omp_workshare_save
;
10494 int forall_save
, do_concurrent_save
;
10498 frame
.prev
= cs_base
;
10502 find_reachable_labels (code
);
10504 for (; code
; code
= code
->next
)
10506 frame
.current
= code
;
10507 forall_save
= forall_flag
;
10508 do_concurrent_save
= gfc_do_concurrent_flag
;
10510 if (code
->op
== EXEC_FORALL
)
10513 gfc_resolve_forall (code
, ns
, forall_save
);
10516 else if (code
->block
)
10518 omp_workshare_save
= -1;
10521 case EXEC_OACC_PARALLEL_LOOP
:
10522 case EXEC_OACC_PARALLEL
:
10523 case EXEC_OACC_KERNELS_LOOP
:
10524 case EXEC_OACC_KERNELS
:
10525 case EXEC_OACC_DATA
:
10526 case EXEC_OACC_HOST_DATA
:
10527 case EXEC_OACC_LOOP
:
10528 gfc_resolve_oacc_blocks (code
, ns
);
10530 case EXEC_OMP_PARALLEL_WORKSHARE
:
10531 omp_workshare_save
= omp_workshare_flag
;
10532 omp_workshare_flag
= 1;
10533 gfc_resolve_omp_parallel_blocks (code
, ns
);
10535 case EXEC_OMP_PARALLEL
:
10536 case EXEC_OMP_PARALLEL_DO
:
10537 case EXEC_OMP_PARALLEL_DO_SIMD
:
10538 case EXEC_OMP_PARALLEL_SECTIONS
:
10539 case EXEC_OMP_TARGET_TEAMS
:
10540 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10541 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10542 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10543 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10544 case EXEC_OMP_TASK
:
10545 case EXEC_OMP_TEAMS
:
10546 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10547 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10548 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10549 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10550 omp_workshare_save
= omp_workshare_flag
;
10551 omp_workshare_flag
= 0;
10552 gfc_resolve_omp_parallel_blocks (code
, ns
);
10554 case EXEC_OMP_DISTRIBUTE
:
10555 case EXEC_OMP_DISTRIBUTE_SIMD
:
10557 case EXEC_OMP_DO_SIMD
:
10558 case EXEC_OMP_SIMD
:
10559 gfc_resolve_omp_do_blocks (code
, ns
);
10561 case EXEC_SELECT_TYPE
:
10562 /* Blocks are handled in resolve_select_type because we have
10563 to transform the SELECT TYPE into ASSOCIATE first. */
10565 case EXEC_DO_CONCURRENT
:
10566 gfc_do_concurrent_flag
= 1;
10567 gfc_resolve_blocks (code
->block
, ns
);
10568 gfc_do_concurrent_flag
= 2;
10570 case EXEC_OMP_WORKSHARE
:
10571 omp_workshare_save
= omp_workshare_flag
;
10572 omp_workshare_flag
= 1;
10575 gfc_resolve_blocks (code
->block
, ns
);
10579 if (omp_workshare_save
!= -1)
10580 omp_workshare_flag
= omp_workshare_save
;
10584 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10585 t
= gfc_resolve_expr (code
->expr1
);
10586 forall_flag
= forall_save
;
10587 gfc_do_concurrent_flag
= do_concurrent_save
;
10589 if (!gfc_resolve_expr (code
->expr2
))
10592 if (code
->op
== EXEC_ALLOCATE
10593 && !gfc_resolve_expr (code
->expr3
))
10599 case EXEC_END_BLOCK
:
10600 case EXEC_END_NESTED_BLOCK
:
10604 case EXEC_ERROR_STOP
:
10606 case EXEC_CONTINUE
:
10608 case EXEC_ASSIGN_CALL
:
10611 case EXEC_CRITICAL
:
10612 resolve_critical (code
);
10615 case EXEC_SYNC_ALL
:
10616 case EXEC_SYNC_IMAGES
:
10617 case EXEC_SYNC_MEMORY
:
10618 resolve_sync (code
);
10623 case EXEC_EVENT_POST
:
10624 case EXEC_EVENT_WAIT
:
10625 resolve_lock_unlock_event (code
);
10629 /* Keep track of which entry we are up to. */
10630 current_entry_id
= code
->ext
.entry
->id
;
10634 resolve_where (code
, NULL
);
10638 if (code
->expr1
!= NULL
)
10640 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10641 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10642 "INTEGER variable", &code
->expr1
->where
);
10643 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10644 gfc_error ("Variable %qs has not been assigned a target "
10645 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10646 &code
->expr1
->where
);
10649 resolve_branch (code
->label1
, code
);
10653 if (code
->expr1
!= NULL
10654 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10655 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10656 "INTEGER return specifier", &code
->expr1
->where
);
10659 case EXEC_INIT_ASSIGN
:
10660 case EXEC_END_PROCEDURE
:
10667 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10669 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10670 && code
->expr1
->value
.function
.isym
10671 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10672 remove_caf_get_intrinsic (code
->expr1
);
10674 /* If this is a pointer function in an lvalue variable context,
10675 the new code will have to be resolved afresh. This is also the
10676 case with an error, where the code is transformed into NOP to
10677 prevent ICEs downstream. */
10678 if (resolve_ptr_fcn_assign (&code
, ns
)
10679 || code
->op
== EXEC_NOP
)
10682 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10686 if (resolve_ordinary_assign (code
, ns
))
10688 if (code
->op
== EXEC_COMPCALL
)
10694 /* Check for dependencies in deferred character length array
10695 assignments and generate a temporary, if necessary. */
10696 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
10699 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10700 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10701 && code
->expr1
->ts
.u
.derived
10702 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10703 generate_component_assignments (&code
, ns
);
10707 case EXEC_LABEL_ASSIGN
:
10708 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10709 gfc_error ("Label %d referenced at %L is never defined",
10710 code
->label1
->value
, &code
->label1
->where
);
10712 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10713 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10714 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10715 != gfc_default_integer_kind
10716 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10717 gfc_error ("ASSIGN statement at %L requires a scalar "
10718 "default INTEGER variable", &code
->expr1
->where
);
10721 case EXEC_POINTER_ASSIGN
:
10728 /* This is both a variable definition and pointer assignment
10729 context, so check both of them. For rank remapping, a final
10730 array ref may be present on the LHS and fool gfc_expr_attr
10731 used in gfc_check_vardef_context. Remove it. */
10732 e
= remove_last_array_ref (code
->expr1
);
10733 t
= gfc_check_vardef_context (e
, true, false, false,
10734 _("pointer assignment"));
10736 t
= gfc_check_vardef_context (e
, false, false, false,
10737 _("pointer assignment"));
10742 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10746 case EXEC_ARITHMETIC_IF
:
10748 gfc_expr
*e
= code
->expr1
;
10750 gfc_resolve_expr (e
);
10751 if (e
->expr_type
== EXPR_NULL
)
10752 gfc_error ("Invalid NULL at %L", &e
->where
);
10754 if (t
&& (e
->rank
> 0
10755 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
10756 gfc_error ("Arithmetic IF statement at %L requires a scalar "
10757 "REAL or INTEGER expression", &e
->where
);
10759 resolve_branch (code
->label1
, code
);
10760 resolve_branch (code
->label2
, code
);
10761 resolve_branch (code
->label3
, code
);
10766 if (t
&& code
->expr1
!= NULL
10767 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10768 || code
->expr1
->rank
!= 0))
10769 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10770 &code
->expr1
->where
);
10775 resolve_call (code
);
10778 case EXEC_COMPCALL
:
10780 resolve_typebound_subroutine (code
);
10783 case EXEC_CALL_PPC
:
10784 resolve_ppc_call (code
);
10788 /* Select is complicated. Also, a SELECT construct could be
10789 a transformed computed GOTO. */
10790 resolve_select (code
, false);
10793 case EXEC_SELECT_TYPE
:
10794 resolve_select_type (code
, ns
);
10798 resolve_block_construct (code
);
10802 if (code
->ext
.iterator
!= NULL
)
10804 gfc_iterator
*iter
= code
->ext
.iterator
;
10805 if (gfc_resolve_iterator (iter
, true, false))
10806 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10810 case EXEC_DO_WHILE
:
10811 if (code
->expr1
== NULL
)
10812 gfc_internal_error ("gfc_resolve_code(): No expression on "
10815 && (code
->expr1
->rank
!= 0
10816 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10817 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10818 "a scalar LOGICAL expression", &code
->expr1
->where
);
10821 case EXEC_ALLOCATE
:
10823 resolve_allocate_deallocate (code
, "ALLOCATE");
10827 case EXEC_DEALLOCATE
:
10829 resolve_allocate_deallocate (code
, "DEALLOCATE");
10834 if (!gfc_resolve_open (code
->ext
.open
))
10837 resolve_branch (code
->ext
.open
->err
, code
);
10841 if (!gfc_resolve_close (code
->ext
.close
))
10844 resolve_branch (code
->ext
.close
->err
, code
);
10847 case EXEC_BACKSPACE
:
10851 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10854 resolve_branch (code
->ext
.filepos
->err
, code
);
10858 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10861 resolve_branch (code
->ext
.inquire
->err
, code
);
10864 case EXEC_IOLENGTH
:
10865 gcc_assert (code
->ext
.inquire
!= NULL
);
10866 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10869 resolve_branch (code
->ext
.inquire
->err
, code
);
10873 if (!gfc_resolve_wait (code
->ext
.wait
))
10876 resolve_branch (code
->ext
.wait
->err
, code
);
10877 resolve_branch (code
->ext
.wait
->end
, code
);
10878 resolve_branch (code
->ext
.wait
->eor
, code
);
10883 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10886 resolve_branch (code
->ext
.dt
->err
, code
);
10887 resolve_branch (code
->ext
.dt
->end
, code
);
10888 resolve_branch (code
->ext
.dt
->eor
, code
);
10891 case EXEC_TRANSFER
:
10892 resolve_transfer (code
);
10895 case EXEC_DO_CONCURRENT
:
10897 resolve_forall_iterators (code
->ext
.forall_iterator
);
10899 if (code
->expr1
!= NULL
10900 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10901 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10902 "expression", &code
->expr1
->where
);
10905 case EXEC_OACC_PARALLEL_LOOP
:
10906 case EXEC_OACC_PARALLEL
:
10907 case EXEC_OACC_KERNELS_LOOP
:
10908 case EXEC_OACC_KERNELS
:
10909 case EXEC_OACC_DATA
:
10910 case EXEC_OACC_HOST_DATA
:
10911 case EXEC_OACC_LOOP
:
10912 case EXEC_OACC_UPDATE
:
10913 case EXEC_OACC_WAIT
:
10914 case EXEC_OACC_CACHE
:
10915 case EXEC_OACC_ENTER_DATA
:
10916 case EXEC_OACC_EXIT_DATA
:
10917 case EXEC_OACC_ATOMIC
:
10918 case EXEC_OACC_DECLARE
:
10919 gfc_resolve_oacc_directive (code
, ns
);
10922 case EXEC_OMP_ATOMIC
:
10923 case EXEC_OMP_BARRIER
:
10924 case EXEC_OMP_CANCEL
:
10925 case EXEC_OMP_CANCELLATION_POINT
:
10926 case EXEC_OMP_CRITICAL
:
10927 case EXEC_OMP_FLUSH
:
10928 case EXEC_OMP_DISTRIBUTE
:
10929 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10930 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10931 case EXEC_OMP_DISTRIBUTE_SIMD
:
10933 case EXEC_OMP_DO_SIMD
:
10934 case EXEC_OMP_MASTER
:
10935 case EXEC_OMP_ORDERED
:
10936 case EXEC_OMP_SECTIONS
:
10937 case EXEC_OMP_SIMD
:
10938 case EXEC_OMP_SINGLE
:
10939 case EXEC_OMP_TARGET
:
10940 case EXEC_OMP_TARGET_DATA
:
10941 case EXEC_OMP_TARGET_TEAMS
:
10942 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10943 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10944 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10945 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10946 case EXEC_OMP_TARGET_UPDATE
:
10947 case EXEC_OMP_TASK
:
10948 case EXEC_OMP_TASKGROUP
:
10949 case EXEC_OMP_TASKWAIT
:
10950 case EXEC_OMP_TASKYIELD
:
10951 case EXEC_OMP_TEAMS
:
10952 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10953 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10954 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10955 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10956 case EXEC_OMP_WORKSHARE
:
10957 gfc_resolve_omp_directive (code
, ns
);
10960 case EXEC_OMP_PARALLEL
:
10961 case EXEC_OMP_PARALLEL_DO
:
10962 case EXEC_OMP_PARALLEL_DO_SIMD
:
10963 case EXEC_OMP_PARALLEL_SECTIONS
:
10964 case EXEC_OMP_PARALLEL_WORKSHARE
:
10965 omp_workshare_save
= omp_workshare_flag
;
10966 omp_workshare_flag
= 0;
10967 gfc_resolve_omp_directive (code
, ns
);
10968 omp_workshare_flag
= omp_workshare_save
;
10972 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10976 cs_base
= frame
.prev
;
10980 /* Resolve initial values and make sure they are compatible with
10984 resolve_values (gfc_symbol
*sym
)
10988 if (sym
->value
== NULL
)
10991 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10992 t
= resolve_structure_cons (sym
->value
, 1);
10994 t
= gfc_resolve_expr (sym
->value
);
10999 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11003 /* Verify any BIND(C) derived types in the namespace so we can report errors
11004 for them once, rather than for each variable declared of that type. */
11007 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11009 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11010 && derived_sym
->attr
.is_bind_c
== 1)
11011 verify_bind_c_derived_type (derived_sym
);
11017 /* Check the interfaces of DTIO procedures associated with derived
11018 type 'sym'. These procedures can either have typebound bindings or
11019 can appear in DTIO generic interfaces. */
11022 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11024 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11027 gfc_check_dtio_interfaces (sym
);
11032 /* Verify that any binding labels used in a given namespace do not collide
11033 with the names or binding labels of any global symbols. Multiple INTERFACE
11034 for the same procedure are permitted. */
11037 gfc_verify_binding_labels (gfc_symbol
*sym
)
11040 const char *module
;
11042 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11043 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11046 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11049 module
= sym
->module
;
11050 else if (sym
->ns
&& sym
->ns
->proc_name
11051 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11052 module
= sym
->ns
->proc_name
->name
;
11053 else if (sym
->ns
&& sym
->ns
->parent
11054 && sym
->ns
&& sym
->ns
->parent
->proc_name
11055 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11056 module
= sym
->ns
->parent
->proc_name
->name
;
11062 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11065 gsym
= gfc_get_gsymbol (sym
->binding_label
);
11066 gsym
->where
= sym
->declared_at
;
11067 gsym
->sym_name
= sym
->name
;
11068 gsym
->binding_label
= sym
->binding_label
;
11069 gsym
->ns
= sym
->ns
;
11070 gsym
->mod_name
= module
;
11071 if (sym
->attr
.function
)
11072 gsym
->type
= GSYM_FUNCTION
;
11073 else if (sym
->attr
.subroutine
)
11074 gsym
->type
= GSYM_SUBROUTINE
;
11075 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11076 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11080 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11082 gfc_error ("Variable %s with binding label %s at %L uses the same global "
11083 "identifier as entity at %L", sym
->name
,
11084 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11085 /* Clear the binding label to prevent checking multiple times. */
11086 sym
->binding_label
= NULL
;
11089 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11090 && (strcmp (module
, gsym
->mod_name
) != 0
11091 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11093 /* This can only happen if the variable is defined in a module - if it
11094 isn't the same module, reject it. */
11095 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
11096 "the same global identifier as entity at %L from module %s",
11097 sym
->name
, module
, sym
->binding_label
,
11098 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11099 sym
->binding_label
= NULL
;
11101 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11102 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11103 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11104 && sym
!= gsym
->ns
->proc_name
11105 && (module
!= gsym
->mod_name
11106 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11107 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11109 /* Print an error if the procedure is defined multiple times; we have to
11110 exclude references to the same procedure via module association or
11111 multiple checks for the same procedure. */
11112 gfc_error ("Procedure %s with binding label %s at %L uses the same "
11113 "global identifier as entity at %L", sym
->name
,
11114 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11115 sym
->binding_label
= NULL
;
11120 /* Resolve an index expression. */
11123 resolve_index_expr (gfc_expr
*e
)
11125 if (!gfc_resolve_expr (e
))
11128 if (!gfc_simplify_expr (e
, 0))
11131 if (!gfc_specification_expr (e
))
11138 /* Resolve a charlen structure. */
11141 resolve_charlen (gfc_charlen
*cl
)
11144 bool saved_specification_expr
;
11150 saved_specification_expr
= specification_expr
;
11151 specification_expr
= true;
11153 if (cl
->length_from_typespec
)
11155 if (!gfc_resolve_expr (cl
->length
))
11157 specification_expr
= saved_specification_expr
;
11161 if (!gfc_simplify_expr (cl
->length
, 0))
11163 specification_expr
= saved_specification_expr
;
11170 if (!resolve_index_expr (cl
->length
))
11172 specification_expr
= saved_specification_expr
;
11177 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11178 a negative value, the length of character entities declared is zero. */
11179 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
11180 gfc_replace_expr (cl
->length
,
11181 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
11183 /* Check that the character length is not too large. */
11184 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11185 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11186 && cl
->length
->ts
.type
== BT_INTEGER
11187 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11189 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11190 specification_expr
= saved_specification_expr
;
11194 specification_expr
= saved_specification_expr
;
11199 /* Test for non-constant shape arrays. */
11202 is_non_constant_shape_array (gfc_symbol
*sym
)
11208 not_constant
= false;
11209 if (sym
->as
!= NULL
)
11211 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11212 has not been simplified; parameter array references. Do the
11213 simplification now. */
11214 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11216 e
= sym
->as
->lower
[i
];
11217 if (e
&& (!resolve_index_expr(e
)
11218 || !gfc_is_constant_expr (e
)))
11219 not_constant
= true;
11220 e
= sym
->as
->upper
[i
];
11221 if (e
&& (!resolve_index_expr(e
)
11222 || !gfc_is_constant_expr (e
)))
11223 not_constant
= true;
11226 return not_constant
;
11229 /* Given a symbol and an initialization expression, add code to initialize
11230 the symbol to the function entry. */
11232 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11236 gfc_namespace
*ns
= sym
->ns
;
11238 /* Search for the function namespace if this is a contained
11239 function without an explicit result. */
11240 if (sym
->attr
.function
&& sym
== sym
->result
11241 && sym
->name
!= sym
->ns
->proc_name
->name
)
11243 ns
= ns
->contained
;
11244 for (;ns
; ns
= ns
->sibling
)
11245 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11251 gfc_free_expr (init
);
11255 /* Build an l-value expression for the result. */
11256 lval
= gfc_lval_expr_from_sym (sym
);
11258 /* Add the code at scope entry. */
11259 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11260 init_st
->next
= ns
->code
;
11261 ns
->code
= init_st
;
11263 /* Assign the default initializer to the l-value. */
11264 init_st
->loc
= sym
->declared_at
;
11265 init_st
->expr1
= lval
;
11266 init_st
->expr2
= init
;
11270 /* Whether or not we can generate a default initializer for a symbol. */
11273 can_generate_init (gfc_symbol
*sym
)
11275 symbol_attribute
*a
;
11280 /* These symbols should never have a default initialization. */
11285 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
11286 && (CLASS_DATA (sym
)->attr
.class_pointer
11287 || CLASS_DATA (sym
)->attr
.proc_pointer
))
11288 || a
->in_equivalence
11295 || (!a
->referenced
&& !a
->result
)
11296 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
11297 || (a
->function
&& sym
!= sym
->result
)
11302 /* Assign the default initializer to a derived type variable or result. */
11305 apply_default_init (gfc_symbol
*sym
)
11307 gfc_expr
*init
= NULL
;
11309 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11312 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11313 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11315 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11318 build_init_assign (sym
, init
);
11319 sym
->attr
.referenced
= 1;
11323 /* Build an initializer for a local. Returns null if the symbol should not have
11324 a default initialization. */
11327 build_default_init_expr (gfc_symbol
*sym
)
11329 /* These symbols should never have a default initialization. */
11330 if (sym
->attr
.allocatable
11331 || sym
->attr
.external
11333 || sym
->attr
.pointer
11334 || sym
->attr
.in_equivalence
11335 || sym
->attr
.in_common
11338 || sym
->attr
.cray_pointee
11339 || sym
->attr
.cray_pointer
11343 /* Get the appropriate init expression. */
11344 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
11347 /* Add an initialization expression to a local variable. */
11349 apply_default_init_local (gfc_symbol
*sym
)
11351 gfc_expr
*init
= NULL
;
11353 /* The symbol should be a variable or a function return value. */
11354 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11355 || (sym
->attr
.function
&& sym
->result
!= sym
))
11358 /* Try to build the initializer expression. If we can't initialize
11359 this symbol, then init will be NULL. */
11360 init
= build_default_init_expr (sym
);
11364 /* For saved variables, we don't want to add an initializer at function
11365 entry, so we just add a static initializer. Note that automatic variables
11366 are stack allocated even with -fno-automatic; we have also to exclude
11367 result variable, which are also nonstatic. */
11368 if (!sym
->attr
.automatic
11369 && (sym
->attr
.save
|| sym
->ns
->save_all
11370 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11371 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11372 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
11374 /* Don't clobber an existing initializer! */
11375 gcc_assert (sym
->value
== NULL
);
11380 build_init_assign (sym
, init
);
11384 /* Resolution of common features of flavors variable and procedure. */
11387 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11389 gfc_array_spec
*as
;
11391 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11392 as
= CLASS_DATA (sym
)->as
;
11396 /* Constraints on deferred shape variable. */
11397 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11399 bool pointer
, allocatable
, dimension
;
11401 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11403 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11404 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11405 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11409 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11410 allocatable
= sym
->attr
.allocatable
;
11411 dimension
= sym
->attr
.dimension
;
11416 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11418 gfc_error ("Allocatable array %qs at %L must have a deferred "
11419 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11422 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11423 "%qs at %L may not be ALLOCATABLE",
11424 sym
->name
, &sym
->declared_at
))
11428 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11430 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11431 "assumed rank", sym
->name
, &sym
->declared_at
);
11437 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11438 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11440 gfc_error ("Array %qs at %L cannot have a deferred shape",
11441 sym
->name
, &sym
->declared_at
);
11446 /* Constraints on polymorphic variables. */
11447 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11450 if (sym
->attr
.class_ok
11451 && !sym
->attr
.select_type_temporary
11452 && !UNLIMITED_POLY (sym
)
11453 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11455 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11456 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11457 &sym
->declared_at
);
11462 /* Assume that use associated symbols were checked in the module ns.
11463 Class-variables that are associate-names are also something special
11464 and excepted from the test. */
11465 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11467 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11468 "or pointer", sym
->name
, &sym
->declared_at
);
11477 /* Additional checks for symbols with flavor variable and derived
11478 type. To be called from resolve_fl_variable. */
11481 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11483 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11485 /* Check to see if a derived type is blocked from being host
11486 associated by the presence of another class I symbol in the same
11487 namespace. 14.6.1.3 of the standard and the discussion on
11488 comp.lang.fortran. */
11489 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11490 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11493 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11494 if (s
&& s
->attr
.generic
)
11495 s
= gfc_find_dt_in_generic (s
);
11496 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
11498 gfc_error ("The type %qs cannot be host associated at %L "
11499 "because it is blocked by an incompatible object "
11500 "of the same name declared at %L",
11501 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11507 /* 4th constraint in section 11.3: "If an object of a type for which
11508 component-initialization is specified (R429) appears in the
11509 specification-part of a module and does not have the ALLOCATABLE
11510 or POINTER attribute, the object shall have the SAVE attribute."
11512 The check for initializers is performed with
11513 gfc_has_default_initializer because gfc_default_initializer generates
11514 a hidden default for allocatable components. */
11515 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11516 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11517 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
11518 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11519 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11520 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11521 "%qs at %L, needed due to the default "
11522 "initialization", sym
->name
, &sym
->declared_at
))
11525 /* Assign default initializer. */
11526 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11527 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11528 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
11534 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
11535 except in the declaration of an entity or component that has the POINTER
11536 or ALLOCATABLE attribute. */
11539 deferred_requirements (gfc_symbol
*sym
)
11541 if (sym
->ts
.deferred
11542 && !(sym
->attr
.pointer
11543 || sym
->attr
.allocatable
11544 || sym
->attr
.omp_udr_artificial_var
))
11546 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11547 "requires either the POINTER or ALLOCATABLE attribute",
11548 sym
->name
, &sym
->declared_at
);
11555 /* Resolve symbols with flavor variable. */
11558 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11560 int no_init_flag
, automatic_flag
;
11562 const char *auto_save_msg
;
11563 bool saved_specification_expr
;
11565 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11568 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11571 /* Set this flag to check that variables are parameters of all entries.
11572 This check is effected by the call to gfc_resolve_expr through
11573 is_non_constant_shape_array. */
11574 saved_specification_expr
= specification_expr
;
11575 specification_expr
= true;
11577 if (sym
->ns
->proc_name
11578 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11579 || sym
->ns
->proc_name
->attr
.is_main_program
)
11580 && !sym
->attr
.use_assoc
11581 && !sym
->attr
.allocatable
11582 && !sym
->attr
.pointer
11583 && is_non_constant_shape_array (sym
))
11585 /* The shape of a main program or module array needs to be
11587 gfc_error ("The module or main program array %qs at %L must "
11588 "have constant shape", sym
->name
, &sym
->declared_at
);
11589 specification_expr
= saved_specification_expr
;
11593 /* Constraints on deferred type parameter. */
11594 if (!deferred_requirements (sym
))
11597 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
11599 /* Make sure that character string variables with assumed length are
11600 dummy arguments. */
11601 e
= sym
->ts
.u
.cl
->length
;
11602 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11603 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11604 && !sym
->attr
.omp_udr_artificial_var
)
11606 gfc_error ("Entity with assumed character length at %L must be a "
11607 "dummy argument or a PARAMETER", &sym
->declared_at
);
11608 specification_expr
= saved_specification_expr
;
11612 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11614 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11615 specification_expr
= saved_specification_expr
;
11619 if (!gfc_is_constant_expr (e
)
11620 && !(e
->expr_type
== EXPR_VARIABLE
11621 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11623 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11624 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11625 || sym
->ns
->proc_name
->attr
.is_main_program
))
11627 gfc_error ("%qs at %L must have constant character length "
11628 "in this context", sym
->name
, &sym
->declared_at
);
11629 specification_expr
= saved_specification_expr
;
11632 if (sym
->attr
.in_common
)
11634 gfc_error ("COMMON variable %qs at %L must have constant "
11635 "character length", sym
->name
, &sym
->declared_at
);
11636 specification_expr
= saved_specification_expr
;
11642 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11643 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11645 /* Determine if the symbol may not have an initializer. */
11646 no_init_flag
= automatic_flag
= 0;
11647 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11648 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11650 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11651 && is_non_constant_shape_array (sym
))
11653 no_init_flag
= automatic_flag
= 1;
11655 /* Also, they must not have the SAVE attribute.
11656 SAVE_IMPLICIT is checked below. */
11657 if (sym
->as
&& sym
->attr
.codimension
)
11659 int corank
= sym
->as
->corank
;
11660 sym
->as
->corank
= 0;
11661 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11662 sym
->as
->corank
= corank
;
11664 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11666 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11667 specification_expr
= saved_specification_expr
;
11672 /* Ensure that any initializer is simplified. */
11674 gfc_simplify_expr (sym
->value
, 1);
11676 /* Reject illegal initializers. */
11677 if (!sym
->mark
&& sym
->value
)
11679 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11680 && CLASS_DATA (sym
)->attr
.allocatable
))
11681 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11682 sym
->name
, &sym
->declared_at
);
11683 else if (sym
->attr
.external
)
11684 gfc_error ("External %qs at %L cannot have an initializer",
11685 sym
->name
, &sym
->declared_at
);
11686 else if (sym
->attr
.dummy
11687 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11688 gfc_error ("Dummy %qs at %L cannot have an initializer",
11689 sym
->name
, &sym
->declared_at
);
11690 else if (sym
->attr
.intrinsic
)
11691 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11692 sym
->name
, &sym
->declared_at
);
11693 else if (sym
->attr
.result
)
11694 gfc_error ("Function result %qs at %L cannot have an initializer",
11695 sym
->name
, &sym
->declared_at
);
11696 else if (automatic_flag
)
11697 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11698 sym
->name
, &sym
->declared_at
);
11700 goto no_init_error
;
11701 specification_expr
= saved_specification_expr
;
11706 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11708 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11709 specification_expr
= saved_specification_expr
;
11713 specification_expr
= saved_specification_expr
;
11718 /* Compare the dummy characteristics of a module procedure interface
11719 declaration with the corresponding declaration in a submodule. */
11720 static gfc_formal_arglist
*new_formal
;
11721 static char errmsg
[200];
11724 compare_fsyms (gfc_symbol
*sym
)
11728 if (sym
== NULL
|| new_formal
== NULL
)
11731 fsym
= new_formal
->sym
;
11736 if (strcmp (sym
->name
, fsym
->name
) == 0)
11738 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
11739 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
11744 /* Resolve a procedure. */
11747 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11749 gfc_formal_arglist
*arg
;
11751 if (sym
->attr
.function
11752 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11755 if (sym
->ts
.type
== BT_CHARACTER
)
11757 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11759 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11760 && !resolve_charlen (cl
))
11763 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11764 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11766 gfc_error ("Character-valued statement function %qs at %L must "
11767 "have constant length", sym
->name
, &sym
->declared_at
);
11772 /* Ensure that derived type for are not of a private type. Internal
11773 module procedures are excluded by 2.2.3.3 - i.e., they are not
11774 externally accessible and can access all the objects accessible in
11776 if (!(sym
->ns
->parent
11777 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11778 && gfc_check_symbol_access (sym
))
11780 gfc_interface
*iface
;
11782 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11785 && arg
->sym
->ts
.type
== BT_DERIVED
11786 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11787 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11788 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11789 "and cannot be a dummy argument"
11790 " of %qs, which is PUBLIC at %L",
11791 arg
->sym
->name
, sym
->name
,
11792 &sym
->declared_at
))
11794 /* Stop this message from recurring. */
11795 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11800 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11801 PRIVATE to the containing module. */
11802 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11804 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11807 && arg
->sym
->ts
.type
== BT_DERIVED
11808 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11809 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11810 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11811 "PUBLIC interface %qs at %L "
11812 "takes dummy arguments of %qs which "
11813 "is PRIVATE", iface
->sym
->name
,
11814 sym
->name
, &iface
->sym
->declared_at
,
11815 gfc_typename(&arg
->sym
->ts
)))
11817 /* Stop this message from recurring. */
11818 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11825 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11826 && !sym
->attr
.proc_pointer
)
11828 gfc_error ("Function %qs at %L cannot have an initializer",
11829 sym
->name
, &sym
->declared_at
);
11833 /* An external symbol may not have an initializer because it is taken to be
11834 a procedure. Exception: Procedure Pointers. */
11835 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11837 gfc_error ("External object %qs at %L may not have an initializer",
11838 sym
->name
, &sym
->declared_at
);
11842 /* An elemental function is required to return a scalar 12.7.1 */
11843 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11845 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11846 "result", sym
->name
, &sym
->declared_at
);
11847 /* Reset so that the error only occurs once. */
11848 sym
->attr
.elemental
= 0;
11852 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11853 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11855 gfc_error ("Statement function %qs at %L may not have pointer or "
11856 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11860 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11861 char-len-param shall not be array-valued, pointer-valued, recursive
11862 or pure. ....snip... A character value of * may only be used in the
11863 following ways: (i) Dummy arg of procedure - dummy associates with
11864 actual length; (ii) To declare a named constant; or (iii) External
11865 function - but length must be declared in calling scoping unit. */
11866 if (sym
->attr
.function
11867 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11868 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11870 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11871 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11873 if (sym
->as
&& sym
->as
->rank
)
11874 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11875 "array-valued", sym
->name
, &sym
->declared_at
);
11877 if (sym
->attr
.pointer
)
11878 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11879 "pointer-valued", sym
->name
, &sym
->declared_at
);
11881 if (sym
->attr
.pure
)
11882 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11883 "pure", sym
->name
, &sym
->declared_at
);
11885 if (sym
->attr
.recursive
)
11886 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11887 "recursive", sym
->name
, &sym
->declared_at
);
11892 /* Appendix B.2 of the standard. Contained functions give an
11893 error anyway. Deferred character length is an F2003 feature.
11894 Don't warn on intrinsic conversion functions, which start
11895 with two underscores. */
11896 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11897 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11898 gfc_notify_std (GFC_STD_F95_OBS
,
11899 "CHARACTER(*) function %qs at %L",
11900 sym
->name
, &sym
->declared_at
);
11903 /* F2008, C1218. */
11904 if (sym
->attr
.elemental
)
11906 if (sym
->attr
.proc_pointer
)
11908 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11909 sym
->name
, &sym
->declared_at
);
11912 if (sym
->attr
.dummy
)
11914 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11915 sym
->name
, &sym
->declared_at
);
11920 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11922 gfc_formal_arglist
*curr_arg
;
11923 int has_non_interop_arg
= 0;
11925 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11926 sym
->common_block
))
11928 /* Clear these to prevent looking at them again if there was an
11930 sym
->attr
.is_bind_c
= 0;
11931 sym
->attr
.is_c_interop
= 0;
11932 sym
->ts
.is_c_interop
= 0;
11936 /* So far, no errors have been found. */
11937 sym
->attr
.is_c_interop
= 1;
11938 sym
->ts
.is_c_interop
= 1;
11941 curr_arg
= gfc_sym_get_dummy_args (sym
);
11942 while (curr_arg
!= NULL
)
11944 /* Skip implicitly typed dummy args here. */
11945 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11946 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11947 /* If something is found to fail, record the fact so we
11948 can mark the symbol for the procedure as not being
11949 BIND(C) to try and prevent multiple errors being
11951 has_non_interop_arg
= 1;
11953 curr_arg
= curr_arg
->next
;
11956 /* See if any of the arguments were not interoperable and if so, clear
11957 the procedure symbol to prevent duplicate error messages. */
11958 if (has_non_interop_arg
!= 0)
11960 sym
->attr
.is_c_interop
= 0;
11961 sym
->ts
.is_c_interop
= 0;
11962 sym
->attr
.is_bind_c
= 0;
11966 if (!sym
->attr
.proc_pointer
)
11968 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11970 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11971 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11974 if (sym
->attr
.intent
)
11976 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11977 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11980 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11982 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11983 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11986 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
11987 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11988 || sym
->attr
.contained
))
11990 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11991 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11994 if (strcmp ("ppr@", sym
->name
) == 0)
11996 gfc_error ("Procedure pointer result %qs at %L "
11997 "is missing the pointer attribute",
11998 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12003 /* Assume that a procedure whose body is not known has references
12004 to external arrays. */
12005 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12006 sym
->attr
.array_outer_dependency
= 1;
12008 /* Compare the characteristics of a module procedure with the
12009 interface declaration. Ideally this would be done with
12010 gfc_compare_interfaces but, at present, the formal interface
12011 cannot be copied to the ts.interface. */
12012 if (sym
->attr
.module_procedure
12013 && sym
->attr
.if_source
== IFSRC_DECL
)
12016 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12018 char *submodule_name
;
12019 strcpy (name
, sym
->ns
->proc_name
->name
);
12020 module_name
= strtok (name
, ".");
12021 submodule_name
= strtok (NULL
, ".");
12023 /* Stop the dummy characteristics test from using the interface
12024 symbol instead of 'sym'. */
12025 iface
= sym
->ts
.interface
;
12026 sym
->ts
.interface
= NULL
;
12028 /* Make sure that the result uses the correct charlen for deferred
12030 if (iface
&& sym
->result
12031 && iface
->ts
.type
== BT_CHARACTER
12032 && iface
->ts
.deferred
)
12033 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12038 /* Check the procedure characteristics. */
12039 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12041 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12042 "PROCEDURE at %L and its interface in %s",
12043 &sym
->declared_at
, module_name
);
12047 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12049 gfc_error ("Mismatch in PURE attribute between MODULE "
12050 "PROCEDURE at %L and its interface in %s",
12051 &sym
->declared_at
, module_name
);
12055 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12057 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12058 "PROCEDURE at %L and its interface in %s",
12059 &sym
->declared_at
, module_name
);
12063 /* Check the result characteristics. */
12064 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12066 gfc_error ("%s between the MODULE PROCEDURE declaration "
12067 "in module %s and the declaration at %L in "
12068 "SUBMODULE %s", errmsg
, module_name
,
12069 &sym
->declared_at
, submodule_name
);
12074 /* Check the charcateristics of the formal arguments. */
12075 if (sym
->formal
&& sym
->formal_ns
)
12077 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12080 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12084 sym
->ts
.interface
= iface
;
12090 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12091 been defined and we now know their defined arguments, check that they fulfill
12092 the requirements of the standard for procedures used as finalizers. */
12095 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12097 gfc_finalizer
* list
;
12098 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12099 bool result
= true;
12100 bool seen_scalar
= false;
12103 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12106 gfc_resolve_finalizers (parent
, finalizable
);
12108 /* Return early when not finalizable. Additionally, ensure that derived-type
12109 components have a their finalizables resolved. */
12110 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
12112 bool has_final
= false;
12113 for (c
= derived
->components
; c
; c
= c
->next
)
12114 if (c
->ts
.type
== BT_DERIVED
12115 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12117 bool has_final2
= false;
12118 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
12119 return false; /* Error. */
12120 has_final
= has_final
|| has_final2
;
12125 *finalizable
= false;
12130 /* Walk over the list of finalizer-procedures, check them, and if any one
12131 does not fit in with the standard's definition, print an error and remove
12132 it from the list. */
12133 prev_link
= &derived
->f2k_derived
->finalizers
;
12134 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12136 gfc_formal_arglist
*dummy_args
;
12141 /* Skip this finalizer if we already resolved it. */
12142 if (list
->proc_tree
)
12144 prev_link
= &(list
->next
);
12148 /* Check this exists and is a SUBROUTINE. */
12149 if (!list
->proc_sym
->attr
.subroutine
)
12151 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12152 list
->proc_sym
->name
, &list
->where
);
12156 /* We should have exactly one argument. */
12157 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12158 if (!dummy_args
|| dummy_args
->next
)
12160 gfc_error ("FINAL procedure at %L must have exactly one argument",
12164 arg
= dummy_args
->sym
;
12166 /* This argument must be of our type. */
12167 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12169 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12170 &arg
->declared_at
, derived
->name
);
12174 /* It must neither be a pointer nor allocatable nor optional. */
12175 if (arg
->attr
.pointer
)
12177 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12178 &arg
->declared_at
);
12181 if (arg
->attr
.allocatable
)
12183 gfc_error ("Argument of FINAL procedure at %L must not be"
12184 " ALLOCATABLE", &arg
->declared_at
);
12187 if (arg
->attr
.optional
)
12189 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12190 &arg
->declared_at
);
12194 /* It must not be INTENT(OUT). */
12195 if (arg
->attr
.intent
== INTENT_OUT
)
12197 gfc_error ("Argument of FINAL procedure at %L must not be"
12198 " INTENT(OUT)", &arg
->declared_at
);
12202 /* Warn if the procedure is non-scalar and not assumed shape. */
12203 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12204 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12205 gfc_warning (OPT_Wsurprising
,
12206 "Non-scalar FINAL procedure at %L should have assumed"
12207 " shape argument", &arg
->declared_at
);
12209 /* Check that it does not match in kind and rank with a FINAL procedure
12210 defined earlier. To really loop over the *earlier* declarations,
12211 we need to walk the tail of the list as new ones were pushed at the
12213 /* TODO: Handle kind parameters once they are implemented. */
12214 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12215 for (i
= list
->next
; i
; i
= i
->next
)
12217 gfc_formal_arglist
*dummy_args
;
12219 /* Argument list might be empty; that is an error signalled earlier,
12220 but we nevertheless continued resolving. */
12221 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12224 gfc_symbol
* i_arg
= dummy_args
->sym
;
12225 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12226 if (i_rank
== my_rank
)
12228 gfc_error ("FINAL procedure %qs declared at %L has the same"
12229 " rank (%d) as %qs",
12230 list
->proc_sym
->name
, &list
->where
, my_rank
,
12231 i
->proc_sym
->name
);
12237 /* Is this the/a scalar finalizer procedure? */
12238 if (!arg
->as
|| arg
->as
->rank
== 0)
12239 seen_scalar
= true;
12241 /* Find the symtree for this procedure. */
12242 gcc_assert (!list
->proc_tree
);
12243 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12245 prev_link
= &list
->next
;
12248 /* Remove wrong nodes immediately from the list so we don't risk any
12249 troubles in the future when they might fail later expectations. */
12252 *prev_link
= list
->next
;
12253 gfc_free_finalizer (i
);
12257 if (result
== false)
12260 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12261 were nodes in the list, must have been for arrays. It is surely a good
12262 idea to have a scalar version there if there's something to finalize. */
12263 if (warn_surprising
&& result
&& !seen_scalar
)
12264 gfc_warning (OPT_Wsurprising
,
12265 "Only array FINAL procedures declared for derived type %qs"
12266 " defined at %L, suggest also scalar one",
12267 derived
->name
, &derived
->declared_at
);
12269 vtab
= gfc_find_derived_vtab (derived
);
12270 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12271 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12274 *finalizable
= true;
12280 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12283 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12284 const char* generic_name
, locus where
)
12286 gfc_symbol
*sym1
, *sym2
;
12287 const char *pass1
, *pass2
;
12288 gfc_formal_arglist
*dummy_args
;
12290 gcc_assert (t1
->specific
&& t2
->specific
);
12291 gcc_assert (!t1
->specific
->is_generic
);
12292 gcc_assert (!t2
->specific
->is_generic
);
12293 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12295 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12296 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12301 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12302 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12303 || sym1
->attr
.function
!= sym2
->attr
.function
)
12305 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12306 " GENERIC %qs at %L",
12307 sym1
->name
, sym2
->name
, generic_name
, &where
);
12311 /* Determine PASS arguments. */
12312 if (t1
->specific
->nopass
)
12314 else if (t1
->specific
->pass_arg
)
12315 pass1
= t1
->specific
->pass_arg
;
12318 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12320 pass1
= dummy_args
->sym
->name
;
12324 if (t2
->specific
->nopass
)
12326 else if (t2
->specific
->pass_arg
)
12327 pass2
= t2
->specific
->pass_arg
;
12330 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12332 pass2
= dummy_args
->sym
->name
;
12337 /* Compare the interfaces. */
12338 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12339 NULL
, 0, pass1
, pass2
))
12341 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12342 sym1
->name
, sym2
->name
, generic_name
, &where
);
12350 /* Worker function for resolving a generic procedure binding; this is used to
12351 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12353 The difference between those cases is finding possible inherited bindings
12354 that are overridden, as one has to look for them in tb_sym_root,
12355 tb_uop_root or tb_op, respectively. Thus the caller must already find
12356 the super-type and set p->overridden correctly. */
12359 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12360 gfc_typebound_proc
* p
, const char* name
)
12362 gfc_tbp_generic
* target
;
12363 gfc_symtree
* first_target
;
12364 gfc_symtree
* inherited
;
12366 gcc_assert (p
&& p
->is_generic
);
12368 /* Try to find the specific bindings for the symtrees in our target-list. */
12369 gcc_assert (p
->u
.generic
);
12370 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12371 if (!target
->specific
)
12373 gfc_typebound_proc
* overridden_tbp
;
12374 gfc_tbp_generic
* g
;
12375 const char* target_name
;
12377 target_name
= target
->specific_st
->name
;
12379 /* Defined for this type directly. */
12380 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12382 target
->specific
= target
->specific_st
->n
.tb
;
12383 goto specific_found
;
12386 /* Look for an inherited specific binding. */
12389 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12394 gcc_assert (inherited
->n
.tb
);
12395 target
->specific
= inherited
->n
.tb
;
12396 goto specific_found
;
12400 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12401 " at %L", target_name
, name
, &p
->where
);
12404 /* Once we've found the specific binding, check it is not ambiguous with
12405 other specifics already found or inherited for the same GENERIC. */
12407 gcc_assert (target
->specific
);
12409 /* This must really be a specific binding! */
12410 if (target
->specific
->is_generic
)
12412 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12413 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12417 /* Check those already resolved on this type directly. */
12418 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12419 if (g
!= target
&& g
->specific
12420 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12423 /* Check for ambiguity with inherited specific targets. */
12424 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12425 overridden_tbp
= overridden_tbp
->overridden
)
12426 if (overridden_tbp
->is_generic
)
12428 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12430 gcc_assert (g
->specific
);
12431 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12437 /* If we attempt to "overwrite" a specific binding, this is an error. */
12438 if (p
->overridden
&& !p
->overridden
->is_generic
)
12440 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12441 " the same name", name
, &p
->where
);
12445 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12446 all must have the same attributes here. */
12447 first_target
= p
->u
.generic
->specific
->u
.specific
;
12448 gcc_assert (first_target
);
12449 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12450 p
->function
= first_target
->n
.sym
->attr
.function
;
12456 /* Resolve a GENERIC procedure binding for a derived type. */
12459 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12461 gfc_symbol
* super_type
;
12463 /* Find the overridden binding if any. */
12464 st
->n
.tb
->overridden
= NULL
;
12465 super_type
= gfc_get_derived_super_type (derived
);
12468 gfc_symtree
* overridden
;
12469 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12472 if (overridden
&& overridden
->n
.tb
)
12473 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12476 /* Resolve using worker function. */
12477 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12481 /* Retrieve the target-procedure of an operator binding and do some checks in
12482 common for intrinsic and user-defined type-bound operators. */
12485 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12487 gfc_symbol
* target_proc
;
12489 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12490 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12491 gcc_assert (target_proc
);
12493 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12494 if (target
->specific
->nopass
)
12496 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12500 return target_proc
;
12504 /* Resolve a type-bound intrinsic operator. */
12507 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12508 gfc_typebound_proc
* p
)
12510 gfc_symbol
* super_type
;
12511 gfc_tbp_generic
* target
;
12513 /* If there's already an error here, do nothing (but don't fail again). */
12517 /* Operators should always be GENERIC bindings. */
12518 gcc_assert (p
->is_generic
);
12520 /* Look for an overridden binding. */
12521 super_type
= gfc_get_derived_super_type (derived
);
12522 if (super_type
&& super_type
->f2k_derived
)
12523 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12526 p
->overridden
= NULL
;
12528 /* Resolve general GENERIC properties using worker function. */
12529 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
12532 /* Check the targets to be procedures of correct interface. */
12533 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12535 gfc_symbol
* target_proc
;
12537 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12541 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12544 /* Add target to non-typebound operator list. */
12545 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12546 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12548 gfc_interface
*head
, *intr
;
12549 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
12551 head
= derived
->ns
->op
[op
];
12552 intr
= gfc_get_interface ();
12553 intr
->sym
= target_proc
;
12554 intr
->where
= p
->where
;
12556 derived
->ns
->op
[op
] = intr
;
12568 /* Resolve a type-bound user operator (tree-walker callback). */
12570 static gfc_symbol
* resolve_bindings_derived
;
12571 static bool resolve_bindings_result
;
12573 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12576 resolve_typebound_user_op (gfc_symtree
* stree
)
12578 gfc_symbol
* super_type
;
12579 gfc_tbp_generic
* target
;
12581 gcc_assert (stree
&& stree
->n
.tb
);
12583 if (stree
->n
.tb
->error
)
12586 /* Operators should always be GENERIC bindings. */
12587 gcc_assert (stree
->n
.tb
->is_generic
);
12589 /* Find overridden procedure, if any. */
12590 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12591 if (super_type
&& super_type
->f2k_derived
)
12593 gfc_symtree
* overridden
;
12594 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12595 stree
->name
, true, NULL
);
12597 if (overridden
&& overridden
->n
.tb
)
12598 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12601 stree
->n
.tb
->overridden
= NULL
;
12603 /* Resolve basically using worker function. */
12604 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12607 /* Check the targets to be functions of correct interface. */
12608 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12610 gfc_symbol
* target_proc
;
12612 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12616 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12623 resolve_bindings_result
= false;
12624 stree
->n
.tb
->error
= 1;
12628 /* Resolve the type-bound procedures for a derived type. */
12631 resolve_typebound_procedure (gfc_symtree
* stree
)
12635 gfc_symbol
* me_arg
;
12636 gfc_symbol
* super_type
;
12637 gfc_component
* comp
;
12639 gcc_assert (stree
);
12641 /* Undefined specific symbol from GENERIC target definition. */
12645 if (stree
->n
.tb
->error
)
12648 /* If this is a GENERIC binding, use that routine. */
12649 if (stree
->n
.tb
->is_generic
)
12651 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12656 /* Get the target-procedure to check it. */
12657 gcc_assert (!stree
->n
.tb
->is_generic
);
12658 gcc_assert (stree
->n
.tb
->u
.specific
);
12659 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12660 where
= stree
->n
.tb
->where
;
12662 /* Default access should already be resolved from the parser. */
12663 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12665 if (stree
->n
.tb
->deferred
)
12667 if (!check_proc_interface (proc
, &where
))
12672 /* Check for F08:C465. */
12673 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12674 || (proc
->attr
.proc
!= PROC_MODULE
12675 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12676 || proc
->attr
.abstract
)
12678 gfc_error ("%qs must be a module procedure or an external procedure with"
12679 " an explicit interface at %L", proc
->name
, &where
);
12684 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12685 stree
->n
.tb
->function
= proc
->attr
.function
;
12687 /* Find the super-type of the current derived type. We could do this once and
12688 store in a global if speed is needed, but as long as not I believe this is
12689 more readable and clearer. */
12690 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12692 /* If PASS, resolve and check arguments if not already resolved / loaded
12693 from a .mod file. */
12694 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12696 gfc_formal_arglist
*dummy_args
;
12698 dummy_args
= gfc_sym_get_dummy_args (proc
);
12699 if (stree
->n
.tb
->pass_arg
)
12701 gfc_formal_arglist
*i
;
12703 /* If an explicit passing argument name is given, walk the arg-list
12704 and look for it. */
12707 stree
->n
.tb
->pass_arg_num
= 1;
12708 for (i
= dummy_args
; i
; i
= i
->next
)
12710 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12715 ++stree
->n
.tb
->pass_arg_num
;
12720 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12722 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12723 stree
->n
.tb
->pass_arg
);
12729 /* Otherwise, take the first one; there should in fact be at least
12731 stree
->n
.tb
->pass_arg_num
= 1;
12734 gfc_error ("Procedure %qs with PASS at %L must have at"
12735 " least one argument", proc
->name
, &where
);
12738 me_arg
= dummy_args
->sym
;
12741 /* Now check that the argument-type matches and the passed-object
12742 dummy argument is generally fine. */
12744 gcc_assert (me_arg
);
12746 if (me_arg
->ts
.type
!= BT_CLASS
)
12748 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12749 " at %L", proc
->name
, &where
);
12753 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12754 != resolve_bindings_derived
)
12756 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12757 " the derived-type %qs", me_arg
->name
, proc
->name
,
12758 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12762 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12763 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12765 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12766 " scalar", proc
->name
, &where
);
12769 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12771 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12772 " be ALLOCATABLE", proc
->name
, &where
);
12775 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12777 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12778 " be POINTER", proc
->name
, &where
);
12783 /* If we are extending some type, check that we don't override a procedure
12784 flagged NON_OVERRIDABLE. */
12785 stree
->n
.tb
->overridden
= NULL
;
12788 gfc_symtree
* overridden
;
12789 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12790 stree
->name
, true, NULL
);
12794 if (overridden
->n
.tb
)
12795 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12797 if (!gfc_check_typebound_override (stree
, overridden
))
12802 /* See if there's a name collision with a component directly in this type. */
12803 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12804 if (!strcmp (comp
->name
, stree
->name
))
12806 gfc_error ("Procedure %qs at %L has the same name as a component of"
12808 stree
->name
, &where
, resolve_bindings_derived
->name
);
12812 /* Try to find a name collision with an inherited component. */
12813 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
12816 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12817 " component of %qs",
12818 stree
->name
, &where
, resolve_bindings_derived
->name
);
12822 stree
->n
.tb
->error
= 0;
12826 resolve_bindings_result
= false;
12827 stree
->n
.tb
->error
= 1;
12832 resolve_typebound_procedures (gfc_symbol
* derived
)
12835 gfc_symbol
* super_type
;
12837 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12840 super_type
= gfc_get_derived_super_type (derived
);
12842 resolve_symbol (super_type
);
12844 resolve_bindings_derived
= derived
;
12845 resolve_bindings_result
= true;
12847 if (derived
->f2k_derived
->tb_sym_root
)
12848 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12849 &resolve_typebound_procedure
);
12851 if (derived
->f2k_derived
->tb_uop_root
)
12852 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12853 &resolve_typebound_user_op
);
12855 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12857 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12858 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12859 (gfc_intrinsic_op
)op
, p
))
12860 resolve_bindings_result
= false;
12863 return resolve_bindings_result
;
12867 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12868 to give all identical derived types the same backend_decl. */
12870 add_dt_to_dt_list (gfc_symbol
*derived
)
12872 gfc_dt_list
*dt_list
;
12874 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12875 if (derived
== dt_list
->derived
)
12878 dt_list
= gfc_get_dt_list ();
12879 dt_list
->next
= gfc_derived_types
;
12880 dt_list
->derived
= derived
;
12881 gfc_derived_types
= dt_list
;
12885 /* Ensure that a derived-type is really not abstract, meaning that every
12886 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12889 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12894 if (!ensure_not_abstract_walker (sub
, st
->left
))
12896 if (!ensure_not_abstract_walker (sub
, st
->right
))
12899 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12901 gfc_symtree
* overriding
;
12902 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12905 gcc_assert (overriding
->n
.tb
);
12906 if (overriding
->n
.tb
->deferred
)
12908 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12909 " %qs is DEFERRED and not overridden",
12910 sub
->name
, &sub
->declared_at
, st
->name
);
12919 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12921 /* The algorithm used here is to recursively travel up the ancestry of sub
12922 and for each ancestor-type, check all bindings. If any of them is
12923 DEFERRED, look it up starting from sub and see if the found (overriding)
12924 binding is not DEFERRED.
12925 This is not the most efficient way to do this, but it should be ok and is
12926 clearer than something sophisticated. */
12928 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12930 if (!ancestor
->attr
.abstract
)
12933 /* Walk bindings of this ancestor. */
12934 if (ancestor
->f2k_derived
)
12937 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12942 /* Find next ancestor type and recurse on it. */
12943 ancestor
= gfc_get_derived_super_type (ancestor
);
12945 return ensure_not_abstract (sub
, ancestor
);
12951 /* This check for typebound defined assignments is done recursively
12952 since the order in which derived types are resolved is not always in
12953 order of the declarations. */
12956 check_defined_assignments (gfc_symbol
*derived
)
12960 for (c
= derived
->components
; c
; c
= c
->next
)
12962 if (!gfc_bt_struct (c
->ts
.type
)
12964 || c
->attr
.allocatable
12965 || c
->attr
.proc_pointer_comp
12966 || c
->attr
.class_pointer
12967 || c
->attr
.proc_pointer
)
12970 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12971 || (c
->ts
.u
.derived
->f2k_derived
12972 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12974 derived
->attr
.defined_assign_comp
= 1;
12978 check_defined_assignments (c
->ts
.u
.derived
);
12979 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12981 derived
->attr
.defined_assign_comp
= 1;
12988 /* Resolve a single component of a derived type or structure. */
12991 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
12993 gfc_symbol
*super_type
;
12995 if (c
->attr
.artificial
)
12999 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13000 && c
->attr
.codimension
13001 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13003 gfc_error ("Coarray component %qs at %L must be allocatable with "
13004 "deferred shape", c
->name
, &c
->loc
);
13009 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13010 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13012 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13013 "shall not be a coarray", c
->name
, &c
->loc
);
13018 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13019 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13020 || c
->attr
.allocatable
))
13022 gfc_error ("Component %qs at %L with coarray component "
13023 "shall be a nonpointer, nonallocatable scalar",
13029 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
13031 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13032 "is not an array pointer", c
->name
, &c
->loc
);
13036 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13038 gfc_symbol
*ifc
= c
->ts
.interface
;
13040 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13046 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13048 /* Resolve interface and copy attributes. */
13049 if (ifc
->formal
&& !ifc
->formal_ns
)
13050 resolve_symbol (ifc
);
13051 if (ifc
->attr
.intrinsic
)
13052 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13056 c
->ts
= ifc
->result
->ts
;
13057 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13058 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13059 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13060 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13061 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13066 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13067 c
->attr
.pointer
= ifc
->attr
.pointer
;
13068 c
->attr
.dimension
= ifc
->attr
.dimension
;
13069 c
->as
= gfc_copy_array_spec (ifc
->as
);
13070 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13072 c
->ts
.interface
= ifc
;
13073 c
->attr
.function
= ifc
->attr
.function
;
13074 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13076 c
->attr
.pure
= ifc
->attr
.pure
;
13077 c
->attr
.elemental
= ifc
->attr
.elemental
;
13078 c
->attr
.recursive
= ifc
->attr
.recursive
;
13079 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13080 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13081 /* Copy char length. */
13082 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13084 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13085 if (cl
->length
&& !cl
->resolved
13086 && !gfc_resolve_expr (cl
->length
))
13095 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13097 /* Since PPCs are not implicitly typed, a PPC without an explicit
13098 interface must be a subroutine. */
13099 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13102 /* Procedure pointer components: Check PASS arg. */
13103 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13104 && !sym
->attr
.vtype
)
13106 gfc_symbol
* me_arg
;
13108 if (c
->tb
->pass_arg
)
13110 gfc_formal_arglist
* i
;
13112 /* If an explicit passing argument name is given, walk the arg-list
13113 and look for it. */
13116 c
->tb
->pass_arg_num
= 1;
13117 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13119 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13124 c
->tb
->pass_arg_num
++;
13129 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13130 "at %L has no argument %qs", c
->name
,
13131 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13138 /* Otherwise, take the first one; there should in fact be at least
13140 c
->tb
->pass_arg_num
= 1;
13141 if (!c
->ts
.interface
->formal
)
13143 gfc_error ("Procedure pointer component %qs with PASS at %L "
13144 "must have at least one argument",
13149 me_arg
= c
->ts
.interface
->formal
->sym
;
13152 /* Now check that the argument-type matches. */
13153 gcc_assert (me_arg
);
13154 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13155 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13156 || (me_arg
->ts
.type
== BT_CLASS
13157 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13159 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13160 " the derived type %qs", me_arg
->name
, c
->name
,
13161 me_arg
->name
, &c
->loc
, sym
->name
);
13166 /* Check for C453. */
13167 if (me_arg
->attr
.dimension
)
13169 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13170 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13176 if (me_arg
->attr
.pointer
)
13178 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13179 "may not have the POINTER attribute", me_arg
->name
,
13180 c
->name
, me_arg
->name
, &c
->loc
);
13185 if (me_arg
->attr
.allocatable
)
13187 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13188 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13189 me_arg
->name
, &c
->loc
);
13194 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13196 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13197 " at %L", c
->name
, &c
->loc
);
13203 /* Check type-spec if this is not the parent-type component. */
13204 if (((sym
->attr
.is_class
13205 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13206 || c
!= sym
->components
->ts
.u
.derived
->components
))
13207 || (!sym
->attr
.is_class
13208 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13209 && !sym
->attr
.vtype
13210 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13213 super_type
= gfc_get_derived_super_type (sym
);
13215 /* If this type is an extension, set the accessibility of the parent
13218 && ((sym
->attr
.is_class
13219 && c
== sym
->components
->ts
.u
.derived
->components
)
13220 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13221 && strcmp (super_type
->name
, c
->name
) == 0)
13222 c
->attr
.access
= super_type
->attr
.access
;
13224 /* If this type is an extension, see if this component has the same name
13225 as an inherited type-bound procedure. */
13226 if (super_type
&& !sym
->attr
.is_class
13227 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13229 gfc_error ("Component %qs of %qs at %L has the same name as an"
13230 " inherited type-bound procedure",
13231 c
->name
, sym
->name
, &c
->loc
);
13235 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13236 && !c
->ts
.deferred
)
13238 if (c
->ts
.u
.cl
->length
== NULL
13239 || (!resolve_charlen(c
->ts
.u
.cl
))
13240 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13242 gfc_error ("Character length of component %qs needs to "
13243 "be a constant specification expression at %L",
13245 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13250 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13251 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13253 gfc_error ("Character component %qs of %qs at %L with deferred "
13254 "length must be a POINTER or ALLOCATABLE",
13255 c
->name
, sym
->name
, &c
->loc
);
13259 /* Add the hidden deferred length field. */
13260 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
13261 && !sym
->attr
.is_class
)
13263 char name
[GFC_MAX_SYMBOL_LEN
+9];
13264 gfc_component
*strlen
;
13265 sprintf (name
, "_%s_length", c
->name
);
13266 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
13267 if (strlen
== NULL
)
13269 if (!gfc_add_component (sym
, name
, &strlen
))
13271 strlen
->ts
.type
= BT_INTEGER
;
13272 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13273 strlen
->attr
.access
= ACCESS_PRIVATE
;
13274 strlen
->attr
.artificial
= 1;
13278 if (c
->ts
.type
== BT_DERIVED
13279 && sym
->component_access
!= ACCESS_PRIVATE
13280 && gfc_check_symbol_access (sym
)
13281 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13282 && !c
->ts
.u
.derived
->attr
.use_assoc
13283 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13284 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13285 "PRIVATE type and cannot be a component of "
13286 "%qs, which is PUBLIC at %L", c
->name
,
13287 sym
->name
, &sym
->declared_at
))
13290 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13292 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13293 "type %s", c
->name
, &c
->loc
, sym
->name
);
13297 if (sym
->attr
.sequence
)
13299 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13301 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13302 "not have the SEQUENCE attribute",
13303 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13308 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13309 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13310 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13311 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13312 CLASS_DATA (c
)->ts
.u
.derived
13313 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13315 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13316 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13317 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13319 gfc_error ("The pointer component %qs of %qs at %L is a type "
13320 "that has not been declared", c
->name
, sym
->name
,
13325 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13326 && CLASS_DATA (c
)->attr
.class_pointer
13327 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13328 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13329 && !UNLIMITED_POLY (c
))
13331 gfc_error ("The pointer component %qs of %qs at %L is a type "
13332 "that has not been declared", c
->name
, sym
->name
,
13338 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
13339 && (!c
->attr
.class_ok
13340 || !(CLASS_DATA (c
)->attr
.class_pointer
13341 || CLASS_DATA (c
)->attr
.allocatable
)))
13343 gfc_error ("Component %qs with CLASS at %L must be allocatable "
13344 "or pointer", c
->name
, &c
->loc
);
13345 /* Prevent a recurrence of the error. */
13346 c
->ts
.type
= BT_UNKNOWN
;
13350 /* Ensure that all the derived type components are put on the
13351 derived type list; even in formal namespaces, where derived type
13352 pointer components might not have been declared. */
13353 if (c
->ts
.type
== BT_DERIVED
13355 && c
->ts
.u
.derived
->components
13357 && sym
!= c
->ts
.u
.derived
)
13358 add_dt_to_dt_list (c
->ts
.u
.derived
);
13360 if (!gfc_resolve_array_spec (c
->as
,
13361 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13362 || c
->attr
.allocatable
)))
13365 if (c
->initializer
&& !sym
->attr
.vtype
13366 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13373 /* Be nice about the locus for a structure expression - show the locus of the
13374 first non-null sub-expression if we can. */
13377 cons_where (gfc_expr
*struct_expr
)
13379 gfc_constructor
*cons
;
13381 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
13383 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
13384 for (; cons
; cons
= gfc_constructor_next (cons
))
13386 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
13387 return &cons
->expr
->where
;
13390 return &struct_expr
->where
;
13393 /* Resolve the components of a structure type. Much less work than derived
13397 resolve_fl_struct (gfc_symbol
*sym
)
13400 gfc_expr
*init
= NULL
;
13403 /* Make sure UNIONs do not have overlapping initializers. */
13404 if (sym
->attr
.flavor
== FL_UNION
)
13406 for (c
= sym
->components
; c
; c
= c
->next
)
13408 if (init
&& c
->initializer
)
13410 gfc_error ("Conflicting initializers in union at %L and %L",
13411 cons_where (init
), cons_where (c
->initializer
));
13412 gfc_free_expr (c
->initializer
);
13413 c
->initializer
= NULL
;
13416 init
= c
->initializer
;
13421 for (c
= sym
->components
; c
; c
= c
->next
)
13422 if (!resolve_component (c
, sym
))
13428 if (sym
->components
)
13429 add_dt_to_dt_list (sym
);
13435 /* Resolve the components of a derived type. This does not have to wait until
13436 resolution stage, but can be done as soon as the dt declaration has been
13440 resolve_fl_derived0 (gfc_symbol
*sym
)
13442 gfc_symbol
* super_type
;
13446 if (sym
->attr
.unlimited_polymorphic
)
13449 super_type
= gfc_get_derived_super_type (sym
);
13452 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
13454 gfc_error ("As extending type %qs at %L has a coarray component, "
13455 "parent type %qs shall also have one", sym
->name
,
13456 &sym
->declared_at
, super_type
->name
);
13460 /* Ensure the extended type gets resolved before we do. */
13461 if (super_type
&& !resolve_fl_derived0 (super_type
))
13464 /* An ABSTRACT type must be extensible. */
13465 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
13467 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
13468 sym
->name
, &sym
->declared_at
);
13472 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
13476 for ( ; c
!= NULL
; c
= c
->next
)
13477 if (!resolve_component (c
, sym
))
13483 check_defined_assignments (sym
);
13485 if (!sym
->attr
.defined_assign_comp
&& super_type
)
13486 sym
->attr
.defined_assign_comp
13487 = super_type
->attr
.defined_assign_comp
;
13489 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13490 all DEFERRED bindings are overridden. */
13491 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
13492 && !sym
->attr
.is_class
13493 && !ensure_not_abstract (sym
, super_type
))
13496 /* Add derived type to the derived type list. */
13497 add_dt_to_dt_list (sym
);
13503 /* The following procedure does the full resolution of a derived type,
13504 including resolution of all type-bound procedures (if present). In contrast
13505 to 'resolve_fl_derived0' this can only be done after the module has been
13506 parsed completely. */
13509 resolve_fl_derived (gfc_symbol
*sym
)
13511 gfc_symbol
*gen_dt
= NULL
;
13513 if (sym
->attr
.unlimited_polymorphic
)
13516 if (!sym
->attr
.is_class
)
13517 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
13518 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
13519 && (!gen_dt
->generic
->sym
->attr
.use_assoc
13520 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
13521 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
13522 "%qs at %L being the same name as derived "
13523 "type at %L", sym
->name
,
13524 gen_dt
->generic
->sym
== sym
13525 ? gen_dt
->generic
->next
->sym
->name
13526 : gen_dt
->generic
->sym
->name
,
13527 gen_dt
->generic
->sym
== sym
13528 ? &gen_dt
->generic
->next
->sym
->declared_at
13529 : &gen_dt
->generic
->sym
->declared_at
,
13530 &sym
->declared_at
))
13533 /* Resolve the finalizer procedures. */
13534 if (!gfc_resolve_finalizers (sym
, NULL
))
13537 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
13539 /* Fix up incomplete CLASS symbols. */
13540 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
13541 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
13543 /* Nothing more to do for unlimited polymorphic entities. */
13544 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
13546 else if (vptr
->ts
.u
.derived
== NULL
)
13548 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
13550 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
13554 if (!resolve_fl_derived0 (sym
))
13557 /* Resolve the type-bound procedures. */
13558 if (!resolve_typebound_procedures (sym
))
13565 /* Check for formatted read and write DTIO procedures. */
13568 dtio_procs_present (gfc_symbol
*sym
)
13570 gfc_symbol
*derived
;
13572 if (sym
->ts
.type
== BT_CLASS
)
13573 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
13574 else if (sym
->ts
.type
== BT_DERIVED
)
13575 derived
= sym
->ts
.u
.derived
;
13579 return gfc_find_specific_dtio_proc (derived
, true, true) != NULL
13580 && gfc_find_specific_dtio_proc (derived
, false, true) != NULL
;
13585 resolve_fl_namelist (gfc_symbol
*sym
)
13591 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13593 /* Check again, the check in match only works if NAMELIST comes
13595 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
13597 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13598 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13602 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
13603 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13604 "with assumed shape in namelist %qs at %L",
13605 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13608 if (is_non_constant_shape_array (nl
->sym
)
13609 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13610 "with nonconstant shape in namelist %qs at %L",
13611 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13614 if (nl
->sym
->ts
.type
== BT_CHARACTER
13615 && (nl
->sym
->ts
.u
.cl
->length
== NULL
13616 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13617 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13618 "nonconstant character length in "
13619 "namelist %qs at %L", nl
->sym
->name
,
13620 sym
->name
, &sym
->declared_at
))
13623 dtio
= dtio_procs_present (nl
->sym
);
13625 if (nl
->sym
->ts
.type
== BT_CLASS
&& !dtio
)
13627 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13628 "polymorphic and requires a defined input/output "
13629 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13633 if (nl
->sym
->ts
.type
== BT_DERIVED
13634 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13635 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13637 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13638 "namelist %qs at %L with ALLOCATABLE "
13639 "or POINTER components", nl
->sym
->name
,
13640 sym
->name
, &sym
->declared_at
))
13645 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13646 "ALLOCATABLE or POINTER components and thus requires "
13647 "a defined input/output procedure", nl
->sym
->name
,
13648 sym
->name
, &sym
->declared_at
);
13654 /* Reject PRIVATE objects in a PUBLIC namelist. */
13655 if (gfc_check_symbol_access (sym
))
13657 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13659 if (!nl
->sym
->attr
.use_assoc
13660 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13661 && !gfc_check_symbol_access (nl
->sym
))
13663 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13664 "cannot be member of PUBLIC namelist %qs at %L",
13665 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13669 /* If the derived type has specific DTIO procedures for both read and
13670 write then namelist objects with private components are OK. */
13671 if (dtio_procs_present (nl
->sym
))
13674 /* Types with private components that came here by USE-association. */
13675 if (nl
->sym
->ts
.type
== BT_DERIVED
13676 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13678 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13679 "components and cannot be member of namelist %qs at %L",
13680 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13684 /* Types with private components that are defined in the same module. */
13685 if (nl
->sym
->ts
.type
== BT_DERIVED
13686 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13687 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13689 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13690 "cannot be a member of PUBLIC namelist %qs at %L",
13691 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13698 /* 14.1.2 A module or internal procedure represent local entities
13699 of the same type as a namelist member and so are not allowed. */
13700 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13702 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13705 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13706 if ((nl
->sym
== sym
->ns
->proc_name
)
13708 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13713 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13714 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13716 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13717 "attribute in %qs at %L", nlsym
->name
,
13718 &sym
->declared_at
);
13728 resolve_fl_parameter (gfc_symbol
*sym
)
13730 /* A parameter array's shape needs to be constant. */
13731 if (sym
->as
!= NULL
13732 && (sym
->as
->type
== AS_DEFERRED
13733 || is_non_constant_shape_array (sym
)))
13735 gfc_error ("Parameter array %qs at %L cannot be automatic "
13736 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13740 /* Constraints on deferred type parameter. */
13741 if (!deferred_requirements (sym
))
13744 /* Make sure a parameter that has been implicitly typed still
13745 matches the implicit type, since PARAMETER statements can precede
13746 IMPLICIT statements. */
13747 if (sym
->attr
.implicit_type
13748 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13751 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13752 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13756 /* Make sure the types of derived parameters are consistent. This
13757 type checking is deferred until resolution because the type may
13758 refer to a derived type from the host. */
13759 if (sym
->ts
.type
== BT_DERIVED
13760 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13762 gfc_error ("Incompatible derived type in PARAMETER at %L",
13763 &sym
->value
->where
);
13770 /* Do anything necessary to resolve a symbol. Right now, we just
13771 assume that an otherwise unknown symbol is a variable. This sort
13772 of thing commonly happens for symbols in module. */
13775 resolve_symbol (gfc_symbol
*sym
)
13777 int check_constant
, mp_flag
;
13778 gfc_symtree
*symtree
;
13779 gfc_symtree
*this_symtree
;
13782 symbol_attribute class_attr
;
13783 gfc_array_spec
*as
;
13784 bool saved_specification_expr
;
13790 /* No symbol will ever have union type; only components can be unions.
13791 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
13792 (just like derived type declaration symbols have flavor FL_DERIVED). */
13793 gcc_assert (sym
->ts
.type
!= BT_UNION
);
13795 /* Coarrayed polymorphic objects with allocatable or pointer components are
13796 yet unsupported for -fcoarray=lib. */
13797 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
13798 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
13799 && CLASS_DATA (sym
)->attr
.codimension
13800 && (sym
->ts
.u
.derived
->attr
.alloc_comp
13801 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
13803 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
13804 "type coarrays at %L are unsupported", &sym
->declared_at
);
13808 if (sym
->attr
.artificial
)
13811 if (sym
->attr
.unlimited_polymorphic
)
13814 if (sym
->attr
.flavor
== FL_UNKNOWN
13815 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13816 && !sym
->attr
.generic
&& !sym
->attr
.external
13817 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13818 && sym
->ts
.type
== BT_UNKNOWN
))
13821 /* If we find that a flavorless symbol is an interface in one of the
13822 parent namespaces, find its symtree in this namespace, free the
13823 symbol and set the symtree to point to the interface symbol. */
13824 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13826 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13827 if (symtree
&& (symtree
->n
.sym
->generic
||
13828 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13829 && sym
->ns
->construct_entities
)))
13831 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13833 if (this_symtree
->n
.sym
== sym
)
13835 symtree
->n
.sym
->refs
++;
13836 gfc_release_symbol (sym
);
13837 this_symtree
->n
.sym
= symtree
->n
.sym
;
13843 /* Otherwise give it a flavor according to such attributes as
13845 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13846 && sym
->attr
.intrinsic
== 0)
13847 sym
->attr
.flavor
= FL_VARIABLE
;
13848 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13850 sym
->attr
.flavor
= FL_PROCEDURE
;
13851 if (sym
->attr
.dimension
)
13852 sym
->attr
.function
= 1;
13856 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13857 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13859 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13860 && !resolve_procedure_interface (sym
))
13863 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13864 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13866 if (sym
->attr
.external
)
13867 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13868 "at %L", &sym
->declared_at
);
13870 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13871 "at %L", &sym
->declared_at
);
13876 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13879 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
13880 && !resolve_fl_struct (sym
))
13883 /* Symbols that are module procedures with results (functions) have
13884 the types and array specification copied for type checking in
13885 procedures that call them, as well as for saving to a module
13886 file. These symbols can't stand the scrutiny that their results
13888 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13890 /* Make sure that the intrinsic is consistent with its internal
13891 representation. This needs to be done before assigning a default
13892 type to avoid spurious warnings. */
13893 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13894 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13897 /* Resolve associate names. */
13899 resolve_assoc_var (sym
, true);
13901 /* Assign default type to symbols that need one and don't have one. */
13902 if (sym
->ts
.type
== BT_UNKNOWN
)
13904 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13906 gfc_set_default_type (sym
, 1, NULL
);
13909 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13910 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13911 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13912 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13914 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13916 /* The specific case of an external procedure should emit an error
13917 in the case that there is no implicit type. */
13920 if (!sym
->attr
.mixed_entry_master
)
13921 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13925 /* Result may be in another namespace. */
13926 resolve_symbol (sym
->result
);
13928 if (!sym
->result
->attr
.proc_pointer
)
13930 sym
->ts
= sym
->result
->ts
;
13931 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13932 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13933 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13934 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13935 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13940 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13942 bool saved_specification_expr
= specification_expr
;
13943 specification_expr
= true;
13944 gfc_resolve_array_spec (sym
->result
->as
, false);
13945 specification_expr
= saved_specification_expr
;
13948 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13950 as
= CLASS_DATA (sym
)->as
;
13951 class_attr
= CLASS_DATA (sym
)->attr
;
13952 class_attr
.pointer
= class_attr
.class_pointer
;
13956 class_attr
= sym
->attr
;
13961 if (sym
->attr
.contiguous
13962 && (!class_attr
.dimension
13963 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13964 && !class_attr
.pointer
)))
13966 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13967 "array pointer or an assumed-shape or assumed-rank array",
13968 sym
->name
, &sym
->declared_at
);
13972 /* Assumed size arrays and assumed shape arrays must be dummy
13973 arguments. Array-spec's of implied-shape should have been resolved to
13974 AS_EXPLICIT already. */
13978 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13979 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13980 || as
->type
== AS_ASSUMED_SHAPE
)
13981 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13983 if (as
->type
== AS_ASSUMED_SIZE
)
13984 gfc_error ("Assumed size array at %L must be a dummy argument",
13985 &sym
->declared_at
);
13987 gfc_error ("Assumed shape array at %L must be a dummy argument",
13988 &sym
->declared_at
);
13991 /* TS 29113, C535a. */
13992 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13993 && !sym
->attr
.select_type_temporary
)
13995 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13996 &sym
->declared_at
);
13999 if (as
->type
== AS_ASSUMED_RANK
14000 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14002 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14003 "CODIMENSION attribute", &sym
->declared_at
);
14008 /* Make sure symbols with known intent or optional are really dummy
14009 variable. Because of ENTRY statement, this has to be deferred
14010 until resolution time. */
14012 if (!sym
->attr
.dummy
14013 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14015 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14019 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14021 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14022 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14026 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14028 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14029 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14031 gfc_error ("Character dummy variable %qs at %L with VALUE "
14032 "attribute must have constant length",
14033 sym
->name
, &sym
->declared_at
);
14037 if (sym
->ts
.is_c_interop
14038 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14040 gfc_error ("C interoperable character dummy variable %qs at %L "
14041 "with VALUE attribute must have length one",
14042 sym
->name
, &sym
->declared_at
);
14047 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14048 && sym
->ts
.u
.derived
->attr
.generic
)
14050 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
14051 if (!sym
->ts
.u
.derived
)
14053 gfc_error ("The derived type %qs at %L is of type %qs, "
14054 "which has not been defined", sym
->name
,
14055 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14056 sym
->ts
.type
= BT_UNKNOWN
;
14061 /* Use the same constraints as TYPE(*), except for the type check
14062 and that only scalars and assumed-size arrays are permitted. */
14063 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
14065 if (!sym
->attr
.dummy
)
14067 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14068 "a dummy argument", sym
->name
, &sym
->declared_at
);
14072 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
14073 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
14074 && sym
->ts
.type
!= BT_COMPLEX
)
14076 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14077 "of type TYPE(*) or of an numeric intrinsic type",
14078 sym
->name
, &sym
->declared_at
);
14082 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14083 || sym
->attr
.pointer
|| sym
->attr
.value
)
14085 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14086 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14087 "attribute", sym
->name
, &sym
->declared_at
);
14091 if (sym
->attr
.intent
== INTENT_OUT
)
14093 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14094 "have the INTENT(OUT) attribute",
14095 sym
->name
, &sym
->declared_at
);
14098 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
14100 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14101 "either be a scalar or an assumed-size array",
14102 sym
->name
, &sym
->declared_at
);
14106 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14107 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14109 sym
->ts
.type
= BT_ASSUMED
;
14110 sym
->as
= gfc_get_array_spec ();
14111 sym
->as
->type
= AS_ASSUMED_SIZE
;
14113 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
14115 else if (sym
->ts
.type
== BT_ASSUMED
)
14117 /* TS 29113, C407a. */
14118 if (!sym
->attr
.dummy
)
14120 gfc_error ("Assumed type of variable %s at %L is only permitted "
14121 "for dummy variables", sym
->name
, &sym
->declared_at
);
14124 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
14125 || sym
->attr
.pointer
|| sym
->attr
.value
)
14127 gfc_error ("Assumed-type variable %s at %L may not have the "
14128 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14129 sym
->name
, &sym
->declared_at
);
14132 if (sym
->attr
.intent
== INTENT_OUT
)
14134 gfc_error ("Assumed-type variable %s at %L may not have the "
14135 "INTENT(OUT) attribute",
14136 sym
->name
, &sym
->declared_at
);
14139 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
14141 gfc_error ("Assumed-type variable %s at %L shall not be an "
14142 "explicit-shape array", sym
->name
, &sym
->declared_at
);
14147 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
14148 do this for something that was implicitly typed because that is handled
14149 in gfc_set_default_type. Handle dummy arguments and procedure
14150 definitions separately. Also, anything that is use associated is not
14151 handled here but instead is handled in the module it is declared in.
14152 Finally, derived type definitions are allowed to be BIND(C) since that
14153 only implies that they're interoperable, and they are checked fully for
14154 interoperability when a variable is declared of that type. */
14155 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
14156 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
14157 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
14161 /* First, make sure the variable is declared at the
14162 module-level scope (J3/04-007, Section 15.3). */
14163 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
14164 sym
->attr
.in_common
== 0)
14166 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14167 "is neither a COMMON block nor declared at the "
14168 "module level scope", sym
->name
, &(sym
->declared_at
));
14171 else if (sym
->common_head
!= NULL
)
14173 t
= verify_com_block_vars_c_interop (sym
->common_head
);
14177 /* If type() declaration, we need to verify that the components
14178 of the given type are all C interoperable, etc. */
14179 if (sym
->ts
.type
== BT_DERIVED
&&
14180 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
14182 /* Make sure the user marked the derived type as BIND(C). If
14183 not, call the verify routine. This could print an error
14184 for the derived type more than once if multiple variables
14185 of that type are declared. */
14186 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
14187 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
14191 /* Verify the variable itself as C interoperable if it
14192 is BIND(C). It is not possible for this to succeed if
14193 the verify_bind_c_derived_type failed, so don't have to handle
14194 any error returned by verify_bind_c_derived_type. */
14195 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
14196 sym
->common_block
);
14201 /* clear the is_bind_c flag to prevent reporting errors more than
14202 once if something failed. */
14203 sym
->attr
.is_bind_c
= 0;
14208 /* If a derived type symbol has reached this point, without its
14209 type being declared, we have an error. Notice that most
14210 conditions that produce undefined derived types have already
14211 been dealt with. However, the likes of:
14212 implicit type(t) (t) ..... call foo (t) will get us here if
14213 the type is not declared in the scope of the implicit
14214 statement. Change the type to BT_UNKNOWN, both because it is so
14215 and to prevent an ICE. */
14216 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14217 && sym
->ts
.u
.derived
->components
== NULL
14218 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14220 gfc_error ("The derived type %qs at %L is of type %qs, "
14221 "which has not been defined", sym
->name
,
14222 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14223 sym
->ts
.type
= BT_UNKNOWN
;
14227 /* Make sure that the derived type has been resolved and that the
14228 derived type is visible in the symbol's namespace, if it is a
14229 module function and is not PRIVATE. */
14230 if (sym
->ts
.type
== BT_DERIVED
14231 && sym
->ts
.u
.derived
->attr
.use_assoc
14232 && sym
->ns
->proc_name
14233 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14234 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14237 /* Unless the derived-type declaration is use associated, Fortran 95
14238 does not allow public entries of private derived types.
14239 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14240 161 in 95-006r3. */
14241 if (sym
->ts
.type
== BT_DERIVED
14242 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14243 && !sym
->ts
.u
.derived
->attr
.use_assoc
14244 && gfc_check_symbol_access (sym
)
14245 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14246 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14247 "derived type %qs",
14248 (sym
->attr
.flavor
== FL_PARAMETER
)
14249 ? "parameter" : "variable",
14250 sym
->name
, &sym
->declared_at
,
14251 sym
->ts
.u
.derived
->name
))
14254 /* F2008, C1302. */
14255 if (sym
->ts
.type
== BT_DERIVED
14256 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14257 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14258 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14259 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14261 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14262 "type LOCK_TYPE must be a coarray", sym
->name
,
14263 &sym
->declared_at
);
14267 /* TS18508, C702/C703. */
14268 if (sym
->ts
.type
== BT_DERIVED
14269 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14270 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14271 || sym
->ts
.u
.derived
->attr
.event_comp
)
14272 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14274 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14275 "type LOCK_TYPE must be a coarray", sym
->name
,
14276 &sym
->declared_at
);
14280 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14281 default initialization is defined (5.1.2.4.4). */
14282 if (sym
->ts
.type
== BT_DERIVED
14284 && sym
->attr
.intent
== INTENT_OUT
14286 && sym
->as
->type
== AS_ASSUMED_SIZE
)
14288 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
14290 if (c
->initializer
)
14292 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14293 "ASSUMED SIZE and so cannot have a default initializer",
14294 sym
->name
, &sym
->declared_at
);
14301 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14302 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
14304 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14305 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14310 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14311 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
14313 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14314 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14319 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14320 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14321 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14322 || class_attr
.codimension
)
14323 && (sym
->attr
.result
|| sym
->result
== sym
))
14325 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14326 "a coarray component", sym
->name
, &sym
->declared_at
);
14331 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
14332 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
14334 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14335 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
14340 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14341 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14342 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14343 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
14344 || class_attr
.allocatable
))
14346 gfc_error ("Variable %qs at %L with coarray component shall be a "
14347 "nonpointer, nonallocatable scalar, which is not a coarray",
14348 sym
->name
, &sym
->declared_at
);
14352 /* F2008, C526. The function-result case was handled above. */
14353 if (class_attr
.codimension
14354 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
14355 || sym
->attr
.select_type_temporary
14356 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14357 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14358 || sym
->ns
->proc_name
->attr
.is_main_program
14359 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
14361 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14362 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
14366 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
14367 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
14369 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
14370 "deferred shape", sym
->name
, &sym
->declared_at
);
14373 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
14374 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
14376 gfc_error ("Allocatable coarray variable %qs at %L must have "
14377 "deferred shape", sym
->name
, &sym
->declared_at
);
14382 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14383 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14384 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14385 || (class_attr
.codimension
&& class_attr
.allocatable
))
14386 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
14388 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
14389 "allocatable coarray or have coarray components",
14390 sym
->name
, &sym
->declared_at
);
14394 if (class_attr
.codimension
&& sym
->attr
.dummy
14395 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
14397 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
14398 "procedure %qs", sym
->name
, &sym
->declared_at
,
14399 sym
->ns
->proc_name
->name
);
14403 if (sym
->ts
.type
== BT_LOGICAL
14404 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
14405 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
14406 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
14409 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
14410 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
14412 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
14413 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
14414 "%L with non-C_Bool kind in BIND(C) procedure "
14415 "%qs", sym
->name
, &sym
->declared_at
,
14416 sym
->ns
->proc_name
->name
))
14418 else if (!gfc_logical_kinds
[i
].c_bool
14419 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
14420 "%qs at %L with non-C_Bool kind in "
14421 "BIND(C) procedure %qs", sym
->name
,
14423 sym
->attr
.function
? sym
->name
14424 : sym
->ns
->proc_name
->name
))
14428 switch (sym
->attr
.flavor
)
14431 if (!resolve_fl_variable (sym
, mp_flag
))
14436 if (sym
->formal
&& !sym
->formal_ns
)
14438 /* Check that none of the arguments are a namelist. */
14439 gfc_formal_arglist
*formal
= sym
->formal
;
14441 for (; formal
; formal
= formal
->next
)
14442 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
14444 gfc_error ("Namelist '%s' can not be an argument to "
14445 "subroutine or function at %L",
14446 formal
->sym
->name
, &sym
->declared_at
);
14451 if (!resolve_fl_procedure (sym
, mp_flag
))
14456 if (!resolve_fl_namelist (sym
))
14461 if (!resolve_fl_parameter (sym
))
14469 /* Resolve array specifier. Check as well some constraints
14470 on COMMON blocks. */
14472 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
14474 /* Set the formal_arg_flag so that check_conflict will not throw
14475 an error for host associated variables in the specification
14476 expression for an array_valued function. */
14477 if (sym
->attr
.function
&& sym
->as
)
14478 formal_arg_flag
= 1;
14480 saved_specification_expr
= specification_expr
;
14481 specification_expr
= true;
14482 gfc_resolve_array_spec (sym
->as
, check_constant
);
14483 specification_expr
= saved_specification_expr
;
14485 formal_arg_flag
= 0;
14487 /* Resolve formal namespaces. */
14488 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
14489 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
14490 gfc_resolve (sym
->formal_ns
);
14492 /* Make sure the formal namespace is present. */
14493 if (sym
->formal
&& !sym
->formal_ns
)
14495 gfc_formal_arglist
*formal
= sym
->formal
;
14496 while (formal
&& !formal
->sym
)
14497 formal
= formal
->next
;
14501 sym
->formal_ns
= formal
->sym
->ns
;
14502 if (sym
->ns
!= formal
->sym
->ns
)
14503 sym
->formal_ns
->refs
++;
14507 /* Check threadprivate restrictions. */
14508 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
14509 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14510 && (!sym
->attr
.in_common
14511 && sym
->module
== NULL
14512 && (sym
->ns
->proc_name
== NULL
14513 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14514 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
14516 /* Check omp declare target restrictions. */
14517 if (sym
->attr
.omp_declare_target
14518 && sym
->attr
.flavor
== FL_VARIABLE
14520 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
14521 && (!sym
->attr
.in_common
14522 && sym
->module
== NULL
14523 && (sym
->ns
->proc_name
== NULL
14524 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14525 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14526 sym
->name
, &sym
->declared_at
);
14528 /* If we have come this far we can apply default-initializers, as
14529 described in 14.7.5, to those variables that have not already
14530 been assigned one. */
14531 if (sym
->ts
.type
== BT_DERIVED
14533 && !sym
->attr
.allocatable
14534 && !sym
->attr
.alloc_comp
)
14536 symbol_attribute
*a
= &sym
->attr
;
14538 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
14539 && !a
->in_common
&& !a
->use_assoc
14540 && !a
->result
&& !a
->function
)
14541 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
14542 apply_default_init (sym
);
14543 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
14544 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14545 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14546 /* Mark the result symbol to be referenced, when it has allocatable
14548 sym
->result
->attr
.referenced
= 1;
14551 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
14552 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
14553 && !CLASS_DATA (sym
)->attr
.class_pointer
14554 && !CLASS_DATA (sym
)->attr
.allocatable
)
14555 apply_default_init (sym
);
14557 /* If this symbol has a type-spec, check it. */
14558 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
14559 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
14560 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
14565 /************* Resolve DATA statements *************/
14569 gfc_data_value
*vnode
;
14575 /* Advance the values structure to point to the next value in the data list. */
14578 next_data_value (void)
14580 while (mpz_cmp_ui (values
.left
, 0) == 0)
14583 if (values
.vnode
->next
== NULL
)
14586 values
.vnode
= values
.vnode
->next
;
14587 mpz_set (values
.left
, values
.vnode
->repeat
);
14595 check_data_variable (gfc_data_variable
*var
, locus
*where
)
14601 ar_type mark
= AR_UNKNOWN
;
14603 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
14609 if (!gfc_resolve_expr (var
->expr
))
14613 mpz_init_set_si (offset
, 0);
14616 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
14617 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
14618 e
= e
->value
.function
.actual
->expr
;
14620 if (e
->expr_type
!= EXPR_VARIABLE
)
14621 gfc_internal_error ("check_data_variable(): Bad expression");
14623 sym
= e
->symtree
->n
.sym
;
14625 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
14627 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
14628 sym
->name
, &sym
->declared_at
);
14631 if (e
->ref
== NULL
&& sym
->as
)
14633 gfc_error ("DATA array %qs at %L must be specified in a previous"
14634 " declaration", sym
->name
, where
);
14638 has_pointer
= sym
->attr
.pointer
;
14640 if (gfc_is_coindexed (e
))
14642 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
14647 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14649 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
14653 && ref
->type
== REF_ARRAY
14654 && ref
->u
.ar
.type
!= AR_FULL
)
14656 gfc_error ("DATA element %qs at %L is a pointer and so must "
14657 "be a full array", sym
->name
, where
);
14662 if (e
->rank
== 0 || has_pointer
)
14664 mpz_init_set_ui (size
, 1);
14671 /* Find the array section reference. */
14672 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14674 if (ref
->type
!= REF_ARRAY
)
14676 if (ref
->u
.ar
.type
== AR_ELEMENT
)
14682 /* Set marks according to the reference pattern. */
14683 switch (ref
->u
.ar
.type
)
14691 /* Get the start position of array section. */
14692 gfc_get_section_index (ar
, section_index
, &offset
);
14697 gcc_unreachable ();
14700 if (!gfc_array_size (e
, &size
))
14702 gfc_error ("Nonconstant array section at %L in DATA statement",
14704 mpz_clear (offset
);
14711 while (mpz_cmp_ui (size
, 0) > 0)
14713 if (!next_data_value ())
14715 gfc_error ("DATA statement at %L has more variables than values",
14721 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14725 /* If we have more than one element left in the repeat count,
14726 and we have more than one element left in the target variable,
14727 then create a range assignment. */
14728 /* FIXME: Only done for full arrays for now, since array sections
14730 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14731 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14735 if (mpz_cmp (size
, values
.left
) >= 0)
14737 mpz_init_set (range
, values
.left
);
14738 mpz_sub (size
, size
, values
.left
);
14739 mpz_set_ui (values
.left
, 0);
14743 mpz_init_set (range
, size
);
14744 mpz_sub (values
.left
, values
.left
, size
);
14745 mpz_set_ui (size
, 0);
14748 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14751 mpz_add (offset
, offset
, range
);
14758 /* Assign initial value to symbol. */
14761 mpz_sub_ui (values
.left
, values
.left
, 1);
14762 mpz_sub_ui (size
, size
, 1);
14764 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14769 if (mark
== AR_FULL
)
14770 mpz_add_ui (offset
, offset
, 1);
14772 /* Modify the array section indexes and recalculate the offset
14773 for next element. */
14774 else if (mark
== AR_SECTION
)
14775 gfc_advance_section (section_index
, ar
, &offset
);
14779 if (mark
== AR_SECTION
)
14781 for (i
= 0; i
< ar
->dimen
; i
++)
14782 mpz_clear (section_index
[i
]);
14786 mpz_clear (offset
);
14792 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14794 /* Iterate over a list of elements in a DATA statement. */
14797 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14800 iterator_stack frame
;
14801 gfc_expr
*e
, *start
, *end
, *step
;
14802 bool retval
= true;
14804 mpz_init (frame
.value
);
14807 start
= gfc_copy_expr (var
->iter
.start
);
14808 end
= gfc_copy_expr (var
->iter
.end
);
14809 step
= gfc_copy_expr (var
->iter
.step
);
14811 if (!gfc_simplify_expr (start
, 1)
14812 || start
->expr_type
!= EXPR_CONSTANT
)
14814 gfc_error ("start of implied-do loop at %L could not be "
14815 "simplified to a constant value", &start
->where
);
14819 if (!gfc_simplify_expr (end
, 1)
14820 || end
->expr_type
!= EXPR_CONSTANT
)
14822 gfc_error ("end of implied-do loop at %L could not be "
14823 "simplified to a constant value", &start
->where
);
14827 if (!gfc_simplify_expr (step
, 1)
14828 || step
->expr_type
!= EXPR_CONSTANT
)
14830 gfc_error ("step of implied-do loop at %L could not be "
14831 "simplified to a constant value", &start
->where
);
14836 mpz_set (trip
, end
->value
.integer
);
14837 mpz_sub (trip
, trip
, start
->value
.integer
);
14838 mpz_add (trip
, trip
, step
->value
.integer
);
14840 mpz_div (trip
, trip
, step
->value
.integer
);
14842 mpz_set (frame
.value
, start
->value
.integer
);
14844 frame
.prev
= iter_stack
;
14845 frame
.variable
= var
->iter
.var
->symtree
;
14846 iter_stack
= &frame
;
14848 while (mpz_cmp_ui (trip
, 0) > 0)
14850 if (!traverse_data_var (var
->list
, where
))
14856 e
= gfc_copy_expr (var
->expr
);
14857 if (!gfc_simplify_expr (e
, 1))
14864 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14866 mpz_sub_ui (trip
, trip
, 1);
14870 mpz_clear (frame
.value
);
14873 gfc_free_expr (start
);
14874 gfc_free_expr (end
);
14875 gfc_free_expr (step
);
14877 iter_stack
= frame
.prev
;
14882 /* Type resolve variables in the variable list of a DATA statement. */
14885 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14889 for (; var
; var
= var
->next
)
14891 if (var
->expr
== NULL
)
14892 t
= traverse_data_list (var
, where
);
14894 t
= check_data_variable (var
, where
);
14904 /* Resolve the expressions and iterators associated with a data statement.
14905 This is separate from the assignment checking because data lists should
14906 only be resolved once. */
14909 resolve_data_variables (gfc_data_variable
*d
)
14911 for (; d
; d
= d
->next
)
14913 if (d
->list
== NULL
)
14915 if (!gfc_resolve_expr (d
->expr
))
14920 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14923 if (!resolve_data_variables (d
->list
))
14932 /* Resolve a single DATA statement. We implement this by storing a pointer to
14933 the value list into static variables, and then recursively traversing the
14934 variables list, expanding iterators and such. */
14937 resolve_data (gfc_data
*d
)
14940 if (!resolve_data_variables (d
->var
))
14943 values
.vnode
= d
->value
;
14944 if (d
->value
== NULL
)
14945 mpz_set_ui (values
.left
, 0);
14947 mpz_set (values
.left
, d
->value
->repeat
);
14949 if (!traverse_data_var (d
->var
, &d
->where
))
14952 /* At this point, we better not have any values left. */
14954 if (next_data_value ())
14955 gfc_error ("DATA statement at %L has more values than variables",
14960 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14961 accessed by host or use association, is a dummy argument to a pure function,
14962 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14963 is storage associated with any such variable, shall not be used in the
14964 following contexts: (clients of this function). */
14966 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14967 procedure. Returns zero if assignment is OK, nonzero if there is a
14970 gfc_impure_variable (gfc_symbol
*sym
)
14975 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14978 /* Check if the symbol's ns is inside the pure procedure. */
14979 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14983 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14987 proc
= sym
->ns
->proc_name
;
14988 if (sym
->attr
.dummy
14989 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14990 || proc
->attr
.function
))
14993 /* TODO: Sort out what can be storage associated, if anything, and include
14994 it here. In principle equivalences should be scanned but it does not
14995 seem to be possible to storage associate an impure variable this way. */
15000 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15001 current namespace is inside a pure procedure. */
15004 gfc_pure (gfc_symbol
*sym
)
15006 symbol_attribute attr
;
15011 /* Check if the current namespace or one of its parents
15012 belongs to a pure procedure. */
15013 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15015 sym
= ns
->proc_name
;
15019 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
15027 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
15031 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15032 checks if the current namespace is implicitly pure. Note that this
15033 function returns false for a PURE procedure. */
15036 gfc_implicit_pure (gfc_symbol
*sym
)
15042 /* Check if the current procedure is implicit_pure. Walk up
15043 the procedure list until we find a procedure. */
15044 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15046 sym
= ns
->proc_name
;
15050 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15055 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
15056 && !sym
->attr
.pure
;
15061 gfc_unset_implicit_pure (gfc_symbol
*sym
)
15067 /* Check if the current procedure is implicit_pure. Walk up
15068 the procedure list until we find a procedure. */
15069 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15071 sym
= ns
->proc_name
;
15075 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15080 if (sym
->attr
.flavor
== FL_PROCEDURE
)
15081 sym
->attr
.implicit_pure
= 0;
15083 sym
->attr
.pure
= 0;
15087 /* Test whether the current procedure is elemental or not. */
15090 gfc_elemental (gfc_symbol
*sym
)
15092 symbol_attribute attr
;
15095 sym
= gfc_current_ns
->proc_name
;
15100 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
15104 /* Warn about unused labels. */
15107 warn_unused_fortran_label (gfc_st_label
*label
)
15112 warn_unused_fortran_label (label
->left
);
15114 if (label
->defined
== ST_LABEL_UNKNOWN
)
15117 switch (label
->referenced
)
15119 case ST_LABEL_UNKNOWN
:
15120 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
15124 case ST_LABEL_BAD_TARGET
:
15125 gfc_warning (0, "Label %d at %L defined but cannot be used",
15126 label
->value
, &label
->where
);
15133 warn_unused_fortran_label (label
->right
);
15137 /* Returns the sequence type of a symbol or sequence. */
15140 sequence_type (gfc_typespec ts
)
15149 if (ts
.u
.derived
->components
== NULL
)
15150 return SEQ_NONDEFAULT
;
15152 result
= sequence_type (ts
.u
.derived
->components
->ts
);
15153 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
15154 if (sequence_type (c
->ts
) != result
)
15160 if (ts
.kind
!= gfc_default_character_kind
)
15161 return SEQ_NONDEFAULT
;
15163 return SEQ_CHARACTER
;
15166 if (ts
.kind
!= gfc_default_integer_kind
)
15167 return SEQ_NONDEFAULT
;
15169 return SEQ_NUMERIC
;
15172 if (!(ts
.kind
== gfc_default_real_kind
15173 || ts
.kind
== gfc_default_double_kind
))
15174 return SEQ_NONDEFAULT
;
15176 return SEQ_NUMERIC
;
15179 if (ts
.kind
!= gfc_default_complex_kind
)
15180 return SEQ_NONDEFAULT
;
15182 return SEQ_NUMERIC
;
15185 if (ts
.kind
!= gfc_default_logical_kind
)
15186 return SEQ_NONDEFAULT
;
15188 return SEQ_NUMERIC
;
15191 return SEQ_NONDEFAULT
;
15196 /* Resolve derived type EQUIVALENCE object. */
15199 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
15201 gfc_component
*c
= derived
->components
;
15206 /* Shall not be an object of nonsequence derived type. */
15207 if (!derived
->attr
.sequence
)
15209 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15210 "attribute to be an EQUIVALENCE object", sym
->name
,
15215 /* Shall not have allocatable components. */
15216 if (derived
->attr
.alloc_comp
)
15218 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15219 "components to be an EQUIVALENCE object",sym
->name
,
15224 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
15226 gfc_error ("Derived type variable %qs at %L with default "
15227 "initialization cannot be in EQUIVALENCE with a variable "
15228 "in COMMON", sym
->name
, &e
->where
);
15232 for (; c
; c
= c
->next
)
15234 if (gfc_bt_struct (c
->ts
.type
)
15235 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15238 /* Shall not be an object of sequence derived type containing a pointer
15239 in the structure. */
15240 if (c
->attr
.pointer
)
15242 gfc_error ("Derived type variable %qs at %L with pointer "
15243 "component(s) cannot be an EQUIVALENCE object",
15244 sym
->name
, &e
->where
);
15252 /* Resolve equivalence object.
15253 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15254 an allocatable array, an object of nonsequence derived type, an object of
15255 sequence derived type containing a pointer at any level of component
15256 selection, an automatic object, a function name, an entry name, a result
15257 name, a named constant, a structure component, or a subobject of any of
15258 the preceding objects. A substring shall not have length zero. A
15259 derived type shall not have components with default initialization nor
15260 shall two objects of an equivalence group be initialized.
15261 Either all or none of the objects shall have an protected attribute.
15262 The simple constraints are done in symbol.c(check_conflict) and the rest
15263 are implemented here. */
15266 resolve_equivalence (gfc_equiv
*eq
)
15269 gfc_symbol
*first_sym
;
15272 locus
*last_where
= NULL
;
15273 seq_type eq_type
, last_eq_type
;
15274 gfc_typespec
*last_ts
;
15275 int object
, cnt_protected
;
15278 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
15280 first_sym
= eq
->expr
->symtree
->n
.sym
;
15284 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
15288 e
->ts
= e
->symtree
->n
.sym
->ts
;
15289 /* match_varspec might not know yet if it is seeing
15290 array reference or substring reference, as it doesn't
15292 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
15294 gfc_ref
*ref
= e
->ref
;
15295 sym
= e
->symtree
->n
.sym
;
15297 if (sym
->attr
.dimension
)
15299 ref
->u
.ar
.as
= sym
->as
;
15303 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15304 if (e
->ts
.type
== BT_CHARACTER
15306 && ref
->type
== REF_ARRAY
15307 && ref
->u
.ar
.dimen
== 1
15308 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
15309 && ref
->u
.ar
.stride
[0] == NULL
)
15311 gfc_expr
*start
= ref
->u
.ar
.start
[0];
15312 gfc_expr
*end
= ref
->u
.ar
.end
[0];
15315 /* Optimize away the (:) reference. */
15316 if (start
== NULL
&& end
== NULL
)
15319 e
->ref
= ref
->next
;
15321 e
->ref
->next
= ref
->next
;
15326 ref
->type
= REF_SUBSTRING
;
15328 start
= gfc_get_int_expr (gfc_default_integer_kind
,
15330 ref
->u
.ss
.start
= start
;
15331 if (end
== NULL
&& e
->ts
.u
.cl
)
15332 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
15333 ref
->u
.ss
.end
= end
;
15334 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
15341 /* Any further ref is an error. */
15344 gcc_assert (ref
->type
== REF_ARRAY
);
15345 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15351 if (!gfc_resolve_expr (e
))
15354 sym
= e
->symtree
->n
.sym
;
15356 if (sym
->attr
.is_protected
)
15358 if (cnt_protected
> 0 && cnt_protected
!= object
)
15360 gfc_error ("Either all or none of the objects in the "
15361 "EQUIVALENCE set at %L shall have the "
15362 "PROTECTED attribute",
15367 /* Shall not equivalence common block variables in a PURE procedure. */
15368 if (sym
->ns
->proc_name
15369 && sym
->ns
->proc_name
->attr
.pure
15370 && sym
->attr
.in_common
)
15372 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
15373 "object in the pure procedure %qs",
15374 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
15378 /* Shall not be a named constant. */
15379 if (e
->expr_type
== EXPR_CONSTANT
)
15381 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
15382 "object", sym
->name
, &e
->where
);
15386 if (e
->ts
.type
== BT_DERIVED
15387 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
15390 /* Check that the types correspond correctly:
15392 A numeric sequence structure may be equivalenced to another sequence
15393 structure, an object of default integer type, default real type, double
15394 precision real type, default logical type such that components of the
15395 structure ultimately only become associated to objects of the same
15396 kind. A character sequence structure may be equivalenced to an object
15397 of default character kind or another character sequence structure.
15398 Other objects may be equivalenced only to objects of the same type and
15399 kind parameters. */
15401 /* Identical types are unconditionally OK. */
15402 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
15403 goto identical_types
;
15405 last_eq_type
= sequence_type (*last_ts
);
15406 eq_type
= sequence_type (sym
->ts
);
15408 /* Since the pair of objects is not of the same type, mixed or
15409 non-default sequences can be rejected. */
15411 msg
= "Sequence %s with mixed components in EQUIVALENCE "
15412 "statement at %L with different type objects";
15414 && last_eq_type
== SEQ_MIXED
15415 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15416 || (eq_type
== SEQ_MIXED
15417 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15420 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
15421 "statement at %L with objects of different type";
15423 && last_eq_type
== SEQ_NONDEFAULT
15424 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15425 || (eq_type
== SEQ_NONDEFAULT
15426 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15429 msg
="Non-CHARACTER object %qs in default CHARACTER "
15430 "EQUIVALENCE statement at %L";
15431 if (last_eq_type
== SEQ_CHARACTER
15432 && eq_type
!= SEQ_CHARACTER
15433 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15436 msg
="Non-NUMERIC object %qs in default NUMERIC "
15437 "EQUIVALENCE statement at %L";
15438 if (last_eq_type
== SEQ_NUMERIC
15439 && eq_type
!= SEQ_NUMERIC
15440 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15445 last_where
= &e
->where
;
15450 /* Shall not be an automatic array. */
15451 if (e
->ref
->type
== REF_ARRAY
15452 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
15454 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15455 "an EQUIVALENCE object", sym
->name
, &e
->where
);
15462 /* Shall not be a structure component. */
15463 if (r
->type
== REF_COMPONENT
)
15465 gfc_error ("Structure component %qs at %L cannot be an "
15466 "EQUIVALENCE object",
15467 r
->u
.c
.component
->name
, &e
->where
);
15471 /* A substring shall not have length zero. */
15472 if (r
->type
== REF_SUBSTRING
)
15474 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
15476 gfc_error ("Substring at %L has length zero",
15477 &r
->u
.ss
.start
->where
);
15487 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15490 resolve_fntype (gfc_namespace
*ns
)
15492 gfc_entry_list
*el
;
15495 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
15498 /* If there are any entries, ns->proc_name is the entry master
15499 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15501 sym
= ns
->entries
->sym
;
15503 sym
= ns
->proc_name
;
15504 if (sym
->result
== sym
15505 && sym
->ts
.type
== BT_UNKNOWN
15506 && !gfc_set_default_type (sym
, 0, NULL
)
15507 && !sym
->attr
.untyped
)
15509 gfc_error ("Function %qs at %L has no IMPLICIT type",
15510 sym
->name
, &sym
->declared_at
);
15511 sym
->attr
.untyped
= 1;
15514 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
15515 && !sym
->attr
.contained
15516 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15517 && gfc_check_symbol_access (sym
))
15519 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
15520 "%L of PRIVATE type %qs", sym
->name
,
15521 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15525 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
15527 if (el
->sym
->result
== el
->sym
15528 && el
->sym
->ts
.type
== BT_UNKNOWN
15529 && !gfc_set_default_type (el
->sym
, 0, NULL
)
15530 && !el
->sym
->attr
.untyped
)
15532 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
15533 el
->sym
->name
, &el
->sym
->declared_at
);
15534 el
->sym
->attr
.untyped
= 1;
15540 /* 12.3.2.1.1 Defined operators. */
15543 check_uop_procedure (gfc_symbol
*sym
, locus where
)
15545 gfc_formal_arglist
*formal
;
15547 if (!sym
->attr
.function
)
15549 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
15550 sym
->name
, &where
);
15554 if (sym
->ts
.type
== BT_CHARACTER
15555 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
15556 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
15557 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
15559 gfc_error ("User operator procedure %qs at %L cannot be assumed "
15560 "character length", sym
->name
, &where
);
15564 formal
= gfc_sym_get_dummy_args (sym
);
15565 if (!formal
|| !formal
->sym
)
15567 gfc_error ("User operator procedure %qs at %L must have at least "
15568 "one argument", sym
->name
, &where
);
15572 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15574 gfc_error ("First argument of operator interface at %L must be "
15575 "INTENT(IN)", &where
);
15579 if (formal
->sym
->attr
.optional
)
15581 gfc_error ("First argument of operator interface at %L cannot be "
15582 "optional", &where
);
15586 formal
= formal
->next
;
15587 if (!formal
|| !formal
->sym
)
15590 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15592 gfc_error ("Second argument of operator interface at %L must be "
15593 "INTENT(IN)", &where
);
15597 if (formal
->sym
->attr
.optional
)
15599 gfc_error ("Second argument of operator interface at %L cannot be "
15600 "optional", &where
);
15606 gfc_error ("Operator interface at %L must have, at most, two "
15607 "arguments", &where
);
15615 gfc_resolve_uops (gfc_symtree
*symtree
)
15617 gfc_interface
*itr
;
15619 if (symtree
== NULL
)
15622 gfc_resolve_uops (symtree
->left
);
15623 gfc_resolve_uops (symtree
->right
);
15625 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
15626 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
15630 /* Examine all of the expressions associated with a program unit,
15631 assign types to all intermediate expressions, make sure that all
15632 assignments are to compatible types and figure out which names
15633 refer to which functions or subroutines. It doesn't check code
15634 block, which is handled by gfc_resolve_code. */
15637 resolve_types (gfc_namespace
*ns
)
15643 gfc_namespace
* old_ns
= gfc_current_ns
;
15645 if (ns
->types_resolved
)
15648 /* Check that all IMPLICIT types are ok. */
15649 if (!ns
->seen_implicit_none
)
15652 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
15653 if (ns
->set_flag
[letter
]
15654 && !resolve_typespec_used (&ns
->default_type
[letter
],
15655 &ns
->implicit_loc
[letter
], NULL
))
15659 gfc_current_ns
= ns
;
15661 resolve_entries (ns
);
15663 resolve_common_vars (&ns
->blank_common
, false);
15664 resolve_common_blocks (ns
->common_root
);
15666 resolve_contained_functions (ns
);
15668 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
15669 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15670 resolve_formal_arglist (ns
->proc_name
);
15672 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
15674 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
15675 resolve_charlen (cl
);
15677 gfc_traverse_ns (ns
, resolve_symbol
);
15679 resolve_fntype (ns
);
15681 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15683 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
15684 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
15685 "also be PURE", n
->proc_name
->name
,
15686 &n
->proc_name
->declared_at
);
15692 gfc_do_concurrent_flag
= 0;
15693 gfc_check_interfaces (ns
);
15695 gfc_traverse_ns (ns
, resolve_values
);
15701 for (d
= ns
->data
; d
; d
= d
->next
)
15705 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
15707 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
15709 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
15710 resolve_equivalence (eq
);
15712 /* Warn about unused labels. */
15713 if (warn_unused_label
)
15714 warn_unused_fortran_label (ns
->st_labels
);
15716 gfc_resolve_uops (ns
->uop_root
);
15718 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
15720 gfc_resolve_omp_declare_simd (ns
);
15722 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
15724 ns
->types_resolved
= 1;
15726 gfc_current_ns
= old_ns
;
15730 /* Call gfc_resolve_code recursively. */
15733 resolve_codes (gfc_namespace
*ns
)
15736 bitmap_obstack old_obstack
;
15738 if (ns
->resolved
== 1)
15741 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15744 gfc_current_ns
= ns
;
15746 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15747 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
15750 /* Set to an out of range value. */
15751 current_entry_id
= -1;
15753 old_obstack
= labels_obstack
;
15754 bitmap_obstack_initialize (&labels_obstack
);
15756 gfc_resolve_oacc_declare (ns
);
15757 gfc_resolve_code (ns
->code
, ns
);
15759 bitmap_obstack_release (&labels_obstack
);
15760 labels_obstack
= old_obstack
;
15764 /* This function is called after a complete program unit has been compiled.
15765 Its purpose is to examine all of the expressions associated with a program
15766 unit, assign types to all intermediate expressions, make sure that all
15767 assignments are to compatible types and figure out which names refer to
15768 which functions or subroutines. */
15771 gfc_resolve (gfc_namespace
*ns
)
15773 gfc_namespace
*old_ns
;
15774 code_stack
*old_cs_base
;
15775 struct gfc_omp_saved_state old_omp_state
;
15781 old_ns
= gfc_current_ns
;
15782 old_cs_base
= cs_base
;
15784 /* As gfc_resolve can be called during resolution of an OpenMP construct
15785 body, we should clear any state associated to it, so that say NS's
15786 DO loops are not interpreted as OpenMP loops. */
15787 if (!ns
->construct_entities
)
15788 gfc_omp_save_and_clear_state (&old_omp_state
);
15790 resolve_types (ns
);
15791 component_assignment_level
= 0;
15792 resolve_codes (ns
);
15794 gfc_current_ns
= old_ns
;
15795 cs_base
= old_cs_base
;
15798 gfc_run_passes (ns
);
15800 if (!ns
->construct_entities
)
15801 gfc_omp_restore_state (&old_omp_state
);