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 || sym
->attr
.flavor
== FL_DERIVED
|| 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
);
1121 /* Resolve all of the elements of a structure constructor and make sure that
1122 the types are correct. The 'init' flag indicates that the given
1123 constructor is an initializer. */
1126 resolve_structure_cons (gfc_expr
*expr
, int init
)
1128 gfc_constructor
*cons
;
1129 gfc_component
*comp
;
1135 if (expr
->ts
.type
== BT_DERIVED
)
1136 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1138 cons
= gfc_constructor_first (expr
->value
.constructor
);
1140 /* A constructor may have references if it is the result of substituting a
1141 parameter variable. In this case we just pull out the component we
1144 comp
= expr
->ref
->u
.c
.sym
->components
;
1146 comp
= expr
->ts
.u
.derived
->components
;
1148 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1155 if (!gfc_resolve_expr (cons
->expr
))
1161 rank
= comp
->as
? comp
->as
->rank
: 0;
1162 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1163 rank
= CLASS_DATA (comp
)->as
->rank
;
1165 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1166 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1168 gfc_error ("The rank of the element in the structure "
1169 "constructor at %L does not match that of the "
1170 "component (%d/%d)", &cons
->expr
->where
,
1171 cons
->expr
->rank
, rank
);
1175 /* If we don't have the right type, try to convert it. */
1177 if (!comp
->attr
.proc_pointer
&&
1178 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1180 if (strcmp (comp
->name
, "_extends") == 0)
1182 /* Can afford to be brutal with the _extends initializer.
1183 The derived type can get lost because it is PRIVATE
1184 but it is not usage constrained by the standard. */
1185 cons
->expr
->ts
= comp
->ts
;
1187 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1189 gfc_error ("The element in the structure constructor at %L, "
1190 "for pointer component %qs, is %s but should be %s",
1191 &cons
->expr
->where
, comp
->name
,
1192 gfc_basic_typename (cons
->expr
->ts
.type
),
1193 gfc_basic_typename (comp
->ts
.type
));
1198 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1204 /* For strings, the length of the constructor should be the same as
1205 the one of the structure, ensure this if the lengths are known at
1206 compile time and when we are dealing with PARAMETER or structure
1208 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1209 && comp
->ts
.u
.cl
->length
1210 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1211 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1212 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1213 && cons
->expr
->rank
!= 0
1214 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1215 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1217 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1218 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1220 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1221 to make use of the gfc_resolve_character_array_constructor
1222 machinery. The expression is later simplified away to
1223 an array of string literals. */
1224 gfc_expr
*para
= cons
->expr
;
1225 cons
->expr
= gfc_get_expr ();
1226 cons
->expr
->ts
= para
->ts
;
1227 cons
->expr
->where
= para
->where
;
1228 cons
->expr
->expr_type
= EXPR_ARRAY
;
1229 cons
->expr
->rank
= para
->rank
;
1230 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1231 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1232 para
, &cons
->expr
->where
);
1234 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1237 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1238 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1240 gfc_charlen
*cl
, *cl2
;
1243 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1245 if (cl
== cons
->expr
->ts
.u
.cl
)
1253 cl2
->next
= cl
->next
;
1255 gfc_free_expr (cl
->length
);
1259 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1260 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1261 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1262 gfc_resolve_character_array_constructor (cons
->expr
);
1266 if (cons
->expr
->expr_type
== EXPR_NULL
1267 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1268 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1269 || (comp
->ts
.type
== BT_CLASS
1270 && (CLASS_DATA (comp
)->attr
.class_pointer
1271 || CLASS_DATA (comp
)->attr
.allocatable
))))
1274 gfc_error ("The NULL in the structure constructor at %L is "
1275 "being applied to component %qs, which is neither "
1276 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1280 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1282 /* Check procedure pointer interface. */
1283 gfc_symbol
*s2
= NULL
;
1288 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1291 s2
= c2
->ts
.interface
;
1294 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1296 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1297 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1299 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1301 s2
= cons
->expr
->symtree
->n
.sym
;
1302 name
= cons
->expr
->symtree
->n
.sym
->name
;
1305 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1306 err
, sizeof (err
), NULL
, NULL
))
1308 gfc_error ("Interface mismatch for procedure-pointer component "
1309 "%qs in structure constructor at %L: %s",
1310 comp
->name
, &cons
->expr
->where
, err
);
1315 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1316 || cons
->expr
->expr_type
== EXPR_NULL
)
1319 a
= gfc_expr_attr (cons
->expr
);
1321 if (!a
.pointer
&& !a
.target
)
1324 gfc_error ("The element in the structure constructor at %L, "
1325 "for pointer component %qs should be a POINTER or "
1326 "a TARGET", &cons
->expr
->where
, comp
->name
);
1331 /* F08:C461. Additional checks for pointer initialization. */
1335 gfc_error ("Pointer initialization target at %L "
1336 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1341 gfc_error ("Pointer initialization target at %L "
1342 "must have the SAVE attribute", &cons
->expr
->where
);
1346 /* F2003, C1272 (3). */
1347 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1348 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1349 || gfc_is_coindexed (cons
->expr
));
1350 if (impure
&& gfc_pure (NULL
))
1353 gfc_error ("Invalid expression in the structure constructor for "
1354 "pointer component %qs at %L in PURE procedure",
1355 comp
->name
, &cons
->expr
->where
);
1359 gfc_unset_implicit_pure (NULL
);
1366 /****************** Expression name resolution ******************/
1368 /* Returns 0 if a symbol was not declared with a type or
1369 attribute declaration statement, nonzero otherwise. */
1372 was_declared (gfc_symbol
*sym
)
1378 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1381 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1382 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1383 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1384 || a
.asynchronous
|| a
.codimension
)
1391 /* Determine if a symbol is generic or not. */
1394 generic_sym (gfc_symbol
*sym
)
1398 if (sym
->attr
.generic
||
1399 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1402 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1405 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1412 return generic_sym (s
);
1419 /* Determine if a symbol is specific or not. */
1422 specific_sym (gfc_symbol
*sym
)
1426 if (sym
->attr
.if_source
== IFSRC_IFBODY
1427 || sym
->attr
.proc
== PROC_MODULE
1428 || sym
->attr
.proc
== PROC_INTERNAL
1429 || sym
->attr
.proc
== PROC_ST_FUNCTION
1430 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1431 || sym
->attr
.external
)
1434 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1437 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1439 return (s
== NULL
) ? 0 : specific_sym (s
);
1443 /* Figure out if the procedure is specific, generic or unknown. */
1446 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1449 procedure_kind (gfc_symbol
*sym
)
1451 if (generic_sym (sym
))
1452 return PTYPE_GENERIC
;
1454 if (specific_sym (sym
))
1455 return PTYPE_SPECIFIC
;
1457 return PTYPE_UNKNOWN
;
1460 /* Check references to assumed size arrays. The flag need_full_assumed_size
1461 is nonzero when matching actual arguments. */
1463 static int need_full_assumed_size
= 0;
1466 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1468 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1471 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1472 What should it be? */
1473 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1474 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1475 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1477 gfc_error ("The upper bound in the last dimension must "
1478 "appear in the reference to the assumed size "
1479 "array %qs at %L", sym
->name
, &e
->where
);
1486 /* Look for bad assumed size array references in argument expressions
1487 of elemental and array valued intrinsic procedures. Since this is
1488 called from procedure resolution functions, it only recurses at
1492 resolve_assumed_size_actual (gfc_expr
*e
)
1497 switch (e
->expr_type
)
1500 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1505 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1506 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1517 /* Check a generic procedure, passed as an actual argument, to see if
1518 there is a matching specific name. If none, it is an error, and if
1519 more than one, the reference is ambiguous. */
1521 count_specific_procs (gfc_expr
*e
)
1528 sym
= e
->symtree
->n
.sym
;
1530 for (p
= sym
->generic
; p
; p
= p
->next
)
1531 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1533 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1539 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1543 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1544 "argument at %L", sym
->name
, &e
->where
);
1550 /* See if a call to sym could possibly be a not allowed RECURSION because of
1551 a missing RECURSIVE declaration. This means that either sym is the current
1552 context itself, or sym is the parent of a contained procedure calling its
1553 non-RECURSIVE containing procedure.
1554 This also works if sym is an ENTRY. */
1557 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1559 gfc_symbol
* proc_sym
;
1560 gfc_symbol
* context_proc
;
1561 gfc_namespace
* real_context
;
1563 if (sym
->attr
.flavor
== FL_PROGRAM
1564 || sym
->attr
.flavor
== FL_DERIVED
)
1567 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1569 /* If we've got an ENTRY, find real procedure. */
1570 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1571 proc_sym
= sym
->ns
->entries
->sym
;
1575 /* If sym is RECURSIVE, all is well of course. */
1576 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1579 /* Find the context procedure's "real" symbol if it has entries.
1580 We look for a procedure symbol, so recurse on the parents if we don't
1581 find one (like in case of a BLOCK construct). */
1582 for (real_context
= context
; ; real_context
= real_context
->parent
)
1584 /* We should find something, eventually! */
1585 gcc_assert (real_context
);
1587 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1588 : real_context
->proc_name
);
1590 /* In some special cases, there may not be a proc_name, like for this
1592 real(bad_kind()) function foo () ...
1593 when checking the call to bad_kind ().
1594 In these cases, we simply return here and assume that the
1599 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1603 /* A call from sym's body to itself is recursion, of course. */
1604 if (context_proc
== proc_sym
)
1607 /* The same is true if context is a contained procedure and sym the
1609 if (context_proc
->attr
.contained
)
1611 gfc_symbol
* parent_proc
;
1613 gcc_assert (context
->parent
);
1614 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1615 : context
->parent
->proc_name
);
1617 if (parent_proc
== proc_sym
)
1625 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1626 its typespec and formal argument list. */
1629 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1631 gfc_intrinsic_sym
* isym
= NULL
;
1637 /* Already resolved. */
1638 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1641 /* We already know this one is an intrinsic, so we don't call
1642 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1643 gfc_find_subroutine directly to check whether it is a function or
1646 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1648 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1649 isym
= gfc_intrinsic_subroutine_by_id (id
);
1651 else if (sym
->intmod_sym_id
)
1653 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1654 isym
= gfc_intrinsic_function_by_id (id
);
1656 else if (!sym
->attr
.subroutine
)
1657 isym
= gfc_find_function (sym
->name
);
1659 if (isym
&& !sym
->attr
.subroutine
)
1661 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1662 && !sym
->attr
.implicit_type
)
1663 gfc_warning (OPT_Wsurprising
,
1664 "Type specified for intrinsic function %qs at %L is"
1665 " ignored", sym
->name
, &sym
->declared_at
);
1667 if (!sym
->attr
.function
&&
1668 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1673 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1675 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1677 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1678 " specifier", sym
->name
, &sym
->declared_at
);
1682 if (!sym
->attr
.subroutine
&&
1683 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1688 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1693 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1695 sym
->attr
.pure
= isym
->pure
;
1696 sym
->attr
.elemental
= isym
->elemental
;
1698 /* Check it is actually available in the standard settings. */
1699 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1701 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1702 "available in the current standard settings but %s. Use "
1703 "an appropriate %<-std=*%> option or enable "
1704 "%<-fall-intrinsics%> in order to use it.",
1705 sym
->name
, &sym
->declared_at
, symstd
);
1713 /* Resolve a procedure expression, like passing it to a called procedure or as
1714 RHS for a procedure pointer assignment. */
1717 resolve_procedure_expression (gfc_expr
* expr
)
1721 if (expr
->expr_type
!= EXPR_VARIABLE
)
1723 gcc_assert (expr
->symtree
);
1725 sym
= expr
->symtree
->n
.sym
;
1727 if (sym
->attr
.intrinsic
)
1728 gfc_resolve_intrinsic (sym
, &expr
->where
);
1730 if (sym
->attr
.flavor
!= FL_PROCEDURE
1731 || (sym
->attr
.function
&& sym
->result
== sym
))
1734 /* A non-RECURSIVE procedure that is used as procedure expression within its
1735 own body is in danger of being called recursively. */
1736 if (is_illegal_recursion (sym
, gfc_current_ns
))
1737 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1738 " itself recursively. Declare it RECURSIVE or use"
1739 " %<-frecursive%>", sym
->name
, &expr
->where
);
1745 /* Resolve an actual argument list. Most of the time, this is just
1746 resolving the expressions in the list.
1747 The exception is that we sometimes have to decide whether arguments
1748 that look like procedure arguments are really simple variable
1752 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1753 bool no_formal_args
)
1756 gfc_symtree
*parent_st
;
1758 gfc_component
*comp
;
1759 int save_need_full_assumed_size
;
1760 bool return_value
= false;
1761 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1764 first_actual_arg
= true;
1766 for (; arg
; arg
= arg
->next
)
1771 /* Check the label is a valid branching target. */
1774 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1776 gfc_error ("Label %d referenced at %L is never defined",
1777 arg
->label
->value
, &arg
->label
->where
);
1781 first_actual_arg
= false;
1785 if (e
->expr_type
== EXPR_VARIABLE
1786 && e
->symtree
->n
.sym
->attr
.generic
1788 && count_specific_procs (e
) != 1)
1791 if (e
->ts
.type
!= BT_PROCEDURE
)
1793 save_need_full_assumed_size
= need_full_assumed_size
;
1794 if (e
->expr_type
!= EXPR_VARIABLE
)
1795 need_full_assumed_size
= 0;
1796 if (!gfc_resolve_expr (e
))
1798 need_full_assumed_size
= save_need_full_assumed_size
;
1802 /* See if the expression node should really be a variable reference. */
1804 sym
= e
->symtree
->n
.sym
;
1806 if (sym
->attr
.flavor
== FL_PROCEDURE
1807 || sym
->attr
.intrinsic
1808 || sym
->attr
.external
)
1812 /* If a procedure is not already determined to be something else
1813 check if it is intrinsic. */
1814 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1815 sym
->attr
.intrinsic
= 1;
1817 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1819 gfc_error ("Statement function %qs at %L is not allowed as an "
1820 "actual argument", sym
->name
, &e
->where
);
1823 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1824 sym
->attr
.subroutine
);
1825 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1827 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1828 "actual argument", sym
->name
, &e
->where
);
1831 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1832 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1834 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1835 " used as actual argument at %L",
1836 sym
->name
, &e
->where
))
1840 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1842 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1843 "allowed as an actual argument at %L", sym
->name
,
1847 /* Check if a generic interface has a specific procedure
1848 with the same name before emitting an error. */
1849 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1852 /* Just in case a specific was found for the expression. */
1853 sym
= e
->symtree
->n
.sym
;
1855 /* If the symbol is the function that names the current (or
1856 parent) scope, then we really have a variable reference. */
1858 if (gfc_is_function_return_value (sym
, sym
->ns
))
1861 /* If all else fails, see if we have a specific intrinsic. */
1862 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1864 gfc_intrinsic_sym
*isym
;
1866 isym
= gfc_find_function (sym
->name
);
1867 if (isym
== NULL
|| !isym
->specific
)
1869 gfc_error ("Unable to find a specific INTRINSIC procedure "
1870 "for the reference %qs at %L", sym
->name
,
1875 sym
->attr
.intrinsic
= 1;
1876 sym
->attr
.function
= 1;
1879 if (!gfc_resolve_expr (e
))
1884 /* See if the name is a module procedure in a parent unit. */
1886 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1889 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1891 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1895 if (parent_st
== NULL
)
1898 sym
= parent_st
->n
.sym
;
1899 e
->symtree
= parent_st
; /* Point to the right thing. */
1901 if (sym
->attr
.flavor
== FL_PROCEDURE
1902 || sym
->attr
.intrinsic
1903 || sym
->attr
.external
)
1905 if (!gfc_resolve_expr (e
))
1911 e
->expr_type
= EXPR_VARIABLE
;
1913 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1914 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1915 && CLASS_DATA (sym
)->as
))
1917 e
->rank
= sym
->ts
.type
== BT_CLASS
1918 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1919 e
->ref
= gfc_get_ref ();
1920 e
->ref
->type
= REF_ARRAY
;
1921 e
->ref
->u
.ar
.type
= AR_FULL
;
1922 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1923 ? CLASS_DATA (sym
)->as
: sym
->as
;
1926 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1927 primary.c (match_actual_arg). If above code determines that it
1928 is a variable instead, it needs to be resolved as it was not
1929 done at the beginning of this function. */
1930 save_need_full_assumed_size
= need_full_assumed_size
;
1931 if (e
->expr_type
!= EXPR_VARIABLE
)
1932 need_full_assumed_size
= 0;
1933 if (!gfc_resolve_expr (e
))
1935 need_full_assumed_size
= save_need_full_assumed_size
;
1938 /* Check argument list functions %VAL, %LOC and %REF. There is
1939 nothing to do for %REF. */
1940 if (arg
->name
&& arg
->name
[0] == '%')
1942 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1944 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1946 gfc_error ("By-value argument at %L is not of numeric "
1953 gfc_error ("By-value argument at %L cannot be an array or "
1954 "an array section", &e
->where
);
1958 /* Intrinsics are still PROC_UNKNOWN here. However,
1959 since same file external procedures are not resolvable
1960 in gfortran, it is a good deal easier to leave them to
1962 if (ptype
!= PROC_UNKNOWN
1963 && ptype
!= PROC_DUMMY
1964 && ptype
!= PROC_EXTERNAL
1965 && ptype
!= PROC_MODULE
)
1967 gfc_error ("By-value argument at %L is not allowed "
1968 "in this context", &e
->where
);
1973 /* Statement functions have already been excluded above. */
1974 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1975 && e
->ts
.type
== BT_PROCEDURE
)
1977 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1979 gfc_error ("Passing internal procedure at %L by location "
1980 "not allowed", &e
->where
);
1986 comp
= gfc_get_proc_ptr_comp(e
);
1987 if (e
->expr_type
== EXPR_VARIABLE
1988 && comp
&& comp
->attr
.elemental
)
1990 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1991 "allowed as an actual argument at %L", comp
->name
,
1995 /* Fortran 2008, C1237. */
1996 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1997 && gfc_has_ultimate_pointer (e
))
1999 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2000 "component", &e
->where
);
2004 first_actual_arg
= false;
2007 return_value
= true;
2010 actual_arg
= actual_arg_sav
;
2011 first_actual_arg
= first_actual_arg_sav
;
2013 return return_value
;
2017 /* Do the checks of the actual argument list that are specific to elemental
2018 procedures. If called with c == NULL, we have a function, otherwise if
2019 expr == NULL, we have a subroutine. */
2022 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2024 gfc_actual_arglist
*arg0
;
2025 gfc_actual_arglist
*arg
;
2026 gfc_symbol
*esym
= NULL
;
2027 gfc_intrinsic_sym
*isym
= NULL
;
2029 gfc_intrinsic_arg
*iformal
= NULL
;
2030 gfc_formal_arglist
*eformal
= NULL
;
2031 bool formal_optional
= false;
2032 bool set_by_optional
= false;
2036 /* Is this an elemental procedure? */
2037 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2039 if (expr
->value
.function
.esym
!= NULL
2040 && expr
->value
.function
.esym
->attr
.elemental
)
2042 arg0
= expr
->value
.function
.actual
;
2043 esym
= expr
->value
.function
.esym
;
2045 else if (expr
->value
.function
.isym
!= NULL
2046 && expr
->value
.function
.isym
->elemental
)
2048 arg0
= expr
->value
.function
.actual
;
2049 isym
= expr
->value
.function
.isym
;
2054 else if (c
&& c
->ext
.actual
!= NULL
)
2056 arg0
= c
->ext
.actual
;
2058 if (c
->resolved_sym
)
2059 esym
= c
->resolved_sym
;
2061 esym
= c
->symtree
->n
.sym
;
2064 if (!esym
->attr
.elemental
)
2070 /* The rank of an elemental is the rank of its array argument(s). */
2071 for (arg
= arg0
; arg
; arg
= arg
->next
)
2073 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2075 rank
= arg
->expr
->rank
;
2076 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2077 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2078 set_by_optional
= true;
2080 /* Function specific; set the result rank and shape. */
2084 if (!expr
->shape
&& arg
->expr
->shape
)
2086 expr
->shape
= gfc_get_shape (rank
);
2087 for (i
= 0; i
< rank
; i
++)
2088 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2095 /* If it is an array, it shall not be supplied as an actual argument
2096 to an elemental procedure unless an array of the same rank is supplied
2097 as an actual argument corresponding to a nonoptional dummy argument of
2098 that elemental procedure(12.4.1.5). */
2099 formal_optional
= false;
2101 iformal
= isym
->formal
;
2103 eformal
= esym
->formal
;
2105 for (arg
= arg0
; arg
; arg
= arg
->next
)
2109 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2110 formal_optional
= true;
2111 eformal
= eformal
->next
;
2113 else if (isym
&& iformal
)
2115 if (iformal
->optional
)
2116 formal_optional
= true;
2117 iformal
= iformal
->next
;
2120 formal_optional
= true;
2122 if (pedantic
&& arg
->expr
!= NULL
2123 && arg
->expr
->expr_type
== EXPR_VARIABLE
2124 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2127 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2128 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2130 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2131 "MISSING, it cannot be the actual argument of an "
2132 "ELEMENTAL procedure unless there is a non-optional "
2133 "argument with the same rank (12.4.1.5)",
2134 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2138 for (arg
= arg0
; arg
; arg
= arg
->next
)
2140 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2143 /* Being elemental, the last upper bound of an assumed size array
2144 argument must be present. */
2145 if (resolve_assumed_size_actual (arg
->expr
))
2148 /* Elemental procedure's array actual arguments must conform. */
2151 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2158 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2159 is an array, the intent inout/out variable needs to be also an array. */
2160 if (rank
> 0 && esym
&& expr
== NULL
)
2161 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2162 arg
= arg
->next
, eformal
= eformal
->next
)
2163 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2164 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2165 && arg
->expr
&& arg
->expr
->rank
== 0)
2167 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2168 "ELEMENTAL subroutine %qs is a scalar, but another "
2169 "actual argument is an array", &arg
->expr
->where
,
2170 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2171 : "INOUT", eformal
->sym
->name
, esym
->name
);
2178 /* This function does the checking of references to global procedures
2179 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2180 77 and 95 standards. It checks for a gsymbol for the name, making
2181 one if it does not already exist. If it already exists, then the
2182 reference being resolved must correspond to the type of gsymbol.
2183 Otherwise, the new symbol is equipped with the attributes of the
2184 reference. The corresponding code that is called in creating
2185 global entities is parse.c.
2187 In addition, for all but -std=legacy, the gsymbols are used to
2188 check the interfaces of external procedures from the same file.
2189 The namespace of the gsymbol is resolved and then, once this is
2190 done the interface is checked. */
2194 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2196 if (!gsym_ns
->proc_name
->attr
.recursive
)
2199 if (sym
->ns
== gsym_ns
)
2202 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2209 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2211 if (gsym_ns
->entries
)
2213 gfc_entry_list
*entry
= gsym_ns
->entries
;
2215 for (; entry
; entry
= entry
->next
)
2217 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2219 if (strcmp (gsym_ns
->proc_name
->name
,
2220 sym
->ns
->proc_name
->name
) == 0)
2224 && strcmp (gsym_ns
->proc_name
->name
,
2225 sym
->ns
->parent
->proc_name
->name
) == 0)
2234 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2237 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2239 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2241 for ( ; arg
; arg
= arg
->next
)
2246 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2248 strncpy (errmsg
, _("allocatable argument"), err_len
);
2251 else if (arg
->sym
->attr
.asynchronous
)
2253 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2256 else if (arg
->sym
->attr
.optional
)
2258 strncpy (errmsg
, _("optional argument"), err_len
);
2261 else if (arg
->sym
->attr
.pointer
)
2263 strncpy (errmsg
, _("pointer argument"), err_len
);
2266 else if (arg
->sym
->attr
.target
)
2268 strncpy (errmsg
, _("target argument"), err_len
);
2271 else if (arg
->sym
->attr
.value
)
2273 strncpy (errmsg
, _("value argument"), err_len
);
2276 else if (arg
->sym
->attr
.volatile_
)
2278 strncpy (errmsg
, _("volatile argument"), err_len
);
2281 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2283 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2286 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2288 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2291 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2293 strncpy (errmsg
, _("coarray argument"), err_len
);
2296 else if (false) /* (2d) TODO: parametrized derived type */
2298 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2301 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2303 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2306 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2308 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2311 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2313 /* As assumed-type is unlimited polymorphic (cf. above).
2314 See also TS 29113, Note 6.1. */
2315 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2320 if (sym
->attr
.function
)
2322 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2324 if (res
->attr
.dimension
) /* (3a) */
2326 strncpy (errmsg
, _("array result"), err_len
);
2329 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2331 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2334 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2335 && res
->ts
.u
.cl
->length
2336 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2338 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2343 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2345 strncpy (errmsg
, _("elemental procedure"), err_len
);
2348 else if (sym
->attr
.is_bind_c
) /* (5) */
2350 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2359 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2360 gfc_actual_arglist
**actual
, int sub
)
2364 enum gfc_symbol_type type
;
2367 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2369 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2371 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2372 gfc_global_used (gsym
, where
);
2374 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2375 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2376 && gsym
->type
!= GSYM_UNKNOWN
2377 && !gsym
->binding_label
2379 && gsym
->ns
->resolved
!= -1
2380 && gsym
->ns
->proc_name
2381 && not_in_recursive (sym
, gsym
->ns
)
2382 && not_entry_self_reference (sym
, gsym
->ns
))
2384 gfc_symbol
*def_sym
;
2386 /* Resolve the gsymbol namespace if needed. */
2387 if (!gsym
->ns
->resolved
)
2389 gfc_dt_list
*old_dt_list
;
2391 /* Stash away derived types so that the backend_decls do not
2393 old_dt_list
= gfc_derived_types
;
2394 gfc_derived_types
= NULL
;
2396 gfc_resolve (gsym
->ns
);
2398 /* Store the new derived types with the global namespace. */
2399 if (gfc_derived_types
)
2400 gsym
->ns
->derived_types
= gfc_derived_types
;
2402 /* Restore the derived types of this namespace. */
2403 gfc_derived_types
= old_dt_list
;
2406 /* Make sure that translation for the gsymbol occurs before
2407 the procedure currently being resolved. */
2408 ns
= gfc_global_ns_list
;
2409 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2411 if (ns
->sibling
== gsym
->ns
)
2413 ns
->sibling
= gsym
->ns
->sibling
;
2414 gsym
->ns
->sibling
= gfc_global_ns_list
;
2415 gfc_global_ns_list
= gsym
->ns
;
2420 def_sym
= gsym
->ns
->proc_name
;
2422 /* This can happen if a binding name has been specified. */
2423 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2424 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2426 if (def_sym
->attr
.entry_master
)
2428 gfc_entry_list
*entry
;
2429 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2430 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2432 def_sym
= entry
->sym
;
2437 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2439 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2440 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2441 gfc_typename (&def_sym
->ts
));
2445 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2446 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2448 gfc_error ("Explicit interface required for %qs at %L: %s",
2449 sym
->name
, &sym
->declared_at
, reason
);
2453 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2454 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2455 gfc_errors_to_warnings (true);
2457 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2458 reason
, sizeof(reason
), NULL
, NULL
))
2460 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2461 sym
->name
, &sym
->declared_at
, reason
);
2466 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2467 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2468 gfc_errors_to_warnings (true);
2470 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2471 gfc_procedure_use (def_sym
, actual
, where
);
2475 gfc_errors_to_warnings (false);
2477 if (gsym
->type
== GSYM_UNKNOWN
)
2480 gsym
->where
= *where
;
2487 /************* Function resolution *************/
2489 /* Resolve a function call known to be generic.
2490 Section 14.1.2.4.1. */
2493 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2497 if (sym
->attr
.generic
)
2499 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2502 expr
->value
.function
.name
= s
->name
;
2503 expr
->value
.function
.esym
= s
;
2505 if (s
->ts
.type
!= BT_UNKNOWN
)
2507 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2508 expr
->ts
= s
->result
->ts
;
2511 expr
->rank
= s
->as
->rank
;
2512 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2513 expr
->rank
= s
->result
->as
->rank
;
2515 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2520 /* TODO: Need to search for elemental references in generic
2524 if (sym
->attr
.intrinsic
)
2525 return gfc_intrinsic_func_interface (expr
, 0);
2532 resolve_generic_f (gfc_expr
*expr
)
2536 gfc_interface
*intr
= NULL
;
2538 sym
= expr
->symtree
->n
.sym
;
2542 m
= resolve_generic_f0 (expr
, sym
);
2545 else if (m
== MATCH_ERROR
)
2550 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2551 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2554 if (sym
->ns
->parent
== NULL
)
2556 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2560 if (!generic_sym (sym
))
2564 /* Last ditch attempt. See if the reference is to an intrinsic
2565 that possesses a matching interface. 14.1.2.4 */
2566 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2568 if (gfc_init_expr_flag
)
2569 gfc_error ("Function %qs in initialization expression at %L "
2570 "must be an intrinsic function",
2571 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2573 gfc_error ("There is no specific function for the generic %qs "
2574 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2580 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2583 return resolve_structure_cons (expr
, 0);
2586 m
= gfc_intrinsic_func_interface (expr
, 0);
2591 gfc_error ("Generic function %qs at %L is not consistent with a "
2592 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2599 /* Resolve a function call known to be specific. */
2602 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2606 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2608 if (sym
->attr
.dummy
)
2610 sym
->attr
.proc
= PROC_DUMMY
;
2614 sym
->attr
.proc
= PROC_EXTERNAL
;
2618 if (sym
->attr
.proc
== PROC_MODULE
2619 || sym
->attr
.proc
== PROC_ST_FUNCTION
2620 || sym
->attr
.proc
== PROC_INTERNAL
)
2623 if (sym
->attr
.intrinsic
)
2625 m
= gfc_intrinsic_func_interface (expr
, 1);
2629 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2630 "with an intrinsic", sym
->name
, &expr
->where
);
2638 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2641 expr
->ts
= sym
->result
->ts
;
2644 expr
->value
.function
.name
= sym
->name
;
2645 expr
->value
.function
.esym
= sym
;
2646 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2648 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2650 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2651 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2652 else if (sym
->as
!= NULL
)
2653 expr
->rank
= sym
->as
->rank
;
2660 resolve_specific_f (gfc_expr
*expr
)
2665 sym
= expr
->symtree
->n
.sym
;
2669 m
= resolve_specific_f0 (sym
, expr
);
2672 if (m
== MATCH_ERROR
)
2675 if (sym
->ns
->parent
== NULL
)
2678 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2684 gfc_error ("Unable to resolve the specific function %qs at %L",
2685 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2691 /* Resolve a procedure call not known to be generic nor specific. */
2694 resolve_unknown_f (gfc_expr
*expr
)
2699 sym
= expr
->symtree
->n
.sym
;
2701 if (sym
->attr
.dummy
)
2703 sym
->attr
.proc
= PROC_DUMMY
;
2704 expr
->value
.function
.name
= sym
->name
;
2708 /* See if we have an intrinsic function reference. */
2710 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2712 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2717 /* The reference is to an external name. */
2719 sym
->attr
.proc
= PROC_EXTERNAL
;
2720 expr
->value
.function
.name
= sym
->name
;
2721 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2723 if (sym
->as
!= NULL
)
2724 expr
->rank
= sym
->as
->rank
;
2726 /* Type of the expression is either the type of the symbol or the
2727 default type of the symbol. */
2730 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2732 if (sym
->ts
.type
!= BT_UNKNOWN
)
2736 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2738 if (ts
->type
== BT_UNKNOWN
)
2740 gfc_error ("Function %qs at %L has no IMPLICIT type",
2741 sym
->name
, &expr
->where
);
2752 /* Return true, if the symbol is an external procedure. */
2754 is_external_proc (gfc_symbol
*sym
)
2756 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2757 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2758 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2759 && !sym
->attr
.proc_pointer
2760 && !sym
->attr
.use_assoc
2768 /* Figure out if a function reference is pure or not. Also set the name
2769 of the function for a potential error message. Return nonzero if the
2770 function is PURE, zero if not. */
2772 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2775 pure_function (gfc_expr
*e
, const char **name
)
2778 gfc_component
*comp
;
2782 if (e
->symtree
!= NULL
2783 && e
->symtree
->n
.sym
!= NULL
2784 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2785 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2787 comp
= gfc_get_proc_ptr_comp (e
);
2790 pure
= gfc_pure (comp
->ts
.interface
);
2793 else if (e
->value
.function
.esym
)
2795 pure
= gfc_pure (e
->value
.function
.esym
);
2796 *name
= e
->value
.function
.esym
->name
;
2798 else if (e
->value
.function
.isym
)
2800 pure
= e
->value
.function
.isym
->pure
2801 || e
->value
.function
.isym
->elemental
;
2802 *name
= e
->value
.function
.isym
->name
;
2806 /* Implicit functions are not pure. */
2808 *name
= e
->value
.function
.name
;
2816 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2817 int *f ATTRIBUTE_UNUSED
)
2821 /* Don't bother recursing into other statement functions
2822 since they will be checked individually for purity. */
2823 if (e
->expr_type
!= EXPR_FUNCTION
2825 || e
->symtree
->n
.sym
== sym
2826 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2829 return pure_function (e
, &name
) ? false : true;
2834 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2836 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2840 /* Check if an impure function is allowed in the current context. */
2842 static bool check_pure_function (gfc_expr
*e
)
2844 const char *name
= NULL
;
2845 if (!pure_function (e
, &name
) && name
)
2849 gfc_error ("Reference to impure function %qs at %L inside a "
2850 "FORALL %s", name
, &e
->where
,
2851 forall_flag
== 2 ? "mask" : "block");
2854 else if (gfc_do_concurrent_flag
)
2856 gfc_error ("Reference to impure function %qs at %L inside a "
2857 "DO CONCURRENT %s", name
, &e
->where
,
2858 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2861 else if (gfc_pure (NULL
))
2863 gfc_error ("Reference to impure function %qs at %L "
2864 "within a PURE procedure", name
, &e
->where
);
2867 gfc_unset_implicit_pure (NULL
);
2873 /* Update current procedure's array_outer_dependency flag, considering
2874 a call to procedure SYM. */
2877 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
2879 /* Check to see if this is a sibling function that has not yet
2881 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
2882 for (; sibling
; sibling
= sibling
->sibling
)
2884 if (sibling
->proc_name
== sym
)
2886 gfc_resolve (sibling
);
2891 /* If SYM has references to outer arrays, so has the procedure calling
2892 SYM. If SYM is a procedure pointer, we can assume the worst. */
2893 if (sym
->attr
.array_outer_dependency
2894 || sym
->attr
.proc_pointer
)
2895 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
2899 /* Resolve a function call, which means resolving the arguments, then figuring
2900 out which entity the name refers to. */
2903 resolve_function (gfc_expr
*expr
)
2905 gfc_actual_arglist
*arg
;
2909 procedure_type p
= PROC_INTRINSIC
;
2910 bool no_formal_args
;
2914 sym
= expr
->symtree
->n
.sym
;
2916 /* If this is a procedure pointer component, it has already been resolved. */
2917 if (gfc_is_proc_ptr_comp (expr
))
2920 if (sym
&& sym
->attr
.intrinsic
2921 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2924 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2926 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2930 /* If this ia a deferred TBP with an abstract interface (which may
2931 of course be referenced), expr->value.function.esym will be set. */
2932 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2934 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2935 sym
->name
, &expr
->where
);
2939 /* Switch off assumed size checking and do this again for certain kinds
2940 of procedure, once the procedure itself is resolved. */
2941 need_full_assumed_size
++;
2943 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2944 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2946 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2947 inquiry_argument
= true;
2948 no_formal_args
= sym
&& is_external_proc (sym
)
2949 && gfc_sym_get_dummy_args (sym
) == NULL
;
2951 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2954 inquiry_argument
= false;
2958 inquiry_argument
= false;
2960 /* Resume assumed_size checking. */
2961 need_full_assumed_size
--;
2963 /* If the procedure is external, check for usage. */
2964 if (sym
&& is_external_proc (sym
))
2965 resolve_global_procedure (sym
, &expr
->where
,
2966 &expr
->value
.function
.actual
, 0);
2968 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2970 && sym
->ts
.u
.cl
->length
== NULL
2972 && !sym
->ts
.deferred
2973 && expr
->value
.function
.esym
== NULL
2974 && !sym
->attr
.contained
)
2976 /* Internal procedures are taken care of in resolve_contained_fntype. */
2977 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2978 "be used at %L since it is not a dummy argument",
2979 sym
->name
, &expr
->where
);
2983 /* See if function is already resolved. */
2985 if (expr
->value
.function
.name
!= NULL
2986 || expr
->value
.function
.isym
!= NULL
)
2988 if (expr
->ts
.type
== BT_UNKNOWN
)
2994 /* Apply the rules of section 14.1.2. */
2996 switch (procedure_kind (sym
))
2999 t
= resolve_generic_f (expr
);
3002 case PTYPE_SPECIFIC
:
3003 t
= resolve_specific_f (expr
);
3007 t
= resolve_unknown_f (expr
);
3011 gfc_internal_error ("resolve_function(): bad function type");
3015 /* If the expression is still a function (it might have simplified),
3016 then we check to see if we are calling an elemental function. */
3018 if (expr
->expr_type
!= EXPR_FUNCTION
)
3021 temp
= need_full_assumed_size
;
3022 need_full_assumed_size
= 0;
3024 if (!resolve_elemental_actual (expr
, NULL
))
3027 if (omp_workshare_flag
3028 && expr
->value
.function
.esym
3029 && ! gfc_elemental (expr
->value
.function
.esym
))
3031 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3032 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3037 #define GENERIC_ID expr->value.function.isym->id
3038 else if (expr
->value
.function
.actual
!= NULL
3039 && expr
->value
.function
.isym
!= NULL
3040 && GENERIC_ID
!= GFC_ISYM_LBOUND
3041 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3042 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3043 && GENERIC_ID
!= GFC_ISYM_LEN
3044 && GENERIC_ID
!= GFC_ISYM_LOC
3045 && GENERIC_ID
!= GFC_ISYM_C_LOC
3046 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3048 /* Array intrinsics must also have the last upper bound of an
3049 assumed size array argument. UBOUND and SIZE have to be
3050 excluded from the check if the second argument is anything
3053 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3055 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3056 && arg
== expr
->value
.function
.actual
3057 && arg
->next
!= NULL
&& arg
->next
->expr
)
3059 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3062 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3065 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3070 if (arg
->expr
!= NULL
3071 && arg
->expr
->rank
> 0
3072 && resolve_assumed_size_actual (arg
->expr
))
3078 need_full_assumed_size
= temp
;
3080 if (!check_pure_function(expr
))
3083 /* Functions without the RECURSIVE attribution are not allowed to
3084 * call themselves. */
3085 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3088 esym
= expr
->value
.function
.esym
;
3090 if (is_illegal_recursion (esym
, gfc_current_ns
))
3092 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3093 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3094 " function %qs is not RECURSIVE",
3095 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3097 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3098 " is not RECURSIVE", esym
->name
, &expr
->where
);
3104 /* Character lengths of use associated functions may contains references to
3105 symbols not referenced from the current program unit otherwise. Make sure
3106 those symbols are marked as referenced. */
3108 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3109 && expr
->value
.function
.esym
->attr
.use_assoc
)
3111 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3114 /* Make sure that the expression has a typespec that works. */
3115 if (expr
->ts
.type
== BT_UNKNOWN
)
3117 if (expr
->symtree
->n
.sym
->result
3118 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3119 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3120 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3123 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3125 if (expr
->value
.function
.esym
)
3126 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3128 update_current_proc_array_outer_dependency (sym
);
3131 /* typebound procedure: Assume the worst. */
3132 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3138 /************* Subroutine resolution *************/
3141 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3148 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3152 else if (gfc_do_concurrent_flag
)
3154 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3158 else if (gfc_pure (NULL
))
3160 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3164 gfc_unset_implicit_pure (NULL
);
3170 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3174 if (sym
->attr
.generic
)
3176 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3179 c
->resolved_sym
= s
;
3180 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3185 /* TODO: Need to search for elemental references in generic interface. */
3188 if (sym
->attr
.intrinsic
)
3189 return gfc_intrinsic_sub_interface (c
, 0);
3196 resolve_generic_s (gfc_code
*c
)
3201 sym
= c
->symtree
->n
.sym
;
3205 m
= resolve_generic_s0 (c
, sym
);
3208 else if (m
== MATCH_ERROR
)
3212 if (sym
->ns
->parent
== NULL
)
3214 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3218 if (!generic_sym (sym
))
3222 /* Last ditch attempt. See if the reference is to an intrinsic
3223 that possesses a matching interface. 14.1.2.4 */
3224 sym
= c
->symtree
->n
.sym
;
3226 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3228 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3229 sym
->name
, &c
->loc
);
3233 m
= gfc_intrinsic_sub_interface (c
, 0);
3237 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3238 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3244 /* Resolve a subroutine call known to be specific. */
3247 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3251 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3253 if (sym
->attr
.dummy
)
3255 sym
->attr
.proc
= PROC_DUMMY
;
3259 sym
->attr
.proc
= PROC_EXTERNAL
;
3263 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3266 if (sym
->attr
.intrinsic
)
3268 m
= gfc_intrinsic_sub_interface (c
, 1);
3272 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3273 "with an intrinsic", sym
->name
, &c
->loc
);
3281 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3283 c
->resolved_sym
= sym
;
3284 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3292 resolve_specific_s (gfc_code
*c
)
3297 sym
= c
->symtree
->n
.sym
;
3301 m
= resolve_specific_s0 (c
, sym
);
3304 if (m
== MATCH_ERROR
)
3307 if (sym
->ns
->parent
== NULL
)
3310 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3316 sym
= c
->symtree
->n
.sym
;
3317 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3318 sym
->name
, &c
->loc
);
3324 /* Resolve a subroutine call not known to be generic nor specific. */
3327 resolve_unknown_s (gfc_code
*c
)
3331 sym
= c
->symtree
->n
.sym
;
3333 if (sym
->attr
.dummy
)
3335 sym
->attr
.proc
= PROC_DUMMY
;
3339 /* See if we have an intrinsic function reference. */
3341 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3343 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3348 /* The reference is to an external name. */
3351 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3353 c
->resolved_sym
= sym
;
3355 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3359 /* Resolve a subroutine call. Although it was tempting to use the same code
3360 for functions, subroutines and functions are stored differently and this
3361 makes things awkward. */
3364 resolve_call (gfc_code
*c
)
3367 procedure_type ptype
= PROC_INTRINSIC
;
3368 gfc_symbol
*csym
, *sym
;
3369 bool no_formal_args
;
3371 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3373 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3375 gfc_error ("%qs at %L has a type, which is not consistent with "
3376 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3380 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3383 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3384 sym
= st
? st
->n
.sym
: NULL
;
3385 if (sym
&& csym
!= sym
3386 && sym
->ns
== gfc_current_ns
3387 && sym
->attr
.flavor
== FL_PROCEDURE
3388 && sym
->attr
.contained
)
3391 if (csym
->attr
.generic
)
3392 c
->symtree
->n
.sym
= sym
;
3395 csym
= c
->symtree
->n
.sym
;
3399 /* If this ia a deferred TBP, c->expr1 will be set. */
3400 if (!c
->expr1
&& csym
)
3402 if (csym
->attr
.abstract
)
3404 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3405 csym
->name
, &c
->loc
);
3409 /* Subroutines without the RECURSIVE attribution are not allowed to
3411 if (is_illegal_recursion (csym
, gfc_current_ns
))
3413 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3414 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3415 "as subroutine %qs is not RECURSIVE",
3416 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3418 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3419 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3425 /* Switch off assumed size checking and do this again for certain kinds
3426 of procedure, once the procedure itself is resolved. */
3427 need_full_assumed_size
++;
3430 ptype
= csym
->attr
.proc
;
3432 no_formal_args
= csym
&& is_external_proc (csym
)
3433 && gfc_sym_get_dummy_args (csym
) == NULL
;
3434 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3437 /* Resume assumed_size checking. */
3438 need_full_assumed_size
--;
3440 /* If external, check for usage. */
3441 if (csym
&& is_external_proc (csym
))
3442 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3445 if (c
->resolved_sym
== NULL
)
3447 c
->resolved_isym
= NULL
;
3448 switch (procedure_kind (csym
))
3451 t
= resolve_generic_s (c
);
3454 case PTYPE_SPECIFIC
:
3455 t
= resolve_specific_s (c
);
3459 t
= resolve_unknown_s (c
);
3463 gfc_internal_error ("resolve_subroutine(): bad function type");
3467 /* Some checks of elemental subroutine actual arguments. */
3468 if (!resolve_elemental_actual (NULL
, c
))
3472 update_current_proc_array_outer_dependency (csym
);
3474 /* Typebound procedure: Assume the worst. */
3475 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3481 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3482 op1->shape and op2->shape are non-NULL return true if their shapes
3483 match. If both op1->shape and op2->shape are non-NULL return false
3484 if their shapes do not match. If either op1->shape or op2->shape is
3485 NULL, return true. */
3488 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3495 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3497 for (i
= 0; i
< op1
->rank
; i
++)
3499 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3501 gfc_error ("Shapes for operands at %L and %L are not conformable",
3502 &op1
->where
, &op2
->where
);
3513 /* Resolve an operator expression node. This can involve replacing the
3514 operation with a user defined function call. */
3517 resolve_operator (gfc_expr
*e
)
3519 gfc_expr
*op1
, *op2
;
3521 bool dual_locus_error
;
3524 /* Resolve all subnodes-- give them types. */
3526 switch (e
->value
.op
.op
)
3529 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3532 /* Fall through... */
3535 case INTRINSIC_UPLUS
:
3536 case INTRINSIC_UMINUS
:
3537 case INTRINSIC_PARENTHESES
:
3538 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3543 /* Typecheck the new node. */
3545 op1
= e
->value
.op
.op1
;
3546 op2
= e
->value
.op
.op2
;
3547 dual_locus_error
= false;
3549 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3550 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3552 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3556 switch (e
->value
.op
.op
)
3558 case INTRINSIC_UPLUS
:
3559 case INTRINSIC_UMINUS
:
3560 if (op1
->ts
.type
== BT_INTEGER
3561 || op1
->ts
.type
== BT_REAL
3562 || op1
->ts
.type
== BT_COMPLEX
)
3568 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3569 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3572 case INTRINSIC_PLUS
:
3573 case INTRINSIC_MINUS
:
3574 case INTRINSIC_TIMES
:
3575 case INTRINSIC_DIVIDE
:
3576 case INTRINSIC_POWER
:
3577 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3579 gfc_type_convert_binary (e
, 1);
3584 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3585 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3586 gfc_typename (&op2
->ts
));
3589 case INTRINSIC_CONCAT
:
3590 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3591 && op1
->ts
.kind
== op2
->ts
.kind
)
3593 e
->ts
.type
= BT_CHARACTER
;
3594 e
->ts
.kind
= op1
->ts
.kind
;
3599 _("Operands of string concatenation operator at %%L are %s/%s"),
3600 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3606 case INTRINSIC_NEQV
:
3607 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3609 e
->ts
.type
= BT_LOGICAL
;
3610 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3611 if (op1
->ts
.kind
< e
->ts
.kind
)
3612 gfc_convert_type (op1
, &e
->ts
, 2);
3613 else if (op2
->ts
.kind
< e
->ts
.kind
)
3614 gfc_convert_type (op2
, &e
->ts
, 2);
3618 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3619 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3620 gfc_typename (&op2
->ts
));
3625 if (op1
->ts
.type
== BT_LOGICAL
)
3627 e
->ts
.type
= BT_LOGICAL
;
3628 e
->ts
.kind
= op1
->ts
.kind
;
3632 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3633 gfc_typename (&op1
->ts
));
3637 case INTRINSIC_GT_OS
:
3639 case INTRINSIC_GE_OS
:
3641 case INTRINSIC_LT_OS
:
3643 case INTRINSIC_LE_OS
:
3644 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3646 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3650 /* Fall through... */
3653 case INTRINSIC_EQ_OS
:
3655 case INTRINSIC_NE_OS
:
3656 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3657 && op1
->ts
.kind
== op2
->ts
.kind
)
3659 e
->ts
.type
= BT_LOGICAL
;
3660 e
->ts
.kind
= gfc_default_logical_kind
;
3664 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3666 gfc_type_convert_binary (e
, 1);
3668 e
->ts
.type
= BT_LOGICAL
;
3669 e
->ts
.kind
= gfc_default_logical_kind
;
3671 if (warn_compare_reals
)
3673 gfc_intrinsic_op op
= e
->value
.op
.op
;
3675 /* Type conversion has made sure that the types of op1 and op2
3676 agree, so it is only necessary to check the first one. */
3677 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3678 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3679 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3683 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3684 msg
= "Equality comparison for %s at %L";
3686 msg
= "Inequality comparison for %s at %L";
3688 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3695 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3697 _("Logicals at %%L must be compared with %s instead of %s"),
3698 (e
->value
.op
.op
== INTRINSIC_EQ
3699 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3700 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3703 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
3704 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3705 gfc_typename (&op2
->ts
));
3709 case INTRINSIC_USER
:
3710 if (e
->value
.op
.uop
->op
== NULL
)
3711 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"),
3712 e
->value
.op
.uop
->name
);
3713 else if (op2
== NULL
)
3714 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
3715 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3718 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
3719 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3720 gfc_typename (&op2
->ts
));
3721 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3726 case INTRINSIC_PARENTHESES
:
3728 if (e
->ts
.type
== BT_CHARACTER
)
3729 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3733 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3736 /* Deal with arrayness of an operand through an operator. */
3740 switch (e
->value
.op
.op
)
3742 case INTRINSIC_PLUS
:
3743 case INTRINSIC_MINUS
:
3744 case INTRINSIC_TIMES
:
3745 case INTRINSIC_DIVIDE
:
3746 case INTRINSIC_POWER
:
3747 case INTRINSIC_CONCAT
:
3751 case INTRINSIC_NEQV
:
3753 case INTRINSIC_EQ_OS
:
3755 case INTRINSIC_NE_OS
:
3757 case INTRINSIC_GT_OS
:
3759 case INTRINSIC_GE_OS
:
3761 case INTRINSIC_LT_OS
:
3763 case INTRINSIC_LE_OS
:
3765 if (op1
->rank
== 0 && op2
->rank
== 0)
3768 if (op1
->rank
== 0 && op2
->rank
!= 0)
3770 e
->rank
= op2
->rank
;
3772 if (e
->shape
== NULL
)
3773 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3776 if (op1
->rank
!= 0 && op2
->rank
== 0)
3778 e
->rank
= op1
->rank
;
3780 if (e
->shape
== NULL
)
3781 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3784 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3786 if (op1
->rank
== op2
->rank
)
3788 e
->rank
= op1
->rank
;
3789 if (e
->shape
== NULL
)
3791 t
= compare_shapes (op1
, op2
);
3795 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3800 /* Allow higher level expressions to work. */
3803 /* Try user-defined operators, and otherwise throw an error. */
3804 dual_locus_error
= true;
3806 _("Inconsistent ranks for operator at %%L and %%L"));
3813 case INTRINSIC_PARENTHESES
:
3815 case INTRINSIC_UPLUS
:
3816 case INTRINSIC_UMINUS
:
3817 /* Simply copy arrayness attribute */
3818 e
->rank
= op1
->rank
;
3820 if (e
->shape
== NULL
)
3821 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3829 /* Attempt to simplify the expression. */
3832 t
= gfc_simplify_expr (e
, 0);
3833 /* Some calls do not succeed in simplification and return false
3834 even though there is no error; e.g. variable references to
3835 PARAMETER arrays. */
3836 if (!gfc_is_constant_expr (e
))
3844 match m
= gfc_extend_expr (e
);
3847 if (m
== MATCH_ERROR
)
3851 if (dual_locus_error
)
3852 gfc_error (msg
, &op1
->where
, &op2
->where
);
3854 gfc_error (msg
, &e
->where
);
3860 /************** Array resolution subroutines **************/
3863 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
3865 /* Compare two integer expressions. */
3867 static compare_result
3868 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3872 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3873 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3876 /* If either of the types isn't INTEGER, we must have
3877 raised an error earlier. */
3879 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3882 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3892 /* Compare an integer expression with an integer. */
3894 static compare_result
3895 compare_bound_int (gfc_expr
*a
, int b
)
3899 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3902 if (a
->ts
.type
!= BT_INTEGER
)
3903 gfc_internal_error ("compare_bound_int(): Bad expression");
3905 i
= mpz_cmp_si (a
->value
.integer
, b
);
3915 /* Compare an integer expression with a mpz_t. */
3917 static compare_result
3918 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3922 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3925 if (a
->ts
.type
!= BT_INTEGER
)
3926 gfc_internal_error ("compare_bound_int(): Bad expression");
3928 i
= mpz_cmp (a
->value
.integer
, b
);
3938 /* Compute the last value of a sequence given by a triplet.
3939 Return 0 if it wasn't able to compute the last value, or if the
3940 sequence if empty, and 1 otherwise. */
3943 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3944 gfc_expr
*stride
, mpz_t last
)
3948 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3949 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3950 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3953 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3954 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3957 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3959 if (compare_bound (start
, end
) == CMP_GT
)
3961 mpz_set (last
, end
->value
.integer
);
3965 if (compare_bound_int (stride
, 0) == CMP_GT
)
3967 /* Stride is positive */
3968 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3973 /* Stride is negative */
3974 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3979 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3980 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3981 mpz_sub (last
, end
->value
.integer
, rem
);
3988 /* Compare a single dimension of an array reference to the array
3992 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3996 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3998 gcc_assert (ar
->stride
[i
] == NULL
);
3999 /* This implies [*] as [*:] and [*:3] are not possible. */
4000 if (ar
->start
[i
] == NULL
)
4002 gcc_assert (ar
->end
[i
] == NULL
);
4007 /* Given start, end and stride values, calculate the minimum and
4008 maximum referenced indexes. */
4010 switch (ar
->dimen_type
[i
])
4013 case DIMEN_THIS_IMAGE
:
4018 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4021 gfc_warning (0, "Array reference at %L is out of bounds "
4022 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4023 mpz_get_si (ar
->start
[i
]->value
.integer
),
4024 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4026 gfc_warning (0, "Array reference at %L is out of bounds "
4027 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4028 mpz_get_si (ar
->start
[i
]->value
.integer
),
4029 mpz_get_si (as
->lower
[i
]->value
.integer
),
4033 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4036 gfc_warning (0, "Array reference at %L is out of bounds "
4037 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4038 mpz_get_si (ar
->start
[i
]->value
.integer
),
4039 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4041 gfc_warning (0, "Array reference at %L is out of bounds "
4042 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4043 mpz_get_si (ar
->start
[i
]->value
.integer
),
4044 mpz_get_si (as
->upper
[i
]->value
.integer
),
4053 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4054 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4056 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4058 /* Check for zero stride, which is not allowed. */
4059 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4061 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4065 /* if start == len || (stride > 0 && start < len)
4066 || (stride < 0 && start > len),
4067 then the array section contains at least one element. In this
4068 case, there is an out-of-bounds access if
4069 (start < lower || start > upper). */
4070 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4071 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4072 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4073 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4074 && comp_start_end
== CMP_GT
))
4076 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4078 gfc_warning (0, "Lower array reference at %L is out of bounds "
4079 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4080 mpz_get_si (AR_START
->value
.integer
),
4081 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4084 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4086 gfc_warning (0, "Lower array reference at %L is out of bounds "
4087 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4088 mpz_get_si (AR_START
->value
.integer
),
4089 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4094 /* If we can compute the highest index of the array section,
4095 then it also has to be between lower and upper. */
4096 mpz_init (last_value
);
4097 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4100 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4102 gfc_warning (0, "Upper array reference at %L is out of bounds "
4103 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4104 mpz_get_si (last_value
),
4105 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4106 mpz_clear (last_value
);
4109 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4111 gfc_warning (0, "Upper array reference at %L is out of bounds "
4112 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4113 mpz_get_si (last_value
),
4114 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4115 mpz_clear (last_value
);
4119 mpz_clear (last_value
);
4127 gfc_internal_error ("check_dimension(): Bad array reference");
4134 /* Compare an array reference with an array specification. */
4137 compare_spec_to_ref (gfc_array_ref
*ar
)
4144 /* TODO: Full array sections are only allowed as actual parameters. */
4145 if (as
->type
== AS_ASSUMED_SIZE
4146 && (/*ar->type == AR_FULL
4147 ||*/ (ar
->type
== AR_SECTION
4148 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4150 gfc_error ("Rightmost upper bound of assumed size array section "
4151 "not specified at %L", &ar
->where
);
4155 if (ar
->type
== AR_FULL
)
4158 if (as
->rank
!= ar
->dimen
)
4160 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4161 &ar
->where
, ar
->dimen
, as
->rank
);
4165 /* ar->codimen == 0 is a local array. */
4166 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4168 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4169 &ar
->where
, ar
->codimen
, as
->corank
);
4173 for (i
= 0; i
< as
->rank
; i
++)
4174 if (!check_dimension (i
, ar
, as
))
4177 /* Local access has no coarray spec. */
4178 if (ar
->codimen
!= 0)
4179 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4181 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4182 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4184 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4185 i
+ 1 - as
->rank
, &ar
->where
);
4188 if (!check_dimension (i
, ar
, as
))
4196 /* Resolve one part of an array index. */
4199 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4200 int force_index_integer_kind
)
4207 if (!gfc_resolve_expr (index
))
4210 if (check_scalar
&& index
->rank
!= 0)
4212 gfc_error ("Array index at %L must be scalar", &index
->where
);
4216 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4218 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4219 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4223 if (index
->ts
.type
== BT_REAL
)
4224 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4228 if ((index
->ts
.kind
!= gfc_index_integer_kind
4229 && force_index_integer_kind
)
4230 || index
->ts
.type
!= BT_INTEGER
)
4233 ts
.type
= BT_INTEGER
;
4234 ts
.kind
= gfc_index_integer_kind
;
4236 gfc_convert_type_warn (index
, &ts
, 2, 0);
4242 /* Resolve one part of an array index. */
4245 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4247 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4250 /* Resolve a dim argument to an intrinsic function. */
4253 gfc_resolve_dim_arg (gfc_expr
*dim
)
4258 if (!gfc_resolve_expr (dim
))
4263 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4268 if (dim
->ts
.type
!= BT_INTEGER
)
4270 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4274 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4279 ts
.type
= BT_INTEGER
;
4280 ts
.kind
= gfc_index_integer_kind
;
4282 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4288 /* Given an expression that contains array references, update those array
4289 references to point to the right array specifications. While this is
4290 filled in during matching, this information is difficult to save and load
4291 in a module, so we take care of it here.
4293 The idea here is that the original array reference comes from the
4294 base symbol. We traverse the list of reference structures, setting
4295 the stored reference to references. Component references can
4296 provide an additional array specification. */
4299 find_array_spec (gfc_expr
*e
)
4305 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4306 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4308 as
= e
->symtree
->n
.sym
->as
;
4310 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4315 gfc_internal_error ("find_array_spec(): Missing spec");
4322 c
= ref
->u
.c
.component
;
4323 if (c
->attr
.dimension
)
4326 gfc_internal_error ("find_array_spec(): unused as(1)");
4337 gfc_internal_error ("find_array_spec(): unused as(2)");
4341 /* Resolve an array reference. */
4344 resolve_array_ref (gfc_array_ref
*ar
)
4346 int i
, check_scalar
;
4349 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4351 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4353 /* Do not force gfc_index_integer_kind for the start. We can
4354 do fine with any integer kind. This avoids temporary arrays
4355 created for indexing with a vector. */
4356 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4358 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4360 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4365 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4369 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4373 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4374 if (e
->expr_type
== EXPR_VARIABLE
4375 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4376 ar
->start
[i
] = gfc_get_parentheses (e
);
4380 gfc_error ("Array index at %L is an array of rank %d",
4381 &ar
->c_where
[i
], e
->rank
);
4385 /* Fill in the upper bound, which may be lower than the
4386 specified one for something like a(2:10:5), which is
4387 identical to a(2:7:5). Only relevant for strides not equal
4388 to one. Don't try a division by zero. */
4389 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4390 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4391 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4392 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4396 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4398 if (ar
->end
[i
] == NULL
)
4401 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4403 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4405 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4406 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4408 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4419 if (ar
->type
== AR_FULL
)
4421 if (ar
->as
->rank
== 0)
4422 ar
->type
= AR_ELEMENT
;
4424 /* Make sure array is the same as array(:,:), this way
4425 we don't need to special case all the time. */
4426 ar
->dimen
= ar
->as
->rank
;
4427 for (i
= 0; i
< ar
->dimen
; i
++)
4429 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4431 gcc_assert (ar
->start
[i
] == NULL
);
4432 gcc_assert (ar
->end
[i
] == NULL
);
4433 gcc_assert (ar
->stride
[i
] == NULL
);
4437 /* If the reference type is unknown, figure out what kind it is. */
4439 if (ar
->type
== AR_UNKNOWN
)
4441 ar
->type
= AR_ELEMENT
;
4442 for (i
= 0; i
< ar
->dimen
; i
++)
4443 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4444 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4446 ar
->type
= AR_SECTION
;
4451 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4454 if (ar
->as
->corank
&& ar
->codimen
== 0)
4457 ar
->codimen
= ar
->as
->corank
;
4458 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4459 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4467 resolve_substring (gfc_ref
*ref
)
4469 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4471 if (ref
->u
.ss
.start
!= NULL
)
4473 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4476 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4478 gfc_error ("Substring start index at %L must be of type INTEGER",
4479 &ref
->u
.ss
.start
->where
);
4483 if (ref
->u
.ss
.start
->rank
!= 0)
4485 gfc_error ("Substring start index at %L must be scalar",
4486 &ref
->u
.ss
.start
->where
);
4490 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4491 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4492 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4494 gfc_error ("Substring start index at %L is less than one",
4495 &ref
->u
.ss
.start
->where
);
4500 if (ref
->u
.ss
.end
!= NULL
)
4502 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4505 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4507 gfc_error ("Substring end index at %L must be of type INTEGER",
4508 &ref
->u
.ss
.end
->where
);
4512 if (ref
->u
.ss
.end
->rank
!= 0)
4514 gfc_error ("Substring end index at %L must be scalar",
4515 &ref
->u
.ss
.end
->where
);
4519 if (ref
->u
.ss
.length
!= NULL
4520 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4521 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4522 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4524 gfc_error ("Substring end index at %L exceeds the string length",
4525 &ref
->u
.ss
.start
->where
);
4529 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4530 gfc_integer_kinds
[k
].huge
) == CMP_GT
4531 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4532 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4534 gfc_error ("Substring end index at %L is too large",
4535 &ref
->u
.ss
.end
->where
);
4544 /* This function supplies missing substring charlens. */
4547 gfc_resolve_substring_charlen (gfc_expr
*e
)
4550 gfc_expr
*start
, *end
;
4551 gfc_typespec
*ts
= NULL
;
4553 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4555 if (char_ref
->type
== REF_SUBSTRING
)
4557 if (char_ref
->type
== REF_COMPONENT
)
4558 ts
= &char_ref
->u
.c
.component
->ts
;
4564 gcc_assert (char_ref
->next
== NULL
);
4568 if (e
->ts
.u
.cl
->length
)
4569 gfc_free_expr (e
->ts
.u
.cl
->length
);
4570 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4574 e
->ts
.type
= BT_CHARACTER
;
4575 e
->ts
.kind
= gfc_default_character_kind
;
4578 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4580 if (char_ref
->u
.ss
.start
)
4581 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4583 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4585 if (char_ref
->u
.ss
.end
)
4586 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4587 else if (e
->expr_type
== EXPR_VARIABLE
)
4590 ts
= &e
->symtree
->n
.sym
->ts
;
4591 end
= gfc_copy_expr (ts
->u
.cl
->length
);
4598 gfc_free_expr (start
);
4599 gfc_free_expr (end
);
4603 /* Length = (end - start + 1). */
4604 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4605 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4606 gfc_get_int_expr (gfc_default_integer_kind
,
4609 /* F2008, 6.4.1: Both the starting point and the ending point shall
4610 be within the range 1, 2, ..., n unless the starting point exceeds
4611 the ending point, in which case the substring has length zero. */
4613 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
4614 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
4616 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4617 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4619 /* Make sure that the length is simplified. */
4620 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4621 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4625 /* Resolve subtype references. */
4628 resolve_ref (gfc_expr
*expr
)
4630 int current_part_dimension
, n_components
, seen_part_dimension
;
4633 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4634 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4636 find_array_spec (expr
);
4640 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4644 if (!resolve_array_ref (&ref
->u
.ar
))
4652 if (!resolve_substring (ref
))
4657 /* Check constraints on part references. */
4659 current_part_dimension
= 0;
4660 seen_part_dimension
= 0;
4663 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4668 switch (ref
->u
.ar
.type
)
4671 /* Coarray scalar. */
4672 if (ref
->u
.ar
.as
->rank
== 0)
4674 current_part_dimension
= 0;
4679 current_part_dimension
= 1;
4683 current_part_dimension
= 0;
4687 gfc_internal_error ("resolve_ref(): Bad array reference");
4693 if (current_part_dimension
|| seen_part_dimension
)
4696 if (ref
->u
.c
.component
->attr
.pointer
4697 || ref
->u
.c
.component
->attr
.proc_pointer
4698 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4699 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4701 gfc_error ("Component to the right of a part reference "
4702 "with nonzero rank must not have the POINTER "
4703 "attribute at %L", &expr
->where
);
4706 else if (ref
->u
.c
.component
->attr
.allocatable
4707 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4708 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4711 gfc_error ("Component to the right of a part reference "
4712 "with nonzero rank must not have the ALLOCATABLE "
4713 "attribute at %L", &expr
->where
);
4725 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4726 || ref
->next
== NULL
)
4727 && current_part_dimension
4728 && seen_part_dimension
)
4730 gfc_error ("Two or more part references with nonzero rank must "
4731 "not be specified at %L", &expr
->where
);
4735 if (ref
->type
== REF_COMPONENT
)
4737 if (current_part_dimension
)
4738 seen_part_dimension
= 1;
4740 /* reset to make sure */
4741 current_part_dimension
= 0;
4749 /* Given an expression, determine its shape. This is easier than it sounds.
4750 Leaves the shape array NULL if it is not possible to determine the shape. */
4753 expression_shape (gfc_expr
*e
)
4755 mpz_t array
[GFC_MAX_DIMENSIONS
];
4758 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4761 for (i
= 0; i
< e
->rank
; i
++)
4762 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4765 e
->shape
= gfc_get_shape (e
->rank
);
4767 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4772 for (i
--; i
>= 0; i
--)
4773 mpz_clear (array
[i
]);
4777 /* Given a variable expression node, compute the rank of the expression by
4778 examining the base symbol and any reference structures it may have. */
4781 expression_rank (gfc_expr
*e
)
4786 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4787 could lead to serious confusion... */
4788 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4792 if (e
->expr_type
== EXPR_ARRAY
)
4794 /* Constructors can have a rank different from one via RESHAPE(). */
4796 if (e
->symtree
== NULL
)
4802 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4803 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4809 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4811 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4812 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4813 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4815 if (ref
->type
!= REF_ARRAY
)
4818 if (ref
->u
.ar
.type
== AR_FULL
)
4820 rank
= ref
->u
.ar
.as
->rank
;
4824 if (ref
->u
.ar
.type
== AR_SECTION
)
4826 /* Figure out the rank of the section. */
4828 gfc_internal_error ("expression_rank(): Two array specs");
4830 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4831 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4832 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4842 expression_shape (e
);
4847 add_caf_get_intrinsic (gfc_expr
*e
)
4849 gfc_expr
*wrapper
, *tmp_expr
;
4853 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4854 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4859 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4860 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4863 tmp_expr
= XCNEW (gfc_expr
);
4865 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4866 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4867 wrapper
->ts
= e
->ts
;
4868 wrapper
->rank
= e
->rank
;
4870 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4877 remove_caf_get_intrinsic (gfc_expr
*e
)
4879 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4880 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4881 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4882 e
->value
.function
.actual
->expr
= NULL
;
4883 gfc_free_actual_arglist (e
->value
.function
.actual
);
4884 gfc_free_shape (&e
->shape
, e
->rank
);
4890 /* Resolve a variable expression. */
4893 resolve_variable (gfc_expr
*e
)
4900 if (e
->symtree
== NULL
)
4902 sym
= e
->symtree
->n
.sym
;
4904 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4905 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4906 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4908 if (!actual_arg
|| inquiry_argument
)
4910 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4911 "be used as actual argument", sym
->name
, &e
->where
);
4915 /* TS 29113, 407b. */
4916 else if (e
->ts
.type
== BT_ASSUMED
)
4920 gfc_error ("Assumed-type variable %s at %L may only be used "
4921 "as actual argument", sym
->name
, &e
->where
);
4924 else if (inquiry_argument
&& !first_actual_arg
)
4926 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4927 for all inquiry functions in resolve_function; the reason is
4928 that the function-name resolution happens too late in that
4930 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4931 "an inquiry function shall be the first argument",
4932 sym
->name
, &e
->where
);
4936 /* TS 29113, C535b. */
4937 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4938 && CLASS_DATA (sym
)->as
4939 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4940 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4941 && sym
->as
->type
== AS_ASSUMED_RANK
))
4945 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4946 "actual argument", sym
->name
, &e
->where
);
4949 else if (inquiry_argument
&& !first_actual_arg
)
4951 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4952 for all inquiry functions in resolve_function; the reason is
4953 that the function-name resolution happens too late in that
4955 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4956 "to an inquiry function shall be the first argument",
4957 sym
->name
, &e
->where
);
4962 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4963 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4964 && e
->ref
->next
== NULL
))
4966 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4967 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4970 /* TS 29113, 407b. */
4971 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4972 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4973 && e
->ref
->next
== NULL
))
4975 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4976 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4980 /* TS 29113, C535b. */
4981 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4982 && CLASS_DATA (sym
)->as
4983 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4984 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4985 && sym
->as
->type
== AS_ASSUMED_RANK
))
4987 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4988 && e
->ref
->next
== NULL
))
4990 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4991 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4995 /* For variables that are used in an associate (target => object) where
4996 the object's basetype is array valued while the target is scalar,
4997 the ts' type of the component refs is still array valued, which
4998 can't be translated that way. */
4999 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5000 && sym
->assoc
->target
->ts
.type
== BT_CLASS
5001 && CLASS_DATA (sym
->assoc
->target
)->as
)
5003 gfc_ref
*ref
= e
->ref
;
5009 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5010 /* Stop the loop. */
5020 /* If this is an associate-name, it may be parsed with an array reference
5021 in error even though the target is scalar. Fail directly in this case.
5022 TODO Understand why class scalar expressions must be excluded. */
5023 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5025 if (sym
->ts
.type
== BT_CLASS
)
5026 gfc_fix_class_refs (e
);
5027 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5031 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5032 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5034 /* On the other hand, the parser may not have known this is an array;
5035 in this case, we have to add a FULL reference. */
5036 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5038 e
->ref
= gfc_get_ref ();
5039 e
->ref
->type
= REF_ARRAY
;
5040 e
->ref
->u
.ar
.type
= AR_FULL
;
5041 e
->ref
->u
.ar
.dimen
= 0;
5044 /* Like above, but for class types, where the checking whether an array
5045 ref is present is more complicated. Furthermore make sure not to add
5046 the full array ref to _vptr or _len refs. */
5047 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5048 && CLASS_DATA (sym
)->attr
.dimension
5049 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5051 gfc_ref
*ref
, *newref
;
5053 newref
= gfc_get_ref ();
5054 newref
->type
= REF_ARRAY
;
5055 newref
->u
.ar
.type
= AR_FULL
;
5056 newref
->u
.ar
.dimen
= 0;
5057 /* Because this is an associate var and the first ref either is a ref to
5058 the _data component or not, no traversal of the ref chain is
5059 needed. The array ref needs to be inserted after the _data ref,
5060 or when that is not present, which may happend for polymorphic
5061 types, then at the first position. */
5065 else if (ref
->type
== REF_COMPONENT
5066 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5068 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5070 newref
->next
= ref
->next
;
5074 /* Array ref present already. */
5075 gfc_free_ref_list (newref
);
5077 else if (ref
->type
== REF_ARRAY
)
5078 /* Array ref present already. */
5079 gfc_free_ref_list (newref
);
5087 if (e
->ref
&& !resolve_ref (e
))
5090 if (sym
->attr
.flavor
== FL_PROCEDURE
5091 && (!sym
->attr
.function
5092 || (sym
->attr
.function
&& sym
->result
5093 && sym
->result
->attr
.proc_pointer
5094 && !sym
->result
->attr
.function
)))
5096 e
->ts
.type
= BT_PROCEDURE
;
5097 goto resolve_procedure
;
5100 if (sym
->ts
.type
!= BT_UNKNOWN
)
5101 gfc_variable_attr (e
, &e
->ts
);
5104 /* Must be a simple variable reference. */
5105 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5110 if (check_assumed_size_reference (sym
, e
))
5113 /* Deal with forward references to entries during gfc_resolve_code, to
5114 satisfy, at least partially, 12.5.2.5. */
5115 if (gfc_current_ns
->entries
5116 && current_entry_id
== sym
->entry_id
5119 && cs_base
->current
->op
!= EXEC_ENTRY
)
5121 gfc_entry_list
*entry
;
5122 gfc_formal_arglist
*formal
;
5124 bool seen
, saved_specification_expr
;
5126 /* If the symbol is a dummy... */
5127 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5129 entry
= gfc_current_ns
->entries
;
5132 /* ...test if the symbol is a parameter of previous entries. */
5133 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5134 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5136 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5143 /* If it has not been seen as a dummy, this is an error. */
5146 if (specification_expr
)
5147 gfc_error ("Variable %qs, used in a specification expression"
5148 ", is referenced at %L before the ENTRY statement "
5149 "in which it is a parameter",
5150 sym
->name
, &cs_base
->current
->loc
);
5152 gfc_error ("Variable %qs is used at %L before the ENTRY "
5153 "statement in which it is a parameter",
5154 sym
->name
, &cs_base
->current
->loc
);
5159 /* Now do the same check on the specification expressions. */
5160 saved_specification_expr
= specification_expr
;
5161 specification_expr
= true;
5162 if (sym
->ts
.type
== BT_CHARACTER
5163 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5167 for (n
= 0; n
< sym
->as
->rank
; n
++)
5169 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5171 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5174 specification_expr
= saved_specification_expr
;
5177 /* Update the symbol's entry level. */
5178 sym
->entry_id
= current_entry_id
+ 1;
5181 /* If a symbol has been host_associated mark it. This is used latter,
5182 to identify if aliasing is possible via host association. */
5183 if (sym
->attr
.flavor
== FL_VARIABLE
5184 && gfc_current_ns
->parent
5185 && (gfc_current_ns
->parent
== sym
->ns
5186 || (gfc_current_ns
->parent
->parent
5187 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5188 sym
->attr
.host_assoc
= 1;
5190 if (gfc_current_ns
->proc_name
5191 && sym
->attr
.dimension
5192 && (sym
->ns
!= gfc_current_ns
5193 || sym
->attr
.use_assoc
5194 || sym
->attr
.in_common
))
5195 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5198 if (t
&& !resolve_procedure_expression (e
))
5201 /* F2008, C617 and C1229. */
5202 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5203 && gfc_is_coindexed (e
))
5205 gfc_ref
*ref
, *ref2
= NULL
;
5207 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5209 if (ref
->type
== REF_COMPONENT
)
5211 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5215 for ( ; ref
; ref
= ref
->next
)
5216 if (ref
->type
== REF_COMPONENT
)
5219 /* Expression itself is not coindexed object. */
5220 if (ref
&& e
->ts
.type
== BT_CLASS
)
5222 gfc_error ("Polymorphic subobject of coindexed object at %L",
5227 /* Expression itself is coindexed object. */
5231 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5232 for ( ; c
; c
= c
->next
)
5233 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5235 gfc_error ("Coindexed object with polymorphic allocatable "
5236 "subcomponent at %L", &e
->where
);
5244 expression_rank (e
);
5246 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5247 add_caf_get_intrinsic (e
);
5253 /* Checks to see that the correct symbol has been host associated.
5254 The only situation where this arises is that in which a twice
5255 contained function is parsed after the host association is made.
5256 Therefore, on detecting this, change the symbol in the expression
5257 and convert the array reference into an actual arglist if the old
5258 symbol is a variable. */
5260 check_host_association (gfc_expr
*e
)
5262 gfc_symbol
*sym
, *old_sym
;
5266 gfc_actual_arglist
*arg
, *tail
= NULL
;
5267 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5269 /* If the expression is the result of substitution in
5270 interface.c(gfc_extend_expr) because there is no way in
5271 which the host association can be wrong. */
5272 if (e
->symtree
== NULL
5273 || e
->symtree
->n
.sym
== NULL
5274 || e
->user_operator
)
5277 old_sym
= e
->symtree
->n
.sym
;
5279 if (gfc_current_ns
->parent
5280 && old_sym
->ns
!= gfc_current_ns
)
5282 /* Use the 'USE' name so that renamed module symbols are
5283 correctly handled. */
5284 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5286 if (sym
&& old_sym
!= sym
5287 && sym
->ts
.type
== old_sym
->ts
.type
5288 && sym
->attr
.flavor
== FL_PROCEDURE
5289 && sym
->attr
.contained
)
5291 /* Clear the shape, since it might not be valid. */
5292 gfc_free_shape (&e
->shape
, e
->rank
);
5294 /* Give the expression the right symtree! */
5295 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5296 gcc_assert (st
!= NULL
);
5298 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5299 || e
->expr_type
== EXPR_FUNCTION
)
5301 /* Original was function so point to the new symbol, since
5302 the actual argument list is already attached to the
5304 e
->value
.function
.esym
= NULL
;
5309 /* Original was variable so convert array references into
5310 an actual arglist. This does not need any checking now
5311 since resolve_function will take care of it. */
5312 e
->value
.function
.actual
= NULL
;
5313 e
->expr_type
= EXPR_FUNCTION
;
5316 /* Ambiguity will not arise if the array reference is not
5317 the last reference. */
5318 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5319 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5322 gcc_assert (ref
->type
== REF_ARRAY
);
5324 /* Grab the start expressions from the array ref and
5325 copy them into actual arguments. */
5326 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5328 arg
= gfc_get_actual_arglist ();
5329 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5330 if (e
->value
.function
.actual
== NULL
)
5331 tail
= e
->value
.function
.actual
= arg
;
5339 /* Dump the reference list and set the rank. */
5340 gfc_free_ref_list (e
->ref
);
5342 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5345 gfc_resolve_expr (e
);
5349 /* This might have changed! */
5350 return e
->expr_type
== EXPR_FUNCTION
;
5355 gfc_resolve_character_operator (gfc_expr
*e
)
5357 gfc_expr
*op1
= e
->value
.op
.op1
;
5358 gfc_expr
*op2
= e
->value
.op
.op2
;
5359 gfc_expr
*e1
= NULL
;
5360 gfc_expr
*e2
= NULL
;
5362 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5364 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5365 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5366 else if (op1
->expr_type
== EXPR_CONSTANT
)
5367 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5368 op1
->value
.character
.length
);
5370 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5371 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5372 else if (op2
->expr_type
== EXPR_CONSTANT
)
5373 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5374 op2
->value
.character
.length
);
5376 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5386 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5387 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5388 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5389 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5390 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5396 /* Ensure that an character expression has a charlen and, if possible, a
5397 length expression. */
5400 fixup_charlen (gfc_expr
*e
)
5402 /* The cases fall through so that changes in expression type and the need
5403 for multiple fixes are picked up. In all circumstances, a charlen should
5404 be available for the middle end to hang a backend_decl on. */
5405 switch (e
->expr_type
)
5408 gfc_resolve_character_operator (e
);
5411 if (e
->expr_type
== EXPR_ARRAY
)
5412 gfc_resolve_character_array_constructor (e
);
5414 case EXPR_SUBSTRING
:
5415 if (!e
->ts
.u
.cl
&& e
->ref
)
5416 gfc_resolve_substring_charlen (e
);
5420 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5427 /* Update an actual argument to include the passed-object for type-bound
5428 procedures at the right position. */
5430 static gfc_actual_arglist
*
5431 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5434 gcc_assert (argpos
> 0);
5438 gfc_actual_arglist
* result
;
5440 result
= gfc_get_actual_arglist ();
5444 result
->name
= name
;
5450 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5452 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5457 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5460 extract_compcall_passed_object (gfc_expr
* e
)
5464 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5466 if (e
->value
.compcall
.base_object
)
5467 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5470 po
= gfc_get_expr ();
5471 po
->expr_type
= EXPR_VARIABLE
;
5472 po
->symtree
= e
->symtree
;
5473 po
->ref
= gfc_copy_ref (e
->ref
);
5474 po
->where
= e
->where
;
5477 if (!gfc_resolve_expr (po
))
5484 /* Update the arglist of an EXPR_COMPCALL expression to include the
5488 update_compcall_arglist (gfc_expr
* e
)
5491 gfc_typebound_proc
* tbp
;
5493 tbp
= e
->value
.compcall
.tbp
;
5498 po
= extract_compcall_passed_object (e
);
5502 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5508 gcc_assert (tbp
->pass_arg_num
> 0);
5509 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5517 /* Extract the passed object from a PPC call (a copy of it). */
5520 extract_ppc_passed_object (gfc_expr
*e
)
5525 po
= gfc_get_expr ();
5526 po
->expr_type
= EXPR_VARIABLE
;
5527 po
->symtree
= e
->symtree
;
5528 po
->ref
= gfc_copy_ref (e
->ref
);
5529 po
->where
= e
->where
;
5531 /* Remove PPC reference. */
5533 while ((*ref
)->next
)
5534 ref
= &(*ref
)->next
;
5535 gfc_free_ref_list (*ref
);
5538 if (!gfc_resolve_expr (po
))
5545 /* Update the actual arglist of a procedure pointer component to include the
5549 update_ppc_arglist (gfc_expr
* e
)
5553 gfc_typebound_proc
* tb
;
5555 ppc
= gfc_get_proc_ptr_comp (e
);
5563 else if (tb
->nopass
)
5566 po
= extract_ppc_passed_object (e
);
5573 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5578 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5580 gfc_error ("Base object for procedure-pointer component call at %L is of"
5581 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5585 gcc_assert (tb
->pass_arg_num
> 0);
5586 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5594 /* Check that the object a TBP is called on is valid, i.e. it must not be
5595 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5598 check_typebound_baseobject (gfc_expr
* e
)
5601 bool return_value
= false;
5603 base
= extract_compcall_passed_object (e
);
5607 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5609 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5613 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5615 gfc_error ("Base object for type-bound procedure call at %L is of"
5616 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5620 /* F08:C1230. If the procedure called is NOPASS,
5621 the base object must be scalar. */
5622 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5624 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5625 " be scalar", &e
->where
);
5629 return_value
= true;
5632 gfc_free_expr (base
);
5633 return return_value
;
5637 /* Resolve a call to a type-bound procedure, either function or subroutine,
5638 statically from the data in an EXPR_COMPCALL expression. The adapted
5639 arglist and the target-procedure symtree are returned. */
5642 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5643 gfc_actual_arglist
** actual
)
5645 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5646 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5648 /* Update the actual arglist for PASS. */
5649 if (!update_compcall_arglist (e
))
5652 *actual
= e
->value
.compcall
.actual
;
5653 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5655 gfc_free_ref_list (e
->ref
);
5657 e
->value
.compcall
.actual
= NULL
;
5659 /* If we find a deferred typebound procedure, check for derived types
5660 that an overriding typebound procedure has not been missed. */
5661 if (e
->value
.compcall
.name
5662 && !e
->value
.compcall
.tbp
->non_overridable
5663 && e
->value
.compcall
.base_object
5664 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5667 gfc_symbol
*derived
;
5669 /* Use the derived type of the base_object. */
5670 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5673 /* If necessary, go through the inheritance chain. */
5674 while (!st
&& derived
)
5676 /* Look for the typebound procedure 'name'. */
5677 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5678 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5679 e
->value
.compcall
.name
);
5681 derived
= gfc_get_derived_super_type (derived
);
5684 /* Now find the specific name in the derived type namespace. */
5685 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5686 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5687 derived
->ns
, 1, &st
);
5695 /* Get the ultimate declared type from an expression. In addition,
5696 return the last class/derived type reference and the copy of the
5697 reference list. If check_types is set true, derived types are
5698 identified as well as class references. */
5700 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5701 gfc_expr
*e
, bool check_types
)
5703 gfc_symbol
*declared
;
5710 *new_ref
= gfc_copy_ref (e
->ref
);
5712 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5714 if (ref
->type
!= REF_COMPONENT
)
5717 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5718 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5719 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5721 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5727 if (declared
== NULL
)
5728 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5734 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5735 which of the specific bindings (if any) matches the arglist and transform
5736 the expression into a call of that binding. */
5739 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5741 gfc_typebound_proc
* genproc
;
5742 const char* genname
;
5744 gfc_symbol
*derived
;
5746 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5747 genname
= e
->value
.compcall
.name
;
5748 genproc
= e
->value
.compcall
.tbp
;
5750 if (!genproc
->is_generic
)
5753 /* Try the bindings on this type and in the inheritance hierarchy. */
5754 for (; genproc
; genproc
= genproc
->overridden
)
5758 gcc_assert (genproc
->is_generic
);
5759 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5762 gfc_actual_arglist
* args
;
5765 gcc_assert (g
->specific
);
5767 if (g
->specific
->error
)
5770 target
= g
->specific
->u
.specific
->n
.sym
;
5772 /* Get the right arglist by handling PASS/NOPASS. */
5773 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5774 if (!g
->specific
->nopass
)
5777 po
= extract_compcall_passed_object (e
);
5780 gfc_free_actual_arglist (args
);
5784 gcc_assert (g
->specific
->pass_arg_num
> 0);
5785 gcc_assert (!g
->specific
->error
);
5786 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5787 g
->specific
->pass_arg
);
5789 resolve_actual_arglist (args
, target
->attr
.proc
,
5790 is_external_proc (target
)
5791 && gfc_sym_get_dummy_args (target
) == NULL
);
5793 /* Check if this arglist matches the formal. */
5794 matches
= gfc_arglist_matches_symbol (&args
, target
);
5796 /* Clean up and break out of the loop if we've found it. */
5797 gfc_free_actual_arglist (args
);
5800 e
->value
.compcall
.tbp
= g
->specific
;
5801 genname
= g
->specific_st
->name
;
5802 /* Pass along the name for CLASS methods, where the vtab
5803 procedure pointer component has to be referenced. */
5811 /* Nothing matching found! */
5812 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5813 " %qs at %L", genname
, &e
->where
);
5817 /* Make sure that we have the right specific instance for the name. */
5818 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5820 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5822 e
->value
.compcall
.tbp
= st
->n
.tb
;
5828 /* Resolve a call to a type-bound subroutine. */
5831 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5833 gfc_actual_arglist
* newactual
;
5834 gfc_symtree
* target
;
5836 /* Check that's really a SUBROUTINE. */
5837 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5839 gfc_error ("%qs at %L should be a SUBROUTINE",
5840 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5844 if (!check_typebound_baseobject (c
->expr1
))
5847 /* Pass along the name for CLASS methods, where the vtab
5848 procedure pointer component has to be referenced. */
5850 *name
= c
->expr1
->value
.compcall
.name
;
5852 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5855 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5857 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5859 /* Transform into an ordinary EXEC_CALL for now. */
5861 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5864 c
->ext
.actual
= newactual
;
5865 c
->symtree
= target
;
5866 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5868 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5870 gfc_free_expr (c
->expr1
);
5871 c
->expr1
= gfc_get_expr ();
5872 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5873 c
->expr1
->symtree
= target
;
5874 c
->expr1
->where
= c
->loc
;
5876 return resolve_call (c
);
5880 /* Resolve a component-call expression. */
5882 resolve_compcall (gfc_expr
* e
, const char **name
)
5884 gfc_actual_arglist
* newactual
;
5885 gfc_symtree
* target
;
5887 /* Check that's really a FUNCTION. */
5888 if (!e
->value
.compcall
.tbp
->function
)
5890 gfc_error ("%qs at %L should be a FUNCTION",
5891 e
->value
.compcall
.name
, &e
->where
);
5895 /* These must not be assign-calls! */
5896 gcc_assert (!e
->value
.compcall
.assign
);
5898 if (!check_typebound_baseobject (e
))
5901 /* Pass along the name for CLASS methods, where the vtab
5902 procedure pointer component has to be referenced. */
5904 *name
= e
->value
.compcall
.name
;
5906 if (!resolve_typebound_generic_call (e
, name
))
5908 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5910 /* Take the rank from the function's symbol. */
5911 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5912 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5914 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5915 arglist to the TBP's binding target. */
5917 if (!resolve_typebound_static (e
, &target
, &newactual
))
5920 e
->value
.function
.actual
= newactual
;
5921 e
->value
.function
.name
= NULL
;
5922 e
->value
.function
.esym
= target
->n
.sym
;
5923 e
->value
.function
.isym
= NULL
;
5924 e
->symtree
= target
;
5925 e
->ts
= target
->n
.sym
->ts
;
5926 e
->expr_type
= EXPR_FUNCTION
;
5928 /* Resolution is not necessary if this is a class subroutine; this
5929 function only has to identify the specific proc. Resolution of
5930 the call will be done next in resolve_typebound_call. */
5931 return gfc_resolve_expr (e
);
5935 static bool resolve_fl_derived (gfc_symbol
*sym
);
5938 /* Resolve a typebound function, or 'method'. First separate all
5939 the non-CLASS references by calling resolve_compcall directly. */
5942 resolve_typebound_function (gfc_expr
* e
)
5944 gfc_symbol
*declared
;
5956 /* Deal with typebound operators for CLASS objects. */
5957 expr
= e
->value
.compcall
.base_object
;
5958 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5959 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5961 /* If the base_object is not a variable, the corresponding actual
5962 argument expression must be stored in e->base_expression so
5963 that the corresponding tree temporary can be used as the base
5964 object in gfc_conv_procedure_call. */
5965 if (expr
->expr_type
!= EXPR_VARIABLE
)
5967 gfc_actual_arglist
*args
;
5969 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5971 if (expr
== args
->expr
)
5976 /* Since the typebound operators are generic, we have to ensure
5977 that any delays in resolution are corrected and that the vtab
5980 declared
= ts
.u
.derived
;
5981 c
= gfc_find_component (declared
, "_vptr", true, true);
5982 if (c
->ts
.u
.derived
== NULL
)
5983 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5985 if (!resolve_compcall (e
, &name
))
5988 /* Use the generic name if it is there. */
5989 name
= name
? name
: e
->value
.function
.esym
->name
;
5990 e
->symtree
= expr
->symtree
;
5991 e
->ref
= gfc_copy_ref (expr
->ref
);
5992 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5994 /* Trim away the extraneous references that emerge from nested
5995 use of interface.c (extend_expr). */
5996 if (class_ref
&& class_ref
->next
)
5998 gfc_free_ref_list (class_ref
->next
);
5999 class_ref
->next
= NULL
;
6001 else if (e
->ref
&& !class_ref
)
6003 gfc_free_ref_list (e
->ref
);
6007 gfc_add_vptr_component (e
);
6008 gfc_add_component_ref (e
, name
);
6009 e
->value
.function
.esym
= NULL
;
6010 if (expr
->expr_type
!= EXPR_VARIABLE
)
6011 e
->base_expr
= expr
;
6016 return resolve_compcall (e
, NULL
);
6018 if (!resolve_ref (e
))
6021 /* Get the CLASS declared type. */
6022 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6024 if (!resolve_fl_derived (declared
))
6027 /* Weed out cases of the ultimate component being a derived type. */
6028 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6029 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6031 gfc_free_ref_list (new_ref
);
6032 return resolve_compcall (e
, NULL
);
6035 c
= gfc_find_component (declared
, "_data", true, true);
6036 declared
= c
->ts
.u
.derived
;
6038 /* Treat the call as if it is a typebound procedure, in order to roll
6039 out the correct name for the specific function. */
6040 if (!resolve_compcall (e
, &name
))
6042 gfc_free_ref_list (new_ref
);
6049 /* Convert the expression to a procedure pointer component call. */
6050 e
->value
.function
.esym
= NULL
;
6056 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6057 gfc_add_vptr_component (e
);
6058 gfc_add_component_ref (e
, name
);
6060 /* Recover the typespec for the expression. This is really only
6061 necessary for generic procedures, where the additional call
6062 to gfc_add_component_ref seems to throw the collection of the
6063 correct typespec. */
6067 gfc_free_ref_list (new_ref
);
6072 /* Resolve a typebound subroutine, or 'method'. First separate all
6073 the non-CLASS references by calling resolve_typebound_call
6077 resolve_typebound_subroutine (gfc_code
*code
)
6079 gfc_symbol
*declared
;
6089 st
= code
->expr1
->symtree
;
6091 /* Deal with typebound operators for CLASS objects. */
6092 expr
= code
->expr1
->value
.compcall
.base_object
;
6093 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6094 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6096 /* If the base_object is not a variable, the corresponding actual
6097 argument expression must be stored in e->base_expression so
6098 that the corresponding tree temporary can be used as the base
6099 object in gfc_conv_procedure_call. */
6100 if (expr
->expr_type
!= EXPR_VARIABLE
)
6102 gfc_actual_arglist
*args
;
6104 args
= code
->expr1
->value
.function
.actual
;
6105 for (; args
; args
= args
->next
)
6106 if (expr
== args
->expr
)
6110 /* Since the typebound operators are generic, we have to ensure
6111 that any delays in resolution are corrected and that the vtab
6113 declared
= expr
->ts
.u
.derived
;
6114 c
= gfc_find_component (declared
, "_vptr", true, true);
6115 if (c
->ts
.u
.derived
== NULL
)
6116 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6118 if (!resolve_typebound_call (code
, &name
, NULL
))
6121 /* Use the generic name if it is there. */
6122 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6123 code
->expr1
->symtree
= expr
->symtree
;
6124 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6126 /* Trim away the extraneous references that emerge from nested
6127 use of interface.c (extend_expr). */
6128 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6129 if (class_ref
&& class_ref
->next
)
6131 gfc_free_ref_list (class_ref
->next
);
6132 class_ref
->next
= NULL
;
6134 else if (code
->expr1
->ref
&& !class_ref
)
6136 gfc_free_ref_list (code
->expr1
->ref
);
6137 code
->expr1
->ref
= NULL
;
6140 /* Now use the procedure in the vtable. */
6141 gfc_add_vptr_component (code
->expr1
);
6142 gfc_add_component_ref (code
->expr1
, name
);
6143 code
->expr1
->value
.function
.esym
= NULL
;
6144 if (expr
->expr_type
!= EXPR_VARIABLE
)
6145 code
->expr1
->base_expr
= expr
;
6150 return resolve_typebound_call (code
, NULL
, NULL
);
6152 if (!resolve_ref (code
->expr1
))
6155 /* Get the CLASS declared type. */
6156 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6158 /* Weed out cases of the ultimate component being a derived type. */
6159 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6160 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6162 gfc_free_ref_list (new_ref
);
6163 return resolve_typebound_call (code
, NULL
, NULL
);
6166 if (!resolve_typebound_call (code
, &name
, &overridable
))
6168 gfc_free_ref_list (new_ref
);
6171 ts
= code
->expr1
->ts
;
6175 /* Convert the expression to a procedure pointer component call. */
6176 code
->expr1
->value
.function
.esym
= NULL
;
6177 code
->expr1
->symtree
= st
;
6180 code
->expr1
->ref
= new_ref
;
6182 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6183 gfc_add_vptr_component (code
->expr1
);
6184 gfc_add_component_ref (code
->expr1
, name
);
6186 /* Recover the typespec for the expression. This is really only
6187 necessary for generic procedures, where the additional call
6188 to gfc_add_component_ref seems to throw the collection of the
6189 correct typespec. */
6190 code
->expr1
->ts
= ts
;
6193 gfc_free_ref_list (new_ref
);
6199 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6202 resolve_ppc_call (gfc_code
* c
)
6204 gfc_component
*comp
;
6206 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6207 gcc_assert (comp
!= NULL
);
6209 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6210 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6212 if (!comp
->attr
.subroutine
)
6213 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6215 if (!resolve_ref (c
->expr1
))
6218 if (!update_ppc_arglist (c
->expr1
))
6221 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6223 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6224 !(comp
->ts
.interface
6225 && comp
->ts
.interface
->formal
)))
6228 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6231 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6237 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6240 resolve_expr_ppc (gfc_expr
* e
)
6242 gfc_component
*comp
;
6244 comp
= gfc_get_proc_ptr_comp (e
);
6245 gcc_assert (comp
!= NULL
);
6247 /* Convert to EXPR_FUNCTION. */
6248 e
->expr_type
= EXPR_FUNCTION
;
6249 e
->value
.function
.isym
= NULL
;
6250 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6252 if (comp
->as
!= NULL
)
6253 e
->rank
= comp
->as
->rank
;
6255 if (!comp
->attr
.function
)
6256 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6258 if (!resolve_ref (e
))
6261 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6262 !(comp
->ts
.interface
6263 && comp
->ts
.interface
->formal
)))
6266 if (!update_ppc_arglist (e
))
6269 if (!check_pure_function(e
))
6272 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6279 gfc_is_expandable_expr (gfc_expr
*e
)
6281 gfc_constructor
*con
;
6283 if (e
->expr_type
== EXPR_ARRAY
)
6285 /* Traverse the constructor looking for variables that are flavor
6286 parameter. Parameters must be expanded since they are fully used at
6288 con
= gfc_constructor_first (e
->value
.constructor
);
6289 for (; con
; con
= gfc_constructor_next (con
))
6291 if (con
->expr
->expr_type
== EXPR_VARIABLE
6292 && con
->expr
->symtree
6293 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6294 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6296 if (con
->expr
->expr_type
== EXPR_ARRAY
6297 && gfc_is_expandable_expr (con
->expr
))
6305 /* Resolve an expression. That is, make sure that types of operands agree
6306 with their operators, intrinsic operators are converted to function calls
6307 for overloaded types and unresolved function references are resolved. */
6310 gfc_resolve_expr (gfc_expr
*e
)
6313 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6318 /* inquiry_argument only applies to variables. */
6319 inquiry_save
= inquiry_argument
;
6320 actual_arg_save
= actual_arg
;
6321 first_actual_arg_save
= first_actual_arg
;
6323 if (e
->expr_type
!= EXPR_VARIABLE
)
6325 inquiry_argument
= false;
6327 first_actual_arg
= false;
6330 switch (e
->expr_type
)
6333 t
= resolve_operator (e
);
6339 if (check_host_association (e
))
6340 t
= resolve_function (e
);
6342 t
= resolve_variable (e
);
6344 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6345 && e
->ref
->type
!= REF_SUBSTRING
)
6346 gfc_resolve_substring_charlen (e
);
6351 t
= resolve_typebound_function (e
);
6354 case EXPR_SUBSTRING
:
6355 t
= resolve_ref (e
);
6364 t
= resolve_expr_ppc (e
);
6369 if (!resolve_ref (e
))
6372 t
= gfc_resolve_array_constructor (e
);
6373 /* Also try to expand a constructor. */
6376 expression_rank (e
);
6377 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6378 gfc_expand_constructor (e
, false);
6381 /* This provides the opportunity for the length of constructors with
6382 character valued function elements to propagate the string length
6383 to the expression. */
6384 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6386 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6387 here rather then add a duplicate test for it above. */
6388 gfc_expand_constructor (e
, false);
6389 t
= gfc_resolve_character_array_constructor (e
);
6394 case EXPR_STRUCTURE
:
6395 t
= resolve_ref (e
);
6399 t
= resolve_structure_cons (e
, 0);
6403 t
= gfc_simplify_expr (e
, 0);
6407 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6410 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6413 inquiry_argument
= inquiry_save
;
6414 actual_arg
= actual_arg_save
;
6415 first_actual_arg
= first_actual_arg_save
;
6421 /* Resolve an expression from an iterator. They must be scalar and have
6422 INTEGER or (optionally) REAL type. */
6425 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6426 const char *name_msgid
)
6428 if (!gfc_resolve_expr (expr
))
6431 if (expr
->rank
!= 0)
6433 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6437 if (expr
->ts
.type
!= BT_INTEGER
)
6439 if (expr
->ts
.type
== BT_REAL
)
6442 return gfc_notify_std (GFC_STD_F95_DEL
,
6443 "%s at %L must be integer",
6444 _(name_msgid
), &expr
->where
);
6447 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6454 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6462 /* Resolve the expressions in an iterator structure. If REAL_OK is
6463 false allow only INTEGER type iterators, otherwise allow REAL types.
6464 Set own_scope to true for ac-implied-do and data-implied-do as those
6465 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6468 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6470 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6473 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6474 _("iterator variable")))
6477 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6478 "Start expression in DO loop"))
6481 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6482 "End expression in DO loop"))
6485 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6486 "Step expression in DO loop"))
6489 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6491 if ((iter
->step
->ts
.type
== BT_INTEGER
6492 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6493 || (iter
->step
->ts
.type
== BT_REAL
6494 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6496 gfc_error ("Step expression in DO loop at %L cannot be zero",
6497 &iter
->step
->where
);
6502 /* Convert start, end, and step to the same type as var. */
6503 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6504 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6505 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6507 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6508 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6509 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6511 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6512 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6513 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6515 if (iter
->start
->expr_type
== EXPR_CONSTANT
6516 && iter
->end
->expr_type
== EXPR_CONSTANT
6517 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6520 if (iter
->start
->ts
.type
== BT_INTEGER
)
6522 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6523 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6527 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6528 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6530 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6531 gfc_warning (OPT_Wzerotrip
,
6532 "DO loop at %L will be executed zero times",
6533 &iter
->step
->where
);
6540 /* Traversal function for find_forall_index. f == 2 signals that
6541 that variable itself is not to be checked - only the references. */
6544 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6546 if (expr
->expr_type
!= EXPR_VARIABLE
)
6549 /* A scalar assignment */
6550 if (!expr
->ref
|| *f
== 1)
6552 if (expr
->symtree
->n
.sym
== sym
)
6564 /* Check whether the FORALL index appears in the expression or not.
6565 Returns true if SYM is found in EXPR. */
6568 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6570 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6577 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6578 to be a scalar INTEGER variable. The subscripts and stride are scalar
6579 INTEGERs, and if stride is a constant it must be nonzero.
6580 Furthermore "A subscript or stride in a forall-triplet-spec shall
6581 not contain a reference to any index-name in the
6582 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6585 resolve_forall_iterators (gfc_forall_iterator
*it
)
6587 gfc_forall_iterator
*iter
, *iter2
;
6589 for (iter
= it
; iter
; iter
= iter
->next
)
6591 if (gfc_resolve_expr (iter
->var
)
6592 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6593 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6596 if (gfc_resolve_expr (iter
->start
)
6597 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6598 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6599 &iter
->start
->where
);
6600 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6601 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6603 if (gfc_resolve_expr (iter
->end
)
6604 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6605 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6607 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6608 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6610 if (gfc_resolve_expr (iter
->stride
))
6612 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6613 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6614 &iter
->stride
->where
, "INTEGER");
6616 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6617 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6618 gfc_error ("FORALL stride expression at %L cannot be zero",
6619 &iter
->stride
->where
);
6621 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6622 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6625 for (iter
= it
; iter
; iter
= iter
->next
)
6626 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6628 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6629 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6630 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6631 gfc_error ("FORALL index %qs may not appear in triplet "
6632 "specification at %L", iter
->var
->symtree
->name
,
6633 &iter2
->start
->where
);
6638 /* Given a pointer to a symbol that is a derived type, see if it's
6639 inaccessible, i.e. if it's defined in another module and the components are
6640 PRIVATE. The search is recursive if necessary. Returns zero if no
6641 inaccessible components are found, nonzero otherwise. */
6644 derived_inaccessible (gfc_symbol
*sym
)
6648 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6651 for (c
= sym
->components
; c
; c
= c
->next
)
6653 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6661 /* Resolve the argument of a deallocate expression. The expression must be
6662 a pointer or a full array. */
6665 resolve_deallocate_expr (gfc_expr
*e
)
6667 symbol_attribute attr
;
6668 int allocatable
, pointer
;
6674 if (!gfc_resolve_expr (e
))
6677 if (e
->expr_type
!= EXPR_VARIABLE
)
6680 sym
= e
->symtree
->n
.sym
;
6681 unlimited
= UNLIMITED_POLY(sym
);
6683 if (sym
->ts
.type
== BT_CLASS
)
6685 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6686 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6690 allocatable
= sym
->attr
.allocatable
;
6691 pointer
= sym
->attr
.pointer
;
6693 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6698 if (ref
->u
.ar
.type
!= AR_FULL
6699 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6700 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6705 c
= ref
->u
.c
.component
;
6706 if (c
->ts
.type
== BT_CLASS
)
6708 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6709 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6713 allocatable
= c
->attr
.allocatable
;
6714 pointer
= c
->attr
.pointer
;
6724 attr
= gfc_expr_attr (e
);
6726 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6729 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6735 if (gfc_is_coindexed (e
))
6737 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6742 && !gfc_check_vardef_context (e
, true, true, false,
6743 _("DEALLOCATE object")))
6745 if (!gfc_check_vardef_context (e
, false, true, false,
6746 _("DEALLOCATE object")))
6753 /* Returns true if the expression e contains a reference to the symbol sym. */
6755 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6757 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6764 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6766 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6770 /* Given the expression node e for an allocatable/pointer of derived type to be
6771 allocated, get the expression node to be initialized afterwards (needed for
6772 derived types with default initializers, and derived types with allocatable
6773 components that need nullification.) */
6776 gfc_expr_to_initialize (gfc_expr
*e
)
6782 result
= gfc_copy_expr (e
);
6784 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6785 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6786 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6788 ref
->u
.ar
.type
= AR_FULL
;
6790 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6791 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6796 gfc_free_shape (&result
->shape
, result
->rank
);
6798 /* Recalculate rank, shape, etc. */
6799 gfc_resolve_expr (result
);
6804 /* If the last ref of an expression is an array ref, return a copy of the
6805 expression with that one removed. Otherwise, a copy of the original
6806 expression. This is used for allocate-expressions and pointer assignment
6807 LHS, where there may be an array specification that needs to be stripped
6808 off when using gfc_check_vardef_context. */
6811 remove_last_array_ref (gfc_expr
* e
)
6816 e2
= gfc_copy_expr (e
);
6817 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6818 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6820 gfc_free_ref_list (*r
);
6829 /* Used in resolve_allocate_expr to check that a allocation-object and
6830 a source-expr are conformable. This does not catch all possible
6831 cases; in particular a runtime checking is needed. */
6834 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6837 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6839 /* First compare rank. */
6840 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6841 || (!tail
&& e1
->rank
!= e2
->rank
))
6843 gfc_error ("Source-expr at %L must be scalar or have the "
6844 "same rank as the allocate-object at %L",
6845 &e1
->where
, &e2
->where
);
6856 for (i
= 0; i
< e1
->rank
; i
++)
6858 if (tail
->u
.ar
.start
[i
] == NULL
)
6861 if (tail
->u
.ar
.end
[i
])
6863 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6864 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6865 mpz_add_ui (s
, s
, 1);
6869 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6872 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6874 gfc_error ("Source-expr at %L and allocate-object at %L must "
6875 "have the same shape", &e1
->where
, &e2
->where
);
6888 /* Resolve the expression in an ALLOCATE statement, doing the additional
6889 checks to see whether the expression is OK or not. The expression must
6890 have a trailing array reference that gives the size of the array. */
6893 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
6895 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6899 symbol_attribute attr
;
6900 gfc_ref
*ref
, *ref2
;
6903 gfc_symbol
*sym
= NULL
;
6908 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6909 checking of coarrays. */
6910 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6911 if (ref
->next
== NULL
)
6914 if (ref
&& ref
->type
== REF_ARRAY
)
6915 ref
->u
.ar
.in_allocate
= true;
6917 if (!gfc_resolve_expr (e
))
6920 /* Make sure the expression is allocatable or a pointer. If it is
6921 pointer, the next-to-last reference must be a pointer. */
6925 sym
= e
->symtree
->n
.sym
;
6927 /* Check whether ultimate component is abstract and CLASS. */
6930 /* Is the allocate-object unlimited polymorphic? */
6931 unlimited
= UNLIMITED_POLY(e
);
6933 if (e
->expr_type
!= EXPR_VARIABLE
)
6936 attr
= gfc_expr_attr (e
);
6937 pointer
= attr
.pointer
;
6938 dimension
= attr
.dimension
;
6939 codimension
= attr
.codimension
;
6943 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6945 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6946 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6947 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6948 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6949 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6953 allocatable
= sym
->attr
.allocatable
;
6954 pointer
= sym
->attr
.pointer
;
6955 dimension
= sym
->attr
.dimension
;
6956 codimension
= sym
->attr
.codimension
;
6961 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6966 if (ref
->u
.ar
.codimen
> 0)
6969 for (n
= ref
->u
.ar
.dimen
;
6970 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6971 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6978 if (ref
->next
!= NULL
)
6986 gfc_error ("Coindexed allocatable object at %L",
6991 c
= ref
->u
.c
.component
;
6992 if (c
->ts
.type
== BT_CLASS
)
6994 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6995 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6996 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6997 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6998 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7002 allocatable
= c
->attr
.allocatable
;
7003 pointer
= c
->attr
.pointer
;
7004 dimension
= c
->attr
.dimension
;
7005 codimension
= c
->attr
.codimension
;
7006 is_abstract
= c
->attr
.abstract
;
7018 /* Check for F08:C628. */
7019 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7021 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7026 /* Some checks for the SOURCE tag. */
7029 /* Check F03:C631. */
7030 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7032 gfc_error ("Type of entity at %L is type incompatible with "
7033 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7037 /* Check F03:C632 and restriction following Note 6.18. */
7038 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7041 /* Check F03:C633. */
7042 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7044 gfc_error ("The allocate-object at %L and the source-expr at %L "
7045 "shall have the same kind type parameter",
7046 &e
->where
, &code
->expr3
->where
);
7050 /* Check F2008, C642. */
7051 if (code
->expr3
->ts
.type
== BT_DERIVED
7052 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7053 || (code
->expr3
->ts
.u
.derived
->from_intmod
7054 == INTMOD_ISO_FORTRAN_ENV
7055 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7056 == ISOFORTRAN_LOCK_TYPE
)))
7058 gfc_error ("The source-expr at %L shall neither be of type "
7059 "LOCK_TYPE nor have a LOCK_TYPE component if "
7060 "allocate-object at %L is a coarray",
7061 &code
->expr3
->where
, &e
->where
);
7065 /* Check TS18508, C702/C703. */
7066 if (code
->expr3
->ts
.type
== BT_DERIVED
7067 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7068 || (code
->expr3
->ts
.u
.derived
->from_intmod
7069 == INTMOD_ISO_FORTRAN_ENV
7070 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7071 == ISOFORTRAN_EVENT_TYPE
)))
7073 gfc_error ("The source-expr at %L shall neither be of type "
7074 "EVENT_TYPE nor have a EVENT_TYPE component if "
7075 "allocate-object at %L is a coarray",
7076 &code
->expr3
->where
, &e
->where
);
7081 /* Check F08:C629. */
7082 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7085 gcc_assert (e
->ts
.type
== BT_CLASS
);
7086 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7087 "type-spec or source-expr", sym
->name
, &e
->where
);
7091 /* Check F08:C632. */
7092 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7093 && !UNLIMITED_POLY (e
))
7095 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7096 code
->ext
.alloc
.ts
.u
.cl
->length
);
7097 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7099 gfc_error ("Allocating %s at %L with type-spec requires the same "
7100 "character-length parameter as in the declaration",
7101 sym
->name
, &e
->where
);
7106 /* In the variable definition context checks, gfc_expr_attr is used
7107 on the expression. This is fooled by the array specification
7108 present in e, thus we have to eliminate that one temporarily. */
7109 e2
= remove_last_array_ref (e
);
7112 t
= gfc_check_vardef_context (e2
, true, true, false,
7113 _("ALLOCATE object"));
7115 t
= gfc_check_vardef_context (e2
, false, true, false,
7116 _("ALLOCATE object"));
7121 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7122 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7124 /* For class arrays, the initialization with SOURCE is done
7125 using _copy and trans_call. It is convenient to exploit that
7126 when the allocated type is different from the declared type but
7127 no SOURCE exists by setting expr3. */
7128 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7130 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7131 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7132 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7134 /* We have to zero initialize the integer variable. */
7135 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7137 else if (!code
->expr3
)
7139 /* Set up default initializer if needed. */
7143 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7144 ts
= code
->ext
.alloc
.ts
;
7148 if (ts
.type
== BT_CLASS
)
7149 ts
= ts
.u
.derived
->components
->ts
;
7151 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7153 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
7154 init_st
->loc
= code
->loc
;
7155 init_st
->expr1
= gfc_expr_to_initialize (e
);
7156 init_st
->expr2
= init_e
;
7157 init_st
->next
= code
->next
;
7158 code
->next
= init_st
;
7161 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7163 /* Default initialization via MOLD (non-polymorphic). */
7164 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7167 gfc_resolve_expr (rhs
);
7168 gfc_free_expr (code
->expr3
);
7173 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7175 /* Make sure the vtab symbol is present when
7176 the module variables are generated. */
7177 gfc_typespec ts
= e
->ts
;
7179 ts
= code
->expr3
->ts
;
7180 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7181 ts
= code
->ext
.alloc
.ts
;
7183 gfc_find_derived_vtab (ts
.u
.derived
);
7186 e
= gfc_expr_to_initialize (e
);
7188 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7190 /* Again, make sure the vtab symbol is present when
7191 the module variables are generated. */
7192 gfc_typespec
*ts
= NULL
;
7194 ts
= &code
->expr3
->ts
;
7196 ts
= &code
->ext
.alloc
.ts
;
7203 e
= gfc_expr_to_initialize (e
);
7206 if (dimension
== 0 && codimension
== 0)
7209 /* Make sure the last reference node is an array specification. */
7211 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7212 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7217 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7218 "in ALLOCATE statement at %L", &e
->where
))
7220 *array_alloc_wo_spec
= true;
7224 gfc_error ("Array specification required in ALLOCATE statement "
7225 "at %L", &e
->where
);
7230 /* Make sure that the array section reference makes sense in the
7231 context of an ALLOCATE specification. */
7236 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7237 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7239 gfc_error ("Coarray specification required in ALLOCATE statement "
7240 "at %L", &e
->where
);
7244 for (i
= 0; i
< ar
->dimen
; i
++)
7246 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7249 switch (ar
->dimen_type
[i
])
7255 if (ar
->start
[i
] != NULL
7256 && ar
->end
[i
] != NULL
7257 && ar
->stride
[i
] == NULL
)
7260 /* Fall Through... */
7265 case DIMEN_THIS_IMAGE
:
7266 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7272 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7274 sym
= a
->expr
->symtree
->n
.sym
;
7276 /* TODO - check derived type components. */
7277 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7280 if ((ar
->start
[i
] != NULL
7281 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7282 || (ar
->end
[i
] != NULL
7283 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7285 gfc_error ("%qs must not appear in the array specification at "
7286 "%L in the same ALLOCATE statement where it is "
7287 "itself allocated", sym
->name
, &ar
->where
);
7293 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7295 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7296 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7298 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7300 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7301 "statement at %L", &e
->where
);
7307 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7308 && ar
->stride
[i
] == NULL
)
7311 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7325 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7327 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7328 gfc_alloc
*a
, *p
, *q
;
7331 errmsg
= code
->expr2
;
7333 /* Check the stat variable. */
7336 gfc_check_vardef_context (stat
, false, false, false,
7337 _("STAT variable"));
7339 if ((stat
->ts
.type
!= BT_INTEGER
7340 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7341 || stat
->ref
->type
== REF_COMPONENT
)))
7343 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7344 "variable", &stat
->where
);
7346 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7347 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7349 gfc_ref
*ref1
, *ref2
;
7352 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7353 ref1
= ref1
->next
, ref2
= ref2
->next
)
7355 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7357 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7366 gfc_error ("Stat-variable at %L shall not be %sd within "
7367 "the same %s statement", &stat
->where
, fcn
, fcn
);
7373 /* Check the errmsg variable. */
7377 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7380 gfc_check_vardef_context (errmsg
, false, false, false,
7381 _("ERRMSG variable"));
7383 if ((errmsg
->ts
.type
!= BT_CHARACTER
7385 && (errmsg
->ref
->type
== REF_ARRAY
7386 || errmsg
->ref
->type
== REF_COMPONENT
)))
7387 || errmsg
->rank
> 0 )
7388 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7389 "variable", &errmsg
->where
);
7391 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7392 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7394 gfc_ref
*ref1
, *ref2
;
7397 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7398 ref1
= ref1
->next
, ref2
= ref2
->next
)
7400 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7402 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7411 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7412 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7418 /* Check that an allocate-object appears only once in the statement. */
7420 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7423 for (q
= p
->next
; q
; q
= q
->next
)
7426 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7428 /* This is a potential collision. */
7429 gfc_ref
*pr
= pe
->ref
;
7430 gfc_ref
*qr
= qe
->ref
;
7432 /* Follow the references until
7433 a) They start to differ, in which case there is no error;
7434 you can deallocate a%b and a%c in a single statement
7435 b) Both of them stop, which is an error
7436 c) One of them stops, which is also an error. */
7439 if (pr
== NULL
&& qr
== NULL
)
7441 gfc_error ("Allocate-object at %L also appears at %L",
7442 &pe
->where
, &qe
->where
);
7445 else if (pr
!= NULL
&& qr
== NULL
)
7447 gfc_error ("Allocate-object at %L is subobject of"
7448 " object at %L", &pe
->where
, &qe
->where
);
7451 else if (pr
== NULL
&& qr
!= NULL
)
7453 gfc_error ("Allocate-object at %L is subobject of"
7454 " object at %L", &qe
->where
, &pe
->where
);
7457 /* Here, pr != NULL && qr != NULL */
7458 gcc_assert(pr
->type
== qr
->type
);
7459 if (pr
->type
== REF_ARRAY
)
7461 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7463 gcc_assert (qr
->type
== REF_ARRAY
);
7465 if (pr
->next
&& qr
->next
)
7468 gfc_array_ref
*par
= &(pr
->u
.ar
);
7469 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7471 for (i
=0; i
<par
->dimen
; i
++)
7473 if ((par
->start
[i
] != NULL
7474 || qar
->start
[i
] != NULL
)
7475 && gfc_dep_compare_expr (par
->start
[i
],
7476 qar
->start
[i
]) != 0)
7483 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7496 if (strcmp (fcn
, "ALLOCATE") == 0)
7498 bool arr_alloc_wo_spec
= false;
7499 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7500 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
7502 if (arr_alloc_wo_spec
&& code
->expr3
)
7504 /* Mark the allocate to have to take the array specification
7506 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
7511 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7512 resolve_deallocate_expr (a
->expr
);
7517 /************ SELECT CASE resolution subroutines ************/
7519 /* Callback function for our mergesort variant. Determines interval
7520 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7521 op1 > op2. Assumes we're not dealing with the default case.
7522 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7523 There are nine situations to check. */
7526 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7530 if (op1
->low
== NULL
) /* op1 = (:L) */
7532 /* op2 = (:N), so overlap. */
7534 /* op2 = (M:) or (M:N), L < M */
7535 if (op2
->low
!= NULL
7536 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7539 else if (op1
->high
== NULL
) /* op1 = (K:) */
7541 /* op2 = (M:), so overlap. */
7543 /* op2 = (:N) or (M:N), K > N */
7544 if (op2
->high
!= NULL
7545 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7548 else /* op1 = (K:L) */
7550 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7551 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7553 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7554 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7556 else /* op2 = (M:N) */
7560 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7563 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7572 /* Merge-sort a double linked case list, detecting overlap in the
7573 process. LIST is the head of the double linked case list before it
7574 is sorted. Returns the head of the sorted list if we don't see any
7575 overlap, or NULL otherwise. */
7578 check_case_overlap (gfc_case
*list
)
7580 gfc_case
*p
, *q
, *e
, *tail
;
7581 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7583 /* If the passed list was empty, return immediately. */
7590 /* Loop unconditionally. The only exit from this loop is a return
7591 statement, when we've finished sorting the case list. */
7598 /* Count the number of merges we do in this pass. */
7601 /* Loop while there exists a merge to be done. */
7606 /* Count this merge. */
7609 /* Cut the list in two pieces by stepping INSIZE places
7610 forward in the list, starting from P. */
7613 for (i
= 0; i
< insize
; i
++)
7622 /* Now we have two lists. Merge them! */
7623 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7625 /* See from which the next case to merge comes from. */
7628 /* P is empty so the next case must come from Q. */
7633 else if (qsize
== 0 || q
== NULL
)
7642 cmp
= compare_cases (p
, q
);
7645 /* The whole case range for P is less than the
7653 /* The whole case range for Q is greater than
7654 the case range for P. */
7661 /* The cases overlap, or they are the same
7662 element in the list. Either way, we must
7663 issue an error and get the next case from P. */
7664 /* FIXME: Sort P and Q by line number. */
7665 gfc_error ("CASE label at %L overlaps with CASE "
7666 "label at %L", &p
->where
, &q
->where
);
7674 /* Add the next element to the merged list. */
7683 /* P has now stepped INSIZE places along, and so has Q. So
7684 they're the same. */
7689 /* If we have done only one merge or none at all, we've
7690 finished sorting the cases. */
7699 /* Otherwise repeat, merging lists twice the size. */
7705 /* Check to see if an expression is suitable for use in a CASE statement.
7706 Makes sure that all case expressions are scalar constants of the same
7707 type. Return false if anything is wrong. */
7710 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7712 if (e
== NULL
) return true;
7714 if (e
->ts
.type
!= case_expr
->ts
.type
)
7716 gfc_error ("Expression in CASE statement at %L must be of type %s",
7717 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7721 /* C805 (R808) For a given case-construct, each case-value shall be of
7722 the same type as case-expr. For character type, length differences
7723 are allowed, but the kind type parameters shall be the same. */
7725 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7727 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7728 &e
->where
, case_expr
->ts
.kind
);
7732 /* Convert the case value kind to that of case expression kind,
7735 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7736 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7740 gfc_error ("Expression in CASE statement at %L must be scalar",
7749 /* Given a completely parsed select statement, we:
7751 - Validate all expressions and code within the SELECT.
7752 - Make sure that the selection expression is not of the wrong type.
7753 - Make sure that no case ranges overlap.
7754 - Eliminate unreachable cases and unreachable code resulting from
7755 removing case labels.
7757 The standard does allow unreachable cases, e.g. CASE (5:3). But
7758 they are a hassle for code generation, and to prevent that, we just
7759 cut them out here. This is not necessary for overlapping cases
7760 because they are illegal and we never even try to generate code.
7762 We have the additional caveat that a SELECT construct could have
7763 been a computed GOTO in the source code. Fortunately we can fairly
7764 easily work around that here: The case_expr for a "real" SELECT CASE
7765 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7766 we have to do is make sure that the case_expr is a scalar integer
7770 resolve_select (gfc_code
*code
, bool select_type
)
7773 gfc_expr
*case_expr
;
7774 gfc_case
*cp
, *default_case
, *tail
, *head
;
7775 int seen_unreachable
;
7781 if (code
->expr1
== NULL
)
7783 /* This was actually a computed GOTO statement. */
7784 case_expr
= code
->expr2
;
7785 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7786 gfc_error ("Selection expression in computed GOTO statement "
7787 "at %L must be a scalar integer expression",
7790 /* Further checking is not necessary because this SELECT was built
7791 by the compiler, so it should always be OK. Just move the
7792 case_expr from expr2 to expr so that we can handle computed
7793 GOTOs as normal SELECTs from here on. */
7794 code
->expr1
= code
->expr2
;
7799 case_expr
= code
->expr1
;
7800 type
= case_expr
->ts
.type
;
7803 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7805 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7806 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7808 /* Punt. Going on here just produce more garbage error messages. */
7813 if (!select_type
&& case_expr
->rank
!= 0)
7815 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7816 "expression", &case_expr
->where
);
7822 /* Raise a warning if an INTEGER case value exceeds the range of
7823 the case-expr. Later, all expressions will be promoted to the
7824 largest kind of all case-labels. */
7826 if (type
== BT_INTEGER
)
7827 for (body
= code
->block
; body
; body
= body
->block
)
7828 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7831 && gfc_check_integer_range (cp
->low
->value
.integer
,
7832 case_expr
->ts
.kind
) != ARITH_OK
)
7833 gfc_warning (0, "Expression in CASE statement at %L is "
7834 "not in the range of %s", &cp
->low
->where
,
7835 gfc_typename (&case_expr
->ts
));
7838 && cp
->low
!= cp
->high
7839 && gfc_check_integer_range (cp
->high
->value
.integer
,
7840 case_expr
->ts
.kind
) != ARITH_OK
)
7841 gfc_warning (0, "Expression in CASE statement at %L is "
7842 "not in the range of %s", &cp
->high
->where
,
7843 gfc_typename (&case_expr
->ts
));
7846 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7847 of the SELECT CASE expression and its CASE values. Walk the lists
7848 of case values, and if we find a mismatch, promote case_expr to
7849 the appropriate kind. */
7851 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7853 for (body
= code
->block
; body
; body
= body
->block
)
7855 /* Walk the case label list. */
7856 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7858 /* Intercept the DEFAULT case. It does not have a kind. */
7859 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7862 /* Unreachable case ranges are discarded, so ignore. */
7863 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7864 && cp
->low
!= cp
->high
7865 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7869 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7870 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7872 if (cp
->high
!= NULL
7873 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7874 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7879 /* Assume there is no DEFAULT case. */
7880 default_case
= NULL
;
7885 for (body
= code
->block
; body
; body
= body
->block
)
7887 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7889 seen_unreachable
= 0;
7891 /* Walk the case label list, making sure that all case labels
7893 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7895 /* Count the number of cases in the whole construct. */
7898 /* Intercept the DEFAULT case. */
7899 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7901 if (default_case
!= NULL
)
7903 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7904 "by a second DEFAULT CASE at %L",
7905 &default_case
->where
, &cp
->where
);
7916 /* Deal with single value cases and case ranges. Errors are
7917 issued from the validation function. */
7918 if (!validate_case_label_expr (cp
->low
, case_expr
)
7919 || !validate_case_label_expr (cp
->high
, case_expr
))
7925 if (type
== BT_LOGICAL
7926 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7927 || cp
->low
!= cp
->high
))
7929 gfc_error ("Logical range in CASE statement at %L is not "
7930 "allowed", &cp
->low
->where
);
7935 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7938 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7939 if (value
& seen_logical
)
7941 gfc_error ("Constant logical value in CASE statement "
7942 "is repeated at %L",
7947 seen_logical
|= value
;
7950 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7951 && cp
->low
!= cp
->high
7952 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7954 if (warn_surprising
)
7955 gfc_warning (OPT_Wsurprising
,
7956 "Range specification at %L can never be matched",
7959 cp
->unreachable
= 1;
7960 seen_unreachable
= 1;
7964 /* If the case range can be matched, it can also overlap with
7965 other cases. To make sure it does not, we put it in a
7966 double linked list here. We sort that with a merge sort
7967 later on to detect any overlapping cases. */
7971 head
->right
= head
->left
= NULL
;
7976 tail
->right
->left
= tail
;
7983 /* It there was a failure in the previous case label, give up
7984 for this case label list. Continue with the next block. */
7988 /* See if any case labels that are unreachable have been seen.
7989 If so, we eliminate them. This is a bit of a kludge because
7990 the case lists for a single case statement (label) is a
7991 single forward linked lists. */
7992 if (seen_unreachable
)
7994 /* Advance until the first case in the list is reachable. */
7995 while (body
->ext
.block
.case_list
!= NULL
7996 && body
->ext
.block
.case_list
->unreachable
)
7998 gfc_case
*n
= body
->ext
.block
.case_list
;
7999 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8001 gfc_free_case_list (n
);
8004 /* Strip all other unreachable cases. */
8005 if (body
->ext
.block
.case_list
)
8007 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8009 if (cp
->next
->unreachable
)
8011 gfc_case
*n
= cp
->next
;
8012 cp
->next
= cp
->next
->next
;
8014 gfc_free_case_list (n
);
8021 /* See if there were overlapping cases. If the check returns NULL,
8022 there was overlap. In that case we don't do anything. If head
8023 is non-NULL, we prepend the DEFAULT case. The sorted list can
8024 then used during code generation for SELECT CASE constructs with
8025 a case expression of a CHARACTER type. */
8028 head
= check_case_overlap (head
);
8030 /* Prepend the default_case if it is there. */
8031 if (head
!= NULL
&& default_case
)
8033 default_case
->left
= NULL
;
8034 default_case
->right
= head
;
8035 head
->left
= default_case
;
8039 /* Eliminate dead blocks that may be the result if we've seen
8040 unreachable case labels for a block. */
8041 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8043 if (body
->block
->ext
.block
.case_list
== NULL
)
8045 /* Cut the unreachable block from the code chain. */
8046 gfc_code
*c
= body
->block
;
8047 body
->block
= c
->block
;
8049 /* Kill the dead block, but not the blocks below it. */
8051 gfc_free_statements (c
);
8055 /* More than two cases is legal but insane for logical selects.
8056 Issue a warning for it. */
8057 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8058 gfc_warning (OPT_Wsurprising
,
8059 "Logical SELECT CASE block at %L has more that two cases",
8064 /* Check if a derived type is extensible. */
8067 gfc_type_is_extensible (gfc_symbol
*sym
)
8069 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8070 || (sym
->attr
.is_class
8071 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8076 resolve_types (gfc_namespace
*ns
);
8078 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8079 correct as well as possibly the array-spec. */
8082 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8086 gcc_assert (sym
->assoc
);
8087 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8089 /* If this is for SELECT TYPE, the target may not yet be set. In that
8090 case, return. Resolution will be called later manually again when
8092 target
= sym
->assoc
->target
;
8095 gcc_assert (!sym
->assoc
->dangling
);
8097 if (resolve_target
&& !gfc_resolve_expr (target
))
8100 /* For variable targets, we get some attributes from the target. */
8101 if (target
->expr_type
== EXPR_VARIABLE
)
8105 gcc_assert (target
->symtree
);
8106 tsym
= target
->symtree
->n
.sym
;
8108 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8109 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8111 sym
->attr
.target
= tsym
->attr
.target
8112 || gfc_expr_attr (target
).pointer
;
8113 if (is_subref_array (target
))
8114 sym
->attr
.subref_array_pointer
= 1;
8117 /* Get type if this was not already set. Note that it can be
8118 some other type than the target in case this is a SELECT TYPE
8119 selector! So we must not update when the type is already there. */
8120 if (sym
->ts
.type
== BT_UNKNOWN
)
8121 sym
->ts
= target
->ts
;
8122 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8124 /* See if this is a valid association-to-variable. */
8125 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8126 && !gfc_has_vector_subscript (target
));
8128 /* Finally resolve if this is an array or not. */
8129 if (sym
->attr
.dimension
&& target
->rank
== 0)
8131 /* primary.c makes the assumption that a reference to an associate
8132 name followed by a left parenthesis is an array reference. */
8133 if (sym
->ts
.type
!= BT_CHARACTER
)
8134 gfc_error ("Associate-name %qs at %L is used as array",
8135 sym
->name
, &sym
->declared_at
);
8136 sym
->attr
.dimension
= 0;
8141 /* We cannot deal with class selectors that need temporaries. */
8142 if (target
->ts
.type
== BT_CLASS
8143 && gfc_ref_needs_temporary_p (target
->ref
))
8145 gfc_error ("CLASS selector at %L needs a temporary which is not "
8146 "yet implemented", &target
->where
);
8150 if (target
->ts
.type
== BT_CLASS
)
8151 gfc_fix_class_refs (target
);
8153 if (target
->rank
!= 0)
8156 if (sym
->ts
.type
!= BT_CLASS
&& !sym
->as
)
8158 as
= gfc_get_array_spec ();
8159 as
->rank
= target
->rank
;
8160 as
->type
= AS_DEFERRED
;
8161 as
->corank
= gfc_get_corank (target
);
8162 sym
->attr
.dimension
= 1;
8163 if (as
->corank
!= 0)
8164 sym
->attr
.codimension
= 1;
8170 /* target's rank is 0, but the type of the sym is still array valued,
8171 which has to be corrected. */
8172 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
8175 symbol_attribute attr
;
8176 /* The associated variable's type is still the array type
8177 correct this now. */
8178 gfc_typespec
*ts
= &target
->ts
;
8181 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8186 ts
= &ref
->u
.c
.component
->ts
;
8189 if (ts
->type
== BT_CLASS
)
8190 ts
= &ts
->u
.derived
->components
->ts
;
8196 /* Create a scalar instance of the current class type. Because the
8197 rank of a class array goes into its name, the type has to be
8198 rebuild. The alternative of (re-)setting just the attributes
8199 and as in the current type, destroys the type also in other
8203 sym
->ts
.type
= BT_CLASS
;
8204 attr
= CLASS_DATA (sym
)->attr
;
8206 attr
.associate_var
= 1;
8207 attr
.dimension
= attr
.codimension
= 0;
8208 attr
.class_pointer
= 1;
8209 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8211 /* Make sure the _vptr is set. */
8212 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true);
8213 if (c
->ts
.u
.derived
== NULL
)
8214 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8215 CLASS_DATA (sym
)->attr
.pointer
= 1;
8216 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8217 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8218 gfc_commit_symbol (sym
->ts
.u
.derived
);
8219 /* _vptr now has the _vtab in it, change it to the _vtype. */
8220 if (c
->ts
.u
.derived
->attr
.vtab
)
8221 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8222 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8223 resolve_types (c
->ts
.u
.derived
->ns
);
8227 /* Mark this as an associate variable. */
8228 sym
->attr
.associate_var
= 1;
8230 /* If the target is a good class object, so is the associate variable. */
8231 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8232 sym
->attr
.class_ok
= 1;
8236 /* Resolve a SELECT TYPE statement. */
8239 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8241 gfc_symbol
*selector_type
;
8242 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8243 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8246 char name
[GFC_MAX_SYMBOL_LEN
];
8251 ns
= code
->ext
.block
.ns
;
8254 /* Check for F03:C813. */
8255 if (code
->expr1
->ts
.type
!= BT_CLASS
8256 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8258 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8259 "at %L", &code
->loc
);
8263 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8268 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8269 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8270 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8272 /* F2008: C803 The selector expression must not be coindexed. */
8273 if (gfc_is_coindexed (code
->expr2
))
8275 gfc_error ("Selector at %L must not be coindexed",
8276 &code
->expr2
->where
);
8283 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8285 if (gfc_is_coindexed (code
->expr1
))
8287 gfc_error ("Selector at %L must not be coindexed",
8288 &code
->expr1
->where
);
8293 /* Loop over TYPE IS / CLASS IS cases. */
8294 for (body
= code
->block
; body
; body
= body
->block
)
8296 c
= body
->ext
.block
.case_list
;
8298 /* Check F03:C815. */
8299 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8300 && !selector_type
->attr
.unlimited_polymorphic
8301 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8303 gfc_error ("Derived type %qs at %L must be extensible",
8304 c
->ts
.u
.derived
->name
, &c
->where
);
8309 /* Check F03:C816. */
8310 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8311 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8312 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8314 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8315 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8316 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8318 gfc_error ("Unexpected intrinsic type %qs at %L",
8319 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8324 /* Check F03:C814. */
8325 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8327 gfc_error ("The type-spec at %L shall specify that each length "
8328 "type parameter is assumed", &c
->where
);
8333 /* Intercept the DEFAULT case. */
8334 if (c
->ts
.type
== BT_UNKNOWN
)
8336 /* Check F03:C818. */
8339 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8340 "by a second DEFAULT CASE at %L",
8341 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8346 default_case
= body
;
8353 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8354 target if present. If there are any EXIT statements referring to the
8355 SELECT TYPE construct, this is no problem because the gfc_code
8356 reference stays the same and EXIT is equally possible from the BLOCK
8357 it is changed to. */
8358 code
->op
= EXEC_BLOCK
;
8361 gfc_association_list
* assoc
;
8363 assoc
= gfc_get_association_list ();
8364 assoc
->st
= code
->expr1
->symtree
;
8365 assoc
->target
= gfc_copy_expr (code
->expr2
);
8366 assoc
->target
->where
= code
->expr2
->where
;
8367 /* assoc->variable will be set by resolve_assoc_var. */
8369 code
->ext
.block
.assoc
= assoc
;
8370 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8372 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8375 code
->ext
.block
.assoc
= NULL
;
8377 /* Add EXEC_SELECT to switch on type. */
8378 new_st
= gfc_get_code (code
->op
);
8379 new_st
->expr1
= code
->expr1
;
8380 new_st
->expr2
= code
->expr2
;
8381 new_st
->block
= code
->block
;
8382 code
->expr1
= code
->expr2
= NULL
;
8387 ns
->code
->next
= new_st
;
8389 code
->op
= EXEC_SELECT
;
8391 gfc_add_vptr_component (code
->expr1
);
8392 gfc_add_hash_component (code
->expr1
);
8394 /* Loop over TYPE IS / CLASS IS cases. */
8395 for (body
= code
->block
; body
; body
= body
->block
)
8397 c
= body
->ext
.block
.case_list
;
8399 if (c
->ts
.type
== BT_DERIVED
)
8400 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8401 c
->ts
.u
.derived
->hash_value
);
8402 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8407 ivtab
= gfc_find_vtab (&c
->ts
);
8408 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8409 e
= CLASS_DATA (ivtab
)->initializer
;
8410 c
->low
= c
->high
= gfc_copy_expr (e
);
8413 else if (c
->ts
.type
== BT_UNKNOWN
)
8416 /* Associate temporary to selector. This should only be done
8417 when this case is actually true, so build a new ASSOCIATE
8418 that does precisely this here (instead of using the
8421 if (c
->ts
.type
== BT_CLASS
)
8422 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8423 else if (c
->ts
.type
== BT_DERIVED
)
8424 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8425 else if (c
->ts
.type
== BT_CHARACTER
)
8427 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8428 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8429 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8430 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8431 charlen
, c
->ts
.kind
);
8434 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8437 st
= gfc_find_symtree (ns
->sym_root
, name
);
8438 gcc_assert (st
->n
.sym
->assoc
);
8439 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8440 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8441 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8442 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8444 new_st
= gfc_get_code (EXEC_BLOCK
);
8445 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8446 new_st
->ext
.block
.ns
->code
= body
->next
;
8447 body
->next
= new_st
;
8449 /* Chain in the new list only if it is marked as dangling. Otherwise
8450 there is a CASE label overlap and this is already used. Just ignore,
8451 the error is diagnosed elsewhere. */
8452 if (st
->n
.sym
->assoc
->dangling
)
8454 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8455 st
->n
.sym
->assoc
->dangling
= 0;
8458 resolve_assoc_var (st
->n
.sym
, false);
8461 /* Take out CLASS IS cases for separate treatment. */
8463 while (body
&& body
->block
)
8465 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8467 /* Add to class_is list. */
8468 if (class_is
== NULL
)
8470 class_is
= body
->block
;
8475 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8476 tail
->block
= body
->block
;
8479 /* Remove from EXEC_SELECT list. */
8480 body
->block
= body
->block
->block
;
8493 /* Add a default case to hold the CLASS IS cases. */
8494 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8495 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8497 tail
->ext
.block
.case_list
= gfc_get_case ();
8498 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8500 default_case
= tail
;
8503 /* More than one CLASS IS block? */
8504 if (class_is
->block
)
8508 /* Sort CLASS IS blocks by extension level. */
8512 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8515 /* F03:C817 (check for doubles). */
8516 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8517 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8519 gfc_error ("Double CLASS IS block in SELECT TYPE "
8521 &c2
->ext
.block
.case_list
->where
);
8524 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8525 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8528 (*c1
)->block
= c2
->block
;
8538 /* Generate IF chain. */
8539 if_st
= gfc_get_code (EXEC_IF
);
8541 for (body
= class_is
; body
; body
= body
->block
)
8543 new_st
->block
= gfc_get_code (EXEC_IF
);
8544 new_st
= new_st
->block
;
8545 /* Set up IF condition: Call _gfortran_is_extension_of. */
8546 new_st
->expr1
= gfc_get_expr ();
8547 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8548 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8549 new_st
->expr1
->ts
.kind
= 4;
8550 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8551 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8552 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8553 /* Set up arguments. */
8554 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8555 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8556 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8557 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8558 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8559 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8560 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8561 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8562 new_st
->next
= body
->next
;
8564 if (default_case
->next
)
8566 new_st
->block
= gfc_get_code (EXEC_IF
);
8567 new_st
= new_st
->block
;
8568 new_st
->next
= default_case
->next
;
8571 /* Replace CLASS DEFAULT code by the IF chain. */
8572 default_case
->next
= if_st
;
8575 /* Resolve the internal code. This can not be done earlier because
8576 it requires that the sym->assoc of selectors is set already. */
8577 gfc_current_ns
= ns
;
8578 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8579 gfc_current_ns
= old_ns
;
8581 resolve_select (code
, true);
8585 /* Resolve a transfer statement. This is making sure that:
8586 -- a derived type being transferred has only non-pointer components
8587 -- a derived type being transferred doesn't have private components, unless
8588 it's being transferred from the module where the type was defined
8589 -- we're not trying to transfer a whole assumed size array. */
8592 resolve_transfer (gfc_code
*code
)
8601 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8602 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8603 exp
= exp
->value
.op
.op1
;
8605 if (exp
&& exp
->expr_type
== EXPR_NULL
8608 gfc_error ("Invalid context for NULL () intrinsic at %L",
8613 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8614 && exp
->expr_type
!= EXPR_FUNCTION
8615 && exp
->expr_type
!= EXPR_STRUCTURE
))
8618 /* If we are reading, the variable will be changed. Note that
8619 code->ext.dt may be NULL if the TRANSFER is related to
8620 an INQUIRE statement -- but in this case, we are not reading, either. */
8621 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8622 && !gfc_check_vardef_context (exp
, false, false, false,
8626 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8628 /* Go to actual component transferred. */
8629 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8630 if (ref
->type
== REF_COMPONENT
)
8631 ts
= &ref
->u
.c
.component
->ts
;
8633 if (ts
->type
== BT_CLASS
)
8635 /* FIXME: Test for defined input/output. */
8636 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8637 "it is processed by a defined input/output procedure",
8642 if (ts
->type
== BT_DERIVED
)
8644 /* Check that transferred derived type doesn't contain POINTER
8646 if (ts
->u
.derived
->attr
.pointer_comp
)
8648 gfc_error ("Data transfer element at %L cannot have POINTER "
8649 "components unless it is processed by a defined "
8650 "input/output procedure", &code
->loc
);
8655 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8657 gfc_error ("Data transfer element at %L cannot have "
8658 "procedure pointer components", &code
->loc
);
8662 if (ts
->u
.derived
->attr
.alloc_comp
)
8664 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8665 "components unless it is processed by a defined "
8666 "input/output procedure", &code
->loc
);
8670 /* C_PTR and C_FUNPTR have private components which means they can not
8671 be printed. However, if -std=gnu and not -pedantic, allow
8672 the component to be printed to help debugging. */
8673 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8675 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8676 "cannot have PRIVATE components", &code
->loc
))
8679 else if (derived_inaccessible (ts
->u
.derived
))
8681 gfc_error ("Data transfer element at %L cannot have "
8682 "PRIVATE components",&code
->loc
);
8687 if (exp
->expr_type
== EXPR_STRUCTURE
)
8690 sym
= exp
->symtree
->n
.sym
;
8692 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8693 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8695 gfc_error ("Data transfer element at %L cannot be a full reference to "
8696 "an assumed-size array", &code
->loc
);
8702 /*********** Toplevel code resolution subroutines ***********/
8704 /* Find the set of labels that are reachable from this block. We also
8705 record the last statement in each block. */
8708 find_reachable_labels (gfc_code
*block
)
8715 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8717 /* Collect labels in this block. We don't keep those corresponding
8718 to END {IF|SELECT}, these are checked in resolve_branch by going
8719 up through the code_stack. */
8720 for (c
= block
; c
; c
= c
->next
)
8722 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8723 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8726 /* Merge with labels from parent block. */
8729 gcc_assert (cs_base
->prev
->reachable_labels
);
8730 bitmap_ior_into (cs_base
->reachable_labels
,
8731 cs_base
->prev
->reachable_labels
);
8737 resolve_lock_unlock_event (gfc_code
*code
)
8739 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8740 && code
->expr1
->value
.function
.isym
8741 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8742 remove_caf_get_intrinsic (code
->expr1
);
8744 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
8745 && (code
->expr1
->ts
.type
!= BT_DERIVED
8746 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8747 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8748 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8749 || code
->expr1
->rank
!= 0
8750 || (!gfc_is_coarray (code
->expr1
) &&
8751 !gfc_is_coindexed (code
->expr1
))))
8752 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8753 &code
->expr1
->where
);
8754 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
8755 && (code
->expr1
->ts
.type
!= BT_DERIVED
8756 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8757 || code
->expr1
->ts
.u
.derived
->from_intmod
8758 != INTMOD_ISO_FORTRAN_ENV
8759 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
8760 != ISOFORTRAN_EVENT_TYPE
8761 || code
->expr1
->rank
!= 0))
8762 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
8763 &code
->expr1
->where
);
8764 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
8765 && !gfc_is_coindexed (code
->expr1
))
8766 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
8767 &code
->expr1
->where
);
8768 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
8769 gfc_error ("Event variable argument at %L must be a coarray but not "
8770 "coindexed", &code
->expr1
->where
);
8774 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8775 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8776 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8777 &code
->expr2
->where
);
8780 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8781 _("STAT variable")))
8786 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8787 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8788 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8789 &code
->expr3
->where
);
8792 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8793 _("ERRMSG variable")))
8796 /* Check for LOCK the ACQUIRED_LOCK. */
8797 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
8798 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8799 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8800 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8801 "variable", &code
->expr4
->where
);
8803 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
8804 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8805 _("ACQUIRED_LOCK variable")))
8808 /* Check for EVENT WAIT the UNTIL_COUNT. */
8809 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
8810 && (code
->expr4
->ts
.type
!= BT_INTEGER
|| code
->expr4
->rank
!= 0))
8811 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
8812 "expression", &code
->expr4
->where
);
8817 resolve_critical (gfc_code
*code
)
8819 gfc_symtree
*symtree
;
8820 gfc_symbol
*lock_type
;
8821 char name
[GFC_MAX_SYMBOL_LEN
];
8822 static int serial
= 0;
8824 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8827 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8828 GFC_PREFIX ("lock_type"));
8830 lock_type
= symtree
->n
.sym
;
8833 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8836 lock_type
= symtree
->n
.sym
;
8837 lock_type
->attr
.flavor
= FL_DERIVED
;
8838 lock_type
->attr
.zero_comp
= 1;
8839 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8840 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8843 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8844 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8847 code
->resolved_sym
= symtree
->n
.sym
;
8848 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8849 symtree
->n
.sym
->attr
.referenced
= 1;
8850 symtree
->n
.sym
->attr
.artificial
= 1;
8851 symtree
->n
.sym
->attr
.codimension
= 1;
8852 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8853 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8854 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8855 symtree
->n
.sym
->as
->corank
= 1;
8856 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8857 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8858 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8860 gfc_commit_symbols();
8865 resolve_sync (gfc_code
*code
)
8867 /* Check imageset. The * case matches expr1 == NULL. */
8870 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8871 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8872 "INTEGER expression", &code
->expr1
->where
);
8873 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8874 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8875 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8876 &code
->expr1
->where
);
8877 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8878 && gfc_simplify_expr (code
->expr1
, 0))
8880 gfc_constructor
*cons
;
8881 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8882 for (; cons
; cons
= gfc_constructor_next (cons
))
8883 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8884 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8885 gfc_error ("Imageset argument at %L must between 1 and "
8886 "num_images()", &cons
->expr
->where
);
8892 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8893 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8894 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8895 &code
->expr2
->where
);
8899 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8900 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8901 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8902 &code
->expr3
->where
);
8906 /* Given a branch to a label, see if the branch is conforming.
8907 The code node describes where the branch is located. */
8910 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8917 /* Step one: is this a valid branching target? */
8919 if (label
->defined
== ST_LABEL_UNKNOWN
)
8921 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8926 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8928 gfc_error ("Statement at %L is not a valid branch target statement "
8929 "for the branch statement at %L", &label
->where
, &code
->loc
);
8933 /* Step two: make sure this branch is not a branch to itself ;-) */
8935 if (code
->here
== label
)
8938 "Branch at %L may result in an infinite loop", &code
->loc
);
8942 /* Step three: See if the label is in the same block as the
8943 branching statement. The hard work has been done by setting up
8944 the bitmap reachable_labels. */
8946 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8948 /* Check now whether there is a CRITICAL construct; if so, check
8949 whether the label is still visible outside of the CRITICAL block,
8950 which is invalid. */
8951 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8953 if (stack
->current
->op
== EXEC_CRITICAL
8954 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8955 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8956 "label at %L", &code
->loc
, &label
->where
);
8957 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8958 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8959 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8960 "for label at %L", &code
->loc
, &label
->where
);
8966 /* Step four: If we haven't found the label in the bitmap, it may
8967 still be the label of the END of the enclosing block, in which
8968 case we find it by going up the code_stack. */
8970 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8972 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8974 if (stack
->current
->op
== EXEC_CRITICAL
)
8976 /* Note: A label at END CRITICAL does not leave the CRITICAL
8977 construct as END CRITICAL is still part of it. */
8978 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8979 " at %L", &code
->loc
, &label
->where
);
8982 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8984 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8985 "label at %L", &code
->loc
, &label
->where
);
8992 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8996 /* The label is not in an enclosing block, so illegal. This was
8997 allowed in Fortran 66, so we allow it as extension. No
8998 further checks are necessary in this case. */
8999 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9000 "as the GOTO statement at %L", &label
->where
,
9006 /* Check whether EXPR1 has the same shape as EXPR2. */
9009 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9011 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9012 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9013 bool result
= false;
9016 /* Compare the rank. */
9017 if (expr1
->rank
!= expr2
->rank
)
9020 /* Compare the size of each dimension. */
9021 for (i
=0; i
<expr1
->rank
; i
++)
9023 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9026 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9029 if (mpz_cmp (shape
[i
], shape2
[i
]))
9033 /* When either of the two expression is an assumed size array, we
9034 ignore the comparison of dimension sizes. */
9039 gfc_clear_shape (shape
, i
);
9040 gfc_clear_shape (shape2
, i
);
9045 /* Check whether a WHERE assignment target or a WHERE mask expression
9046 has the same shape as the outmost WHERE mask expression. */
9049 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9055 cblock
= code
->block
;
9057 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9058 In case of nested WHERE, only the outmost one is stored. */
9059 if (mask
== NULL
) /* outmost WHERE */
9061 else /* inner WHERE */
9068 /* Check if the mask-expr has a consistent shape with the
9069 outmost WHERE mask-expr. */
9070 if (!resolve_where_shape (cblock
->expr1
, e
))
9071 gfc_error ("WHERE mask at %L has inconsistent shape",
9072 &cblock
->expr1
->where
);
9075 /* the assignment statement of a WHERE statement, or the first
9076 statement in where-body-construct of a WHERE construct */
9077 cnext
= cblock
->next
;
9082 /* WHERE assignment statement */
9085 /* Check shape consistent for WHERE assignment target. */
9086 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9087 gfc_error ("WHERE assignment target at %L has "
9088 "inconsistent shape", &cnext
->expr1
->where
);
9092 case EXEC_ASSIGN_CALL
:
9093 resolve_call (cnext
);
9094 if (!cnext
->resolved_sym
->attr
.elemental
)
9095 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9096 &cnext
->ext
.actual
->expr
->where
);
9099 /* WHERE or WHERE construct is part of a where-body-construct */
9101 resolve_where (cnext
, e
);
9105 gfc_error ("Unsupported statement inside WHERE at %L",
9108 /* the next statement within the same where-body-construct */
9109 cnext
= cnext
->next
;
9111 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9112 cblock
= cblock
->block
;
9117 /* Resolve assignment in FORALL construct.
9118 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9119 FORALL index variables. */
9122 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9126 for (n
= 0; n
< nvar
; n
++)
9128 gfc_symbol
*forall_index
;
9130 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9132 /* Check whether the assignment target is one of the FORALL index
9134 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9135 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9136 gfc_error ("Assignment to a FORALL index variable at %L",
9137 &code
->expr1
->where
);
9140 /* If one of the FORALL index variables doesn't appear in the
9141 assignment variable, then there could be a many-to-one
9142 assignment. Emit a warning rather than an error because the
9143 mask could be resolving this problem. */
9144 if (!find_forall_index (code
->expr1
, forall_index
, 0))
9145 gfc_warning (0, "The FORALL with index %qs is not used on the "
9146 "left side of the assignment at %L and so might "
9147 "cause multiple assignment to this object",
9148 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9154 /* Resolve WHERE statement in FORALL construct. */
9157 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9158 gfc_expr
**var_expr
)
9163 cblock
= code
->block
;
9166 /* the assignment statement of a WHERE statement, or the first
9167 statement in where-body-construct of a WHERE construct */
9168 cnext
= cblock
->next
;
9173 /* WHERE assignment statement */
9175 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9178 /* WHERE operator assignment statement */
9179 case EXEC_ASSIGN_CALL
:
9180 resolve_call (cnext
);
9181 if (!cnext
->resolved_sym
->attr
.elemental
)
9182 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9183 &cnext
->ext
.actual
->expr
->where
);
9186 /* WHERE or WHERE construct is part of a where-body-construct */
9188 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9192 gfc_error ("Unsupported statement inside WHERE at %L",
9195 /* the next statement within the same where-body-construct */
9196 cnext
= cnext
->next
;
9198 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9199 cblock
= cblock
->block
;
9204 /* Traverse the FORALL body to check whether the following errors exist:
9205 1. For assignment, check if a many-to-one assignment happens.
9206 2. For WHERE statement, check the WHERE body to see if there is any
9207 many-to-one assignment. */
9210 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9214 c
= code
->block
->next
;
9220 case EXEC_POINTER_ASSIGN
:
9221 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9224 case EXEC_ASSIGN_CALL
:
9228 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9229 there is no need to handle it here. */
9233 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9238 /* The next statement in the FORALL body. */
9244 /* Counts the number of iterators needed inside a forall construct, including
9245 nested forall constructs. This is used to allocate the needed memory
9246 in gfc_resolve_forall. */
9249 gfc_count_forall_iterators (gfc_code
*code
)
9251 int max_iters
, sub_iters
, current_iters
;
9252 gfc_forall_iterator
*fa
;
9254 gcc_assert(code
->op
== EXEC_FORALL
);
9258 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9261 code
= code
->block
->next
;
9265 if (code
->op
== EXEC_FORALL
)
9267 sub_iters
= gfc_count_forall_iterators (code
);
9268 if (sub_iters
> max_iters
)
9269 max_iters
= sub_iters
;
9274 return current_iters
+ max_iters
;
9278 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9279 gfc_resolve_forall_body to resolve the FORALL body. */
9282 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9284 static gfc_expr
**var_expr
;
9285 static int total_var
= 0;
9286 static int nvar
= 0;
9288 gfc_forall_iterator
*fa
;
9293 /* Start to resolve a FORALL construct */
9294 if (forall_save
== 0)
9296 /* Count the total number of FORALL index in the nested FORALL
9297 construct in order to allocate the VAR_EXPR with proper size. */
9298 total_var
= gfc_count_forall_iterators (code
);
9300 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9301 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9304 /* The information about FORALL iterator, including FORALL index start, end
9305 and stride. The FORALL index can not appear in start, end or stride. */
9306 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9308 /* Check if any outer FORALL index name is the same as the current
9310 for (i
= 0; i
< nvar
; i
++)
9312 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9314 gfc_error ("An outer FORALL construct already has an index "
9315 "with this name %L", &fa
->var
->where
);
9319 /* Record the current FORALL index. */
9320 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9324 /* No memory leak. */
9325 gcc_assert (nvar
<= total_var
);
9328 /* Resolve the FORALL body. */
9329 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9331 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9332 gfc_resolve_blocks (code
->block
, ns
);
9336 /* Free only the VAR_EXPRs allocated in this frame. */
9337 for (i
= nvar
; i
< tmp
; i
++)
9338 gfc_free_expr (var_expr
[i
]);
9342 /* We are in the outermost FORALL construct. */
9343 gcc_assert (forall_save
== 0);
9345 /* VAR_EXPR is not needed any more. */
9352 /* Resolve a BLOCK construct statement. */
9355 resolve_block_construct (gfc_code
* code
)
9357 /* Resolve the BLOCK's namespace. */
9358 gfc_resolve (code
->ext
.block
.ns
);
9360 /* For an ASSOCIATE block, the associations (and their targets) are already
9361 resolved during resolve_symbol. */
9365 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9369 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9373 for (; b
; b
= b
->block
)
9375 t
= gfc_resolve_expr (b
->expr1
);
9376 if (!gfc_resolve_expr (b
->expr2
))
9382 if (t
&& b
->expr1
!= NULL
9383 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9384 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9391 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9392 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9397 resolve_branch (b
->label1
, b
);
9401 resolve_block_construct (b
);
9405 case EXEC_SELECT_TYPE
:
9409 case EXEC_DO_CONCURRENT
:
9417 case EXEC_OACC_PARALLEL_LOOP
:
9418 case EXEC_OACC_PARALLEL
:
9419 case EXEC_OACC_KERNELS_LOOP
:
9420 case EXEC_OACC_KERNELS
:
9421 case EXEC_OACC_DATA
:
9422 case EXEC_OACC_HOST_DATA
:
9423 case EXEC_OACC_LOOP
:
9424 case EXEC_OACC_UPDATE
:
9425 case EXEC_OACC_WAIT
:
9426 case EXEC_OACC_CACHE
:
9427 case EXEC_OACC_ENTER_DATA
:
9428 case EXEC_OACC_EXIT_DATA
:
9429 case EXEC_OACC_ATOMIC
:
9430 case EXEC_OACC_ROUTINE
:
9431 case EXEC_OMP_ATOMIC
:
9432 case EXEC_OMP_CRITICAL
:
9433 case EXEC_OMP_DISTRIBUTE
:
9434 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9435 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9436 case EXEC_OMP_DISTRIBUTE_SIMD
:
9438 case EXEC_OMP_DO_SIMD
:
9439 case EXEC_OMP_MASTER
:
9440 case EXEC_OMP_ORDERED
:
9441 case EXEC_OMP_PARALLEL
:
9442 case EXEC_OMP_PARALLEL_DO
:
9443 case EXEC_OMP_PARALLEL_DO_SIMD
:
9444 case EXEC_OMP_PARALLEL_SECTIONS
:
9445 case EXEC_OMP_PARALLEL_WORKSHARE
:
9446 case EXEC_OMP_SECTIONS
:
9448 case EXEC_OMP_SINGLE
:
9449 case EXEC_OMP_TARGET
:
9450 case EXEC_OMP_TARGET_DATA
:
9451 case EXEC_OMP_TARGET_TEAMS
:
9452 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9453 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9454 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9455 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9456 case EXEC_OMP_TARGET_UPDATE
:
9458 case EXEC_OMP_TASKGROUP
:
9459 case EXEC_OMP_TASKWAIT
:
9460 case EXEC_OMP_TASKYIELD
:
9461 case EXEC_OMP_TEAMS
:
9462 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9463 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9464 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9465 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9466 case EXEC_OMP_WORKSHARE
:
9470 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9473 gfc_resolve_code (b
->next
, ns
);
9478 /* Does everything to resolve an ordinary assignment. Returns true
9479 if this is an interface assignment. */
9481 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9490 symbol_attribute attr
;
9492 if (gfc_extend_assign (code
, ns
))
9496 if (code
->op
== EXEC_ASSIGN_CALL
)
9498 lhs
= code
->ext
.actual
->expr
;
9499 rhsptr
= &code
->ext
.actual
->next
->expr
;
9503 gfc_actual_arglist
* args
;
9504 gfc_typebound_proc
* tbp
;
9506 gcc_assert (code
->op
== EXEC_COMPCALL
);
9508 args
= code
->expr1
->value
.compcall
.actual
;
9510 rhsptr
= &args
->next
->expr
;
9512 tbp
= code
->expr1
->value
.compcall
.tbp
;
9513 gcc_assert (!tbp
->is_generic
);
9516 /* Make a temporary rhs when there is a default initializer
9517 and rhs is the same symbol as the lhs. */
9518 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9519 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9520 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9521 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9522 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9531 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9532 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9536 /* Handle the case of a BOZ literal on the RHS. */
9537 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9540 if (warn_surprising
)
9541 gfc_warning (OPT_Wsurprising
,
9542 "BOZ literal at %L is bitwise transferred "
9543 "non-integer symbol %qs", &code
->loc
,
9544 lhs
->symtree
->n
.sym
->name
);
9546 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9548 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9550 if (rc
== ARITH_UNDERFLOW
)
9551 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9552 ". This check can be disabled with the option "
9553 "%<-fno-range-check%>", &rhs
->where
);
9554 else if (rc
== ARITH_OVERFLOW
)
9555 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9556 ". This check can be disabled with the option "
9557 "%<-fno-range-check%>", &rhs
->where
);
9558 else if (rc
== ARITH_NAN
)
9559 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9560 ". This check can be disabled with the option "
9561 "%<-fno-range-check%>", &rhs
->where
);
9566 if (lhs
->ts
.type
== BT_CHARACTER
9567 && warn_character_truncation
)
9569 if (lhs
->ts
.u
.cl
!= NULL
9570 && lhs
->ts
.u
.cl
->length
!= NULL
9571 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9572 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9574 if (rhs
->expr_type
== EXPR_CONSTANT
)
9575 rlen
= rhs
->value
.character
.length
;
9577 else if (rhs
->ts
.u
.cl
!= NULL
9578 && rhs
->ts
.u
.cl
->length
!= NULL
9579 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9580 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9582 if (rlen
&& llen
&& rlen
> llen
)
9583 gfc_warning_now (OPT_Wcharacter_truncation
,
9584 "CHARACTER expression will be truncated "
9585 "in assignment (%d/%d) at %L",
9586 llen
, rlen
, &code
->loc
);
9589 /* Ensure that a vector index expression for the lvalue is evaluated
9590 to a temporary if the lvalue symbol is referenced in it. */
9593 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9594 if (ref
->type
== REF_ARRAY
)
9596 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9597 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9598 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9599 ref
->u
.ar
.start
[n
]))
9601 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9605 if (gfc_pure (NULL
))
9607 if (lhs
->ts
.type
== BT_DERIVED
9608 && lhs
->expr_type
== EXPR_VARIABLE
9609 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9610 && rhs
->expr_type
== EXPR_VARIABLE
9611 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9612 || gfc_is_coindexed (rhs
)))
9615 if (gfc_is_coindexed (rhs
))
9616 gfc_error ("Coindexed expression at %L is assigned to "
9617 "a derived type variable with a POINTER "
9618 "component in a PURE procedure",
9621 gfc_error ("The impure variable at %L is assigned to "
9622 "a derived type variable with a POINTER "
9623 "component in a PURE procedure (12.6)",
9628 /* Fortran 2008, C1283. */
9629 if (gfc_is_coindexed (lhs
))
9631 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9632 "procedure", &rhs
->where
);
9637 if (gfc_implicit_pure (NULL
))
9639 if (lhs
->expr_type
== EXPR_VARIABLE
9640 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9641 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9642 gfc_unset_implicit_pure (NULL
);
9644 if (lhs
->ts
.type
== BT_DERIVED
9645 && lhs
->expr_type
== EXPR_VARIABLE
9646 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9647 && rhs
->expr_type
== EXPR_VARIABLE
9648 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9649 || gfc_is_coindexed (rhs
)))
9650 gfc_unset_implicit_pure (NULL
);
9652 /* Fortran 2008, C1283. */
9653 if (gfc_is_coindexed (lhs
))
9654 gfc_unset_implicit_pure (NULL
);
9657 /* F2008, 7.2.1.2. */
9658 attr
= gfc_expr_attr (lhs
);
9659 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9661 if (attr
.codimension
)
9663 gfc_error ("Assignment to polymorphic coarray at %L is not "
9664 "permitted", &lhs
->where
);
9667 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9668 "polymorphic variable at %L", &lhs
->where
))
9670 if (!flag_realloc_lhs
)
9672 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9673 "requires %<-frealloc-lhs%>", &lhs
->where
);
9677 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9678 "is not yet supported", &lhs
->where
);
9681 else if (lhs
->ts
.type
== BT_CLASS
)
9683 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9684 "assignment at %L - check that there is a matching specific "
9685 "subroutine for '=' operator", &lhs
->where
);
9689 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9691 /* F2008, Section 7.2.1.2. */
9692 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9694 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9695 "component in assignment at %L", &lhs
->where
);
9699 gfc_check_assign (lhs
, rhs
, 1);
9701 /* Assign the 'data' of a class object to a derived type. */
9702 if (lhs
->ts
.type
== BT_DERIVED
9703 && rhs
->ts
.type
== BT_CLASS
)
9704 gfc_add_data_component (rhs
);
9706 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9707 Additionally, insert this code when the RHS is a CAF as we then use the
9708 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9709 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9710 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9712 if (flag_coarray
== GFC_FCOARRAY_LIB
9714 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9715 && code
->expr2
->value
.function
.isym
9716 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9717 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9718 && !gfc_expr_attr (rhs
).allocatable
9719 && !gfc_has_vector_subscript (rhs
))))
9721 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9722 && code
->expr2
->value
.function
.isym
9723 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9724 remove_caf_get_intrinsic (code
->expr2
);
9725 code
->op
= EXEC_CALL
;
9726 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9727 code
->resolved_sym
= code
->symtree
->n
.sym
;
9728 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9729 code
->resolved_sym
->attr
.intrinsic
= 1;
9730 code
->resolved_sym
->attr
.subroutine
= 1;
9731 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9732 gfc_commit_symbol (code
->resolved_sym
);
9733 code
->ext
.actual
= gfc_get_actual_arglist ();
9734 code
->ext
.actual
->expr
= lhs
;
9735 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9736 code
->ext
.actual
->next
->expr
= rhs
;
9745 /* Add a component reference onto an expression. */
9748 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9753 ref
= &((*ref
)->next
);
9754 *ref
= gfc_get_ref ();
9755 (*ref
)->type
= REF_COMPONENT
;
9756 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9757 (*ref
)->u
.c
.component
= c
;
9760 /* Add a full array ref, as necessary. */
9763 gfc_add_full_array_ref (e
, c
->as
);
9764 e
->rank
= c
->as
->rank
;
9769 /* Build an assignment. Keep the argument 'op' for future use, so that
9770 pointer assignments can be made. */
9773 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9774 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9776 gfc_code
*this_code
;
9778 this_code
= gfc_get_code (op
);
9779 this_code
->next
= NULL
;
9780 this_code
->expr1
= gfc_copy_expr (expr1
);
9781 this_code
->expr2
= gfc_copy_expr (expr2
);
9782 this_code
->loc
= loc
;
9785 add_comp_ref (this_code
->expr1
, comp1
);
9786 add_comp_ref (this_code
->expr2
, comp2
);
9793 /* Makes a temporary variable expression based on the characteristics of
9794 a given variable expression. */
9797 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9799 static int serial
= 0;
9800 char name
[GFC_MAX_SYMBOL_LEN
];
9803 gfc_array_ref
*aref
;
9806 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9807 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9808 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9814 /* Obtain the arrayspec for the temporary. */
9815 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
9816 && e
->expr_type
!= EXPR_FUNCTION
9817 && e
->expr_type
!= EXPR_OP
)
9819 aref
= gfc_find_array_ref (e
);
9820 if (e
->expr_type
== EXPR_VARIABLE
9821 && e
->symtree
->n
.sym
->as
== aref
->as
)
9825 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9826 if (ref
->type
== REF_COMPONENT
9827 && ref
->u
.c
.component
->as
== aref
->as
)
9835 /* Add the attributes and the arrayspec to the temporary. */
9836 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9837 tmp
->n
.sym
->attr
.function
= 0;
9838 tmp
->n
.sym
->attr
.result
= 0;
9839 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9843 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9846 if (as
->type
== AS_DEFERRED
)
9847 tmp
->n
.sym
->attr
.allocatable
= 1;
9849 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
9850 || e
->expr_type
== EXPR_FUNCTION
9851 || e
->expr_type
== EXPR_OP
))
9853 tmp
->n
.sym
->as
= gfc_get_array_spec ();
9854 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
9855 tmp
->n
.sym
->as
->rank
= e
->rank
;
9856 tmp
->n
.sym
->attr
.allocatable
= 1;
9857 tmp
->n
.sym
->attr
.dimension
= 1;
9860 tmp
->n
.sym
->attr
.dimension
= 0;
9862 gfc_set_sym_referenced (tmp
->n
.sym
);
9863 gfc_commit_symbol (tmp
->n
.sym
);
9864 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9866 /* Should the lhs be a section, use its array ref for the
9867 temporary expression. */
9868 if (aref
&& aref
->type
!= AR_FULL
)
9870 gfc_free_ref_list (e
->ref
);
9871 e
->ref
= gfc_copy_ref (ref
);
9877 /* Add one line of code to the code chain, making sure that 'head' and
9878 'tail' are appropriately updated. */
9881 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9883 gcc_assert (this_code
);
9885 *head
= *tail
= *this_code
;
9887 *tail
= gfc_append_code (*tail
, *this_code
);
9892 /* Counts the potential number of part array references that would
9893 result from resolution of typebound defined assignments. */
9896 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9899 int c_depth
= 0, t_depth
;
9901 for (c
= derived
->components
; c
; c
= c
->next
)
9903 if ((c
->ts
.type
!= BT_DERIVED
9905 || c
->attr
.allocatable
9906 || c
->attr
.proc_pointer_comp
9907 || c
->attr
.class_pointer
9908 || c
->attr
.proc_pointer
)
9909 && !c
->attr
.defined_assign_comp
)
9912 if (c
->as
&& c_depth
== 0)
9915 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9916 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9921 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9923 return depth
+ c_depth
;
9927 /* Implement 7.2.1.3 of the F08 standard:
9928 "An intrinsic assignment where the variable is of derived type is
9929 performed as if each component of the variable were assigned from the
9930 corresponding component of expr using pointer assignment (7.2.2) for
9931 each pointer component, defined assignment for each nonpointer
9932 nonallocatable component of a type that has a type-bound defined
9933 assignment consistent with the component, intrinsic assignment for
9934 each other nonpointer nonallocatable component, ..."
9936 The pointer assignments are taken care of by the intrinsic
9937 assignment of the structure itself. This function recursively adds
9938 defined assignments where required. The recursion is accomplished
9939 by calling gfc_resolve_code.
9941 When the lhs in a defined assignment has intent INOUT, we need a
9942 temporary for the lhs. In pseudo-code:
9944 ! Only call function lhs once.
9945 if (lhs is not a constant or an variable)
9948 ! Do the intrinsic assignment
9950 ! Now do the defined assignments
9951 do over components with typebound defined assignment [%cmp]
9952 #if one component's assignment procedure is INOUT
9954 #if expr2 non-variable
9960 t1%cmp {defined=} expr2%cmp
9966 expr1%cmp {defined=} expr2%cmp
9970 /* The temporary assignments have to be put on top of the additional
9971 code to avoid the result being changed by the intrinsic assignment.
9973 static int component_assignment_level
= 0;
9974 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9977 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9979 gfc_component
*comp1
, *comp2
;
9980 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9982 int error_count
, depth
;
9984 gfc_get_errors (NULL
, &error_count
);
9986 /* Filter out continuing processing after an error. */
9988 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9989 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9992 /* TODO: Handle more than one part array reference in assignments. */
9993 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9994 (*code
)->expr1
->rank
? 1 : 0);
9997 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
9998 "done because multiple part array references would "
9999 "occur in intermediate expressions.", &(*code
)->loc
);
10003 component_assignment_level
++;
10005 /* Create a temporary so that functions get called only once. */
10006 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10007 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10009 gfc_expr
*tmp_expr
;
10011 /* Assign the rhs to the temporary. */
10012 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10013 this_code
= build_assignment (EXEC_ASSIGN
,
10014 tmp_expr
, (*code
)->expr2
,
10015 NULL
, NULL
, (*code
)->loc
);
10016 /* Add the code and substitute the rhs expression. */
10017 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10018 gfc_free_expr ((*code
)->expr2
);
10019 (*code
)->expr2
= tmp_expr
;
10022 /* Do the intrinsic assignment. This is not needed if the lhs is one
10023 of the temporaries generated here, since the intrinsic assignment
10024 to the final result already does this. */
10025 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10027 this_code
= build_assignment (EXEC_ASSIGN
,
10028 (*code
)->expr1
, (*code
)->expr2
,
10029 NULL
, NULL
, (*code
)->loc
);
10030 add_code_to_chain (&this_code
, &head
, &tail
);
10033 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10034 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10037 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10039 bool inout
= false;
10041 /* The intrinsic assignment does the right thing for pointers
10042 of all kinds and allocatable components. */
10043 if (comp1
->ts
.type
!= BT_DERIVED
10044 || comp1
->attr
.pointer
10045 || comp1
->attr
.allocatable
10046 || comp1
->attr
.proc_pointer_comp
10047 || comp1
->attr
.class_pointer
10048 || comp1
->attr
.proc_pointer
)
10051 /* Make an assigment for this component. */
10052 this_code
= build_assignment (EXEC_ASSIGN
,
10053 (*code
)->expr1
, (*code
)->expr2
,
10054 comp1
, comp2
, (*code
)->loc
);
10056 /* Convert the assignment if there is a defined assignment for
10057 this type. Otherwise, using the call from gfc_resolve_code,
10058 recurse into its components. */
10059 gfc_resolve_code (this_code
, ns
);
10061 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10063 gfc_formal_arglist
*dummy_args
;
10065 /* Check that there is a typebound defined assignment. If not,
10066 then this must be a module defined assignment. We cannot
10067 use the defined_assign_comp attribute here because it must
10068 be this derived type that has the defined assignment and not
10070 if (!(comp1
->ts
.u
.derived
->f2k_derived
10071 && comp1
->ts
.u
.derived
->f2k_derived
10072 ->tb_op
[INTRINSIC_ASSIGN
]))
10074 gfc_free_statements (this_code
);
10079 /* If the first argument of the subroutine has intent INOUT
10080 a temporary must be generated and used instead. */
10081 rsym
= this_code
->resolved_sym
;
10082 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10084 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10086 gfc_code
*temp_code
;
10089 /* Build the temporary required for the assignment and put
10090 it at the head of the generated code. */
10093 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
10094 temp_code
= build_assignment (EXEC_ASSIGN
,
10095 t1
, (*code
)->expr1
,
10096 NULL
, NULL
, (*code
)->loc
);
10098 /* For allocatable LHS, check whether it is allocated. Note
10099 that allocatable components with defined assignment are
10100 not yet support. See PR 57696. */
10101 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
10105 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10106 block
= gfc_get_code (EXEC_IF
);
10107 block
->block
= gfc_get_code (EXEC_IF
);
10108 block
->block
->expr1
10109 = gfc_build_intrinsic_call (ns
,
10110 GFC_ISYM_ALLOCATED
, "allocated",
10111 (*code
)->loc
, 1, e
);
10112 block
->block
->next
= temp_code
;
10115 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
10118 /* Replace the first actual arg with the component of the
10120 gfc_free_expr (this_code
->ext
.actual
->expr
);
10121 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
10122 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10124 /* If the LHS variable is allocatable and wasn't allocated and
10125 the temporary is allocatable, pointer assign the address of
10126 the freshly allocated LHS to the temporary. */
10127 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10128 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10133 cond
= gfc_get_expr ();
10134 cond
->ts
.type
= BT_LOGICAL
;
10135 cond
->ts
.kind
= gfc_default_logical_kind
;
10136 cond
->expr_type
= EXPR_OP
;
10137 cond
->where
= (*code
)->loc
;
10138 cond
->value
.op
.op
= INTRINSIC_NOT
;
10139 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
10140 GFC_ISYM_ALLOCATED
, "allocated",
10141 (*code
)->loc
, 1, gfc_copy_expr (t1
));
10142 block
= gfc_get_code (EXEC_IF
);
10143 block
->block
= gfc_get_code (EXEC_IF
);
10144 block
->block
->expr1
= cond
;
10145 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10146 t1
, (*code
)->expr1
,
10147 NULL
, NULL
, (*code
)->loc
);
10148 add_code_to_chain (&block
, &head
, &tail
);
10152 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10154 /* Don't add intrinsic assignments since they are already
10155 effected by the intrinsic assignment of the structure. */
10156 gfc_free_statements (this_code
);
10161 add_code_to_chain (&this_code
, &head
, &tail
);
10165 /* Transfer the value to the final result. */
10166 this_code
= build_assignment (EXEC_ASSIGN
,
10167 (*code
)->expr1
, t1
,
10168 comp1
, comp2
, (*code
)->loc
);
10169 add_code_to_chain (&this_code
, &head
, &tail
);
10173 /* Put the temporary assignments at the top of the generated code. */
10174 if (tmp_head
&& component_assignment_level
== 1)
10176 gfc_append_code (tmp_head
, head
);
10178 tmp_head
= tmp_tail
= NULL
;
10181 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10182 // not accidentally deallocated. Hence, nullify t1.
10183 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
10184 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
10190 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
10191 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
10192 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
10193 block
= gfc_get_code (EXEC_IF
);
10194 block
->block
= gfc_get_code (EXEC_IF
);
10195 block
->block
->expr1
= cond
;
10196 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
10197 t1
, gfc_get_null_expr (&(*code
)->loc
),
10198 NULL
, NULL
, (*code
)->loc
);
10199 gfc_append_code (tail
, block
);
10203 /* Now attach the remaining code chain to the input code. Step on
10204 to the end of the new code since resolution is complete. */
10205 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10206 tail
->next
= (*code
)->next
;
10207 /* Overwrite 'code' because this would place the intrinsic assignment
10208 before the temporary for the lhs is created. */
10209 gfc_free_expr ((*code
)->expr1
);
10210 gfc_free_expr ((*code
)->expr2
);
10216 component_assignment_level
--;
10220 /* F2008: Pointer function assignments are of the form:
10221 ptr_fcn (args) = expr
10222 This function breaks these assignments into two statements:
10223 temporary_pointer => ptr_fcn(args)
10224 temporary_pointer = expr */
10227 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
10229 gfc_expr
*tmp_ptr_expr
;
10230 gfc_code
*this_code
;
10231 gfc_component
*comp
;
10234 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
10237 /* Even if standard does not support this feature, continue to build
10238 the two statements to avoid upsetting frontend_passes.c. */
10239 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
10240 "%L", &(*code
)->loc
);
10242 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
10245 s
= comp
->ts
.interface
;
10247 s
= (*code
)->expr1
->symtree
->n
.sym
;
10249 if (s
== NULL
|| !s
->result
->attr
.pointer
)
10251 gfc_error ("The function result on the lhs of the assignment at "
10252 "%L must have the pointer attribute.",
10253 &(*code
)->expr1
->where
);
10254 (*code
)->op
= EXEC_NOP
;
10258 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
10260 /* get_temp_from_expression is set up for ordinary assignments. To that
10261 end, where array bounds are not known, arrays are made allocatable.
10262 Change the temporary to a pointer here. */
10263 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
10264 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
10265 tmp_ptr_expr
->where
= (*code
)->loc
;
10267 this_code
= build_assignment (EXEC_ASSIGN
,
10268 tmp_ptr_expr
, (*code
)->expr2
,
10269 NULL
, NULL
, (*code
)->loc
);
10270 this_code
->next
= (*code
)->next
;
10271 (*code
)->next
= this_code
;
10272 (*code
)->op
= EXEC_POINTER_ASSIGN
;
10273 (*code
)->expr2
= (*code
)->expr1
;
10274 (*code
)->expr1
= tmp_ptr_expr
;
10280 /* Deferred character length assignments from an operator expression
10281 require a temporary because the character length of the lhs can
10282 change in the course of the assignment. */
10285 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
10287 gfc_expr
*tmp_expr
;
10288 gfc_code
*this_code
;
10290 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
10291 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
10292 && (*code
)->expr2
->expr_type
== EXPR_OP
))
10295 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
10298 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10299 tmp_expr
->where
= (*code
)->loc
;
10301 /* A new charlen is required to ensure that the variable string
10302 length is different to that of the original lhs. */
10303 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
10304 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
10305 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
10306 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
10308 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
10310 this_code
= build_assignment (EXEC_ASSIGN
,
10312 gfc_copy_expr (tmp_expr
),
10313 NULL
, NULL
, (*code
)->loc
);
10315 (*code
)->expr1
= tmp_expr
;
10317 this_code
->next
= (*code
)->next
;
10318 (*code
)->next
= this_code
;
10324 /* Given a block of code, recursively resolve everything pointed to by this
10328 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10330 int omp_workshare_save
;
10331 int forall_save
, do_concurrent_save
;
10335 frame
.prev
= cs_base
;
10339 find_reachable_labels (code
);
10341 for (; code
; code
= code
->next
)
10343 frame
.current
= code
;
10344 forall_save
= forall_flag
;
10345 do_concurrent_save
= gfc_do_concurrent_flag
;
10347 if (code
->op
== EXEC_FORALL
)
10350 gfc_resolve_forall (code
, ns
, forall_save
);
10353 else if (code
->block
)
10355 omp_workshare_save
= -1;
10358 case EXEC_OACC_PARALLEL_LOOP
:
10359 case EXEC_OACC_PARALLEL
:
10360 case EXEC_OACC_KERNELS_LOOP
:
10361 case EXEC_OACC_KERNELS
:
10362 case EXEC_OACC_DATA
:
10363 case EXEC_OACC_HOST_DATA
:
10364 case EXEC_OACC_LOOP
:
10365 gfc_resolve_oacc_blocks (code
, ns
);
10367 case EXEC_OMP_PARALLEL_WORKSHARE
:
10368 omp_workshare_save
= omp_workshare_flag
;
10369 omp_workshare_flag
= 1;
10370 gfc_resolve_omp_parallel_blocks (code
, ns
);
10372 case EXEC_OMP_PARALLEL
:
10373 case EXEC_OMP_PARALLEL_DO
:
10374 case EXEC_OMP_PARALLEL_DO_SIMD
:
10375 case EXEC_OMP_PARALLEL_SECTIONS
:
10376 case EXEC_OMP_TARGET_TEAMS
:
10377 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10378 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10379 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10380 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10381 case EXEC_OMP_TASK
:
10382 case EXEC_OMP_TEAMS
:
10383 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10384 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10385 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10386 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10387 omp_workshare_save
= omp_workshare_flag
;
10388 omp_workshare_flag
= 0;
10389 gfc_resolve_omp_parallel_blocks (code
, ns
);
10391 case EXEC_OMP_DISTRIBUTE
:
10392 case EXEC_OMP_DISTRIBUTE_SIMD
:
10394 case EXEC_OMP_DO_SIMD
:
10395 case EXEC_OMP_SIMD
:
10396 gfc_resolve_omp_do_blocks (code
, ns
);
10398 case EXEC_SELECT_TYPE
:
10399 /* Blocks are handled in resolve_select_type because we have
10400 to transform the SELECT TYPE into ASSOCIATE first. */
10402 case EXEC_DO_CONCURRENT
:
10403 gfc_do_concurrent_flag
= 1;
10404 gfc_resolve_blocks (code
->block
, ns
);
10405 gfc_do_concurrent_flag
= 2;
10407 case EXEC_OMP_WORKSHARE
:
10408 omp_workshare_save
= omp_workshare_flag
;
10409 omp_workshare_flag
= 1;
10412 gfc_resolve_blocks (code
->block
, ns
);
10416 if (omp_workshare_save
!= -1)
10417 omp_workshare_flag
= omp_workshare_save
;
10421 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10422 t
= gfc_resolve_expr (code
->expr1
);
10423 forall_flag
= forall_save
;
10424 gfc_do_concurrent_flag
= do_concurrent_save
;
10426 if (!gfc_resolve_expr (code
->expr2
))
10429 if (code
->op
== EXEC_ALLOCATE
10430 && !gfc_resolve_expr (code
->expr3
))
10436 case EXEC_END_BLOCK
:
10437 case EXEC_END_NESTED_BLOCK
:
10441 case EXEC_ERROR_STOP
:
10443 case EXEC_CONTINUE
:
10445 case EXEC_ASSIGN_CALL
:
10448 case EXEC_CRITICAL
:
10449 resolve_critical (code
);
10452 case EXEC_SYNC_ALL
:
10453 case EXEC_SYNC_IMAGES
:
10454 case EXEC_SYNC_MEMORY
:
10455 resolve_sync (code
);
10460 case EXEC_EVENT_POST
:
10461 case EXEC_EVENT_WAIT
:
10462 resolve_lock_unlock_event (code
);
10466 /* Keep track of which entry we are up to. */
10467 current_entry_id
= code
->ext
.entry
->id
;
10471 resolve_where (code
, NULL
);
10475 if (code
->expr1
!= NULL
)
10477 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10478 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10479 "INTEGER variable", &code
->expr1
->where
);
10480 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10481 gfc_error ("Variable %qs has not been assigned a target "
10482 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10483 &code
->expr1
->where
);
10486 resolve_branch (code
->label1
, code
);
10490 if (code
->expr1
!= NULL
10491 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10492 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10493 "INTEGER return specifier", &code
->expr1
->where
);
10496 case EXEC_INIT_ASSIGN
:
10497 case EXEC_END_PROCEDURE
:
10504 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10506 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10507 && code
->expr1
->value
.function
.isym
10508 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10509 remove_caf_get_intrinsic (code
->expr1
);
10511 /* If this is a pointer function in an lvalue variable context,
10512 the new code will have to be resolved afresh. This is also the
10513 case with an error, where the code is transformed into NOP to
10514 prevent ICEs downstream. */
10515 if (resolve_ptr_fcn_assign (&code
, ns
)
10516 || code
->op
== EXEC_NOP
)
10519 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10523 if (resolve_ordinary_assign (code
, ns
))
10525 if (code
->op
== EXEC_COMPCALL
)
10531 /* Check for dependencies in deferred character length array
10532 assignments and generate a temporary, if necessary. */
10533 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
10536 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10537 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10538 && code
->expr1
->ts
.u
.derived
10539 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10540 generate_component_assignments (&code
, ns
);
10544 case EXEC_LABEL_ASSIGN
:
10545 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10546 gfc_error ("Label %d referenced at %L is never defined",
10547 code
->label1
->value
, &code
->label1
->where
);
10549 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10550 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10551 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10552 != gfc_default_integer_kind
10553 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10554 gfc_error ("ASSIGN statement at %L requires a scalar "
10555 "default INTEGER variable", &code
->expr1
->where
);
10558 case EXEC_POINTER_ASSIGN
:
10565 /* This is both a variable definition and pointer assignment
10566 context, so check both of them. For rank remapping, a final
10567 array ref may be present on the LHS and fool gfc_expr_attr
10568 used in gfc_check_vardef_context. Remove it. */
10569 e
= remove_last_array_ref (code
->expr1
);
10570 t
= gfc_check_vardef_context (e
, true, false, false,
10571 _("pointer assignment"));
10573 t
= gfc_check_vardef_context (e
, false, false, false,
10574 _("pointer assignment"));
10579 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10583 case EXEC_ARITHMETIC_IF
:
10585 gfc_expr
*e
= code
->expr1
;
10587 gfc_resolve_expr (e
);
10588 if (e
->expr_type
== EXPR_NULL
)
10589 gfc_error ("Invalid NULL at %L", &e
->where
);
10591 if (t
&& (e
->rank
> 0
10592 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
10593 gfc_error ("Arithmetic IF statement at %L requires a scalar "
10594 "REAL or INTEGER expression", &e
->where
);
10596 resolve_branch (code
->label1
, code
);
10597 resolve_branch (code
->label2
, code
);
10598 resolve_branch (code
->label3
, code
);
10603 if (t
&& code
->expr1
!= NULL
10604 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10605 || code
->expr1
->rank
!= 0))
10606 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10607 &code
->expr1
->where
);
10612 resolve_call (code
);
10615 case EXEC_COMPCALL
:
10617 resolve_typebound_subroutine (code
);
10620 case EXEC_CALL_PPC
:
10621 resolve_ppc_call (code
);
10625 /* Select is complicated. Also, a SELECT construct could be
10626 a transformed computed GOTO. */
10627 resolve_select (code
, false);
10630 case EXEC_SELECT_TYPE
:
10631 resolve_select_type (code
, ns
);
10635 resolve_block_construct (code
);
10639 if (code
->ext
.iterator
!= NULL
)
10641 gfc_iterator
*iter
= code
->ext
.iterator
;
10642 if (gfc_resolve_iterator (iter
, true, false))
10643 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10647 case EXEC_DO_WHILE
:
10648 if (code
->expr1
== NULL
)
10649 gfc_internal_error ("gfc_resolve_code(): No expression on "
10652 && (code
->expr1
->rank
!= 0
10653 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10654 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10655 "a scalar LOGICAL expression", &code
->expr1
->where
);
10658 case EXEC_ALLOCATE
:
10660 resolve_allocate_deallocate (code
, "ALLOCATE");
10664 case EXEC_DEALLOCATE
:
10666 resolve_allocate_deallocate (code
, "DEALLOCATE");
10671 if (!gfc_resolve_open (code
->ext
.open
))
10674 resolve_branch (code
->ext
.open
->err
, code
);
10678 if (!gfc_resolve_close (code
->ext
.close
))
10681 resolve_branch (code
->ext
.close
->err
, code
);
10684 case EXEC_BACKSPACE
:
10688 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10691 resolve_branch (code
->ext
.filepos
->err
, code
);
10695 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10698 resolve_branch (code
->ext
.inquire
->err
, code
);
10701 case EXEC_IOLENGTH
:
10702 gcc_assert (code
->ext
.inquire
!= NULL
);
10703 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10706 resolve_branch (code
->ext
.inquire
->err
, code
);
10710 if (!gfc_resolve_wait (code
->ext
.wait
))
10713 resolve_branch (code
->ext
.wait
->err
, code
);
10714 resolve_branch (code
->ext
.wait
->end
, code
);
10715 resolve_branch (code
->ext
.wait
->eor
, code
);
10720 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10723 resolve_branch (code
->ext
.dt
->err
, code
);
10724 resolve_branch (code
->ext
.dt
->end
, code
);
10725 resolve_branch (code
->ext
.dt
->eor
, code
);
10728 case EXEC_TRANSFER
:
10729 resolve_transfer (code
);
10732 case EXEC_DO_CONCURRENT
:
10734 resolve_forall_iterators (code
->ext
.forall_iterator
);
10736 if (code
->expr1
!= NULL
10737 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10738 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10739 "expression", &code
->expr1
->where
);
10742 case EXEC_OACC_PARALLEL_LOOP
:
10743 case EXEC_OACC_PARALLEL
:
10744 case EXEC_OACC_KERNELS_LOOP
:
10745 case EXEC_OACC_KERNELS
:
10746 case EXEC_OACC_DATA
:
10747 case EXEC_OACC_HOST_DATA
:
10748 case EXEC_OACC_LOOP
:
10749 case EXEC_OACC_UPDATE
:
10750 case EXEC_OACC_WAIT
:
10751 case EXEC_OACC_CACHE
:
10752 case EXEC_OACC_ENTER_DATA
:
10753 case EXEC_OACC_EXIT_DATA
:
10754 case EXEC_OACC_ATOMIC
:
10755 case EXEC_OACC_DECLARE
:
10756 gfc_resolve_oacc_directive (code
, ns
);
10759 case EXEC_OMP_ATOMIC
:
10760 case EXEC_OMP_BARRIER
:
10761 case EXEC_OMP_CANCEL
:
10762 case EXEC_OMP_CANCELLATION_POINT
:
10763 case EXEC_OMP_CRITICAL
:
10764 case EXEC_OMP_FLUSH
:
10765 case EXEC_OMP_DISTRIBUTE
:
10766 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10767 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10768 case EXEC_OMP_DISTRIBUTE_SIMD
:
10770 case EXEC_OMP_DO_SIMD
:
10771 case EXEC_OMP_MASTER
:
10772 case EXEC_OMP_ORDERED
:
10773 case EXEC_OMP_SECTIONS
:
10774 case EXEC_OMP_SIMD
:
10775 case EXEC_OMP_SINGLE
:
10776 case EXEC_OMP_TARGET
:
10777 case EXEC_OMP_TARGET_DATA
:
10778 case EXEC_OMP_TARGET_TEAMS
:
10779 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10780 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10781 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10782 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10783 case EXEC_OMP_TARGET_UPDATE
:
10784 case EXEC_OMP_TASK
:
10785 case EXEC_OMP_TASKGROUP
:
10786 case EXEC_OMP_TASKWAIT
:
10787 case EXEC_OMP_TASKYIELD
:
10788 case EXEC_OMP_TEAMS
:
10789 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10790 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10791 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10792 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10793 case EXEC_OMP_WORKSHARE
:
10794 gfc_resolve_omp_directive (code
, ns
);
10797 case EXEC_OMP_PARALLEL
:
10798 case EXEC_OMP_PARALLEL_DO
:
10799 case EXEC_OMP_PARALLEL_DO_SIMD
:
10800 case EXEC_OMP_PARALLEL_SECTIONS
:
10801 case EXEC_OMP_PARALLEL_WORKSHARE
:
10802 omp_workshare_save
= omp_workshare_flag
;
10803 omp_workshare_flag
= 0;
10804 gfc_resolve_omp_directive (code
, ns
);
10805 omp_workshare_flag
= omp_workshare_save
;
10809 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10813 cs_base
= frame
.prev
;
10817 /* Resolve initial values and make sure they are compatible with
10821 resolve_values (gfc_symbol
*sym
)
10825 if (sym
->value
== NULL
)
10828 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10829 t
= resolve_structure_cons (sym
->value
, 1);
10831 t
= gfc_resolve_expr (sym
->value
);
10836 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10840 /* Verify any BIND(C) derived types in the namespace so we can report errors
10841 for them once, rather than for each variable declared of that type. */
10844 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10846 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10847 && derived_sym
->attr
.is_bind_c
== 1)
10848 verify_bind_c_derived_type (derived_sym
);
10854 /* Verify that any binding labels used in a given namespace do not collide
10855 with the names or binding labels of any global symbols. Multiple INTERFACE
10856 for the same procedure are permitted. */
10859 gfc_verify_binding_labels (gfc_symbol
*sym
)
10862 const char *module
;
10864 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10865 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10868 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10871 module
= sym
->module
;
10872 else if (sym
->ns
&& sym
->ns
->proc_name
10873 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10874 module
= sym
->ns
->proc_name
->name
;
10875 else if (sym
->ns
&& sym
->ns
->parent
10876 && sym
->ns
&& sym
->ns
->parent
->proc_name
10877 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10878 module
= sym
->ns
->parent
->proc_name
->name
;
10884 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10887 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10888 gsym
->where
= sym
->declared_at
;
10889 gsym
->sym_name
= sym
->name
;
10890 gsym
->binding_label
= sym
->binding_label
;
10891 gsym
->ns
= sym
->ns
;
10892 gsym
->mod_name
= module
;
10893 if (sym
->attr
.function
)
10894 gsym
->type
= GSYM_FUNCTION
;
10895 else if (sym
->attr
.subroutine
)
10896 gsym
->type
= GSYM_SUBROUTINE
;
10897 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10898 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10902 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10904 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10905 "identifier as entity at %L", sym
->name
,
10906 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10907 /* Clear the binding label to prevent checking multiple times. */
10908 sym
->binding_label
= NULL
;
10911 else if (sym
->attr
.flavor
== FL_VARIABLE
&& module
10912 && (strcmp (module
, gsym
->mod_name
) != 0
10913 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10915 /* This can only happen if the variable is defined in a module - if it
10916 isn't the same module, reject it. */
10917 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10918 "the same global identifier as entity at %L from module %s",
10919 sym
->name
, module
, sym
->binding_label
,
10920 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10921 sym
->binding_label
= NULL
;
10923 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10924 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10925 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10926 && sym
!= gsym
->ns
->proc_name
10927 && (module
!= gsym
->mod_name
10928 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10929 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10931 /* Print an error if the procedure is defined multiple times; we have to
10932 exclude references to the same procedure via module association or
10933 multiple checks for the same procedure. */
10934 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10935 "global identifier as entity at %L", sym
->name
,
10936 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10937 sym
->binding_label
= NULL
;
10942 /* Resolve an index expression. */
10945 resolve_index_expr (gfc_expr
*e
)
10947 if (!gfc_resolve_expr (e
))
10950 if (!gfc_simplify_expr (e
, 0))
10953 if (!gfc_specification_expr (e
))
10960 /* Resolve a charlen structure. */
10963 resolve_charlen (gfc_charlen
*cl
)
10966 bool saved_specification_expr
;
10972 saved_specification_expr
= specification_expr
;
10973 specification_expr
= true;
10975 if (cl
->length_from_typespec
)
10977 if (!gfc_resolve_expr (cl
->length
))
10979 specification_expr
= saved_specification_expr
;
10983 if (!gfc_simplify_expr (cl
->length
, 0))
10985 specification_expr
= saved_specification_expr
;
10992 if (!resolve_index_expr (cl
->length
))
10994 specification_expr
= saved_specification_expr
;
10999 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11000 a negative value, the length of character entities declared is zero. */
11001 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
11002 gfc_replace_expr (cl
->length
,
11003 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
11005 /* Check that the character length is not too large. */
11006 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11007 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11008 && cl
->length
->ts
.type
== BT_INTEGER
11009 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11011 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11012 specification_expr
= saved_specification_expr
;
11016 specification_expr
= saved_specification_expr
;
11021 /* Test for non-constant shape arrays. */
11024 is_non_constant_shape_array (gfc_symbol
*sym
)
11030 not_constant
= false;
11031 if (sym
->as
!= NULL
)
11033 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11034 has not been simplified; parameter array references. Do the
11035 simplification now. */
11036 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
11038 e
= sym
->as
->lower
[i
];
11039 if (e
&& (!resolve_index_expr(e
)
11040 || !gfc_is_constant_expr (e
)))
11041 not_constant
= true;
11042 e
= sym
->as
->upper
[i
];
11043 if (e
&& (!resolve_index_expr(e
)
11044 || !gfc_is_constant_expr (e
)))
11045 not_constant
= true;
11048 return not_constant
;
11051 /* Given a symbol and an initialization expression, add code to initialize
11052 the symbol to the function entry. */
11054 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
11058 gfc_namespace
*ns
= sym
->ns
;
11060 /* Search for the function namespace if this is a contained
11061 function without an explicit result. */
11062 if (sym
->attr
.function
&& sym
== sym
->result
11063 && sym
->name
!= sym
->ns
->proc_name
->name
)
11065 ns
= ns
->contained
;
11066 for (;ns
; ns
= ns
->sibling
)
11067 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
11073 gfc_free_expr (init
);
11077 /* Build an l-value expression for the result. */
11078 lval
= gfc_lval_expr_from_sym (sym
);
11080 /* Add the code at scope entry. */
11081 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
11082 init_st
->next
= ns
->code
;
11083 ns
->code
= init_st
;
11085 /* Assign the default initializer to the l-value. */
11086 init_st
->loc
= sym
->declared_at
;
11087 init_st
->expr1
= lval
;
11088 init_st
->expr2
= init
;
11091 /* Assign the default initializer to a derived type variable or result. */
11094 apply_default_init (gfc_symbol
*sym
)
11096 gfc_expr
*init
= NULL
;
11098 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11101 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
11102 init
= gfc_default_initializer (&sym
->ts
);
11104 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
11107 build_init_assign (sym
, init
);
11108 sym
->attr
.referenced
= 1;
11111 /* Build an initializer for a local integer, real, complex, logical, or
11112 character variable, based on the command line flags finit-local-zero,
11113 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
11114 null if the symbol should not have a default initialization. */
11116 build_default_init_expr (gfc_symbol
*sym
)
11119 gfc_expr
*init_expr
;
11122 /* These symbols should never have a default initialization. */
11123 if (sym
->attr
.allocatable
11124 || sym
->attr
.external
11126 || sym
->attr
.pointer
11127 || sym
->attr
.in_equivalence
11128 || sym
->attr
.in_common
11131 || sym
->attr
.cray_pointee
11132 || sym
->attr
.cray_pointer
11136 /* Now we'll try to build an initializer expression. */
11137 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
11138 &sym
->declared_at
);
11140 /* We will only initialize integers, reals, complex, logicals, and
11141 characters, and only if the corresponding command-line flags
11142 were set. Otherwise, we free init_expr and return null. */
11143 switch (sym
->ts
.type
)
11146 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
11147 mpz_set_si (init_expr
->value
.integer
,
11148 gfc_option
.flag_init_integer_value
);
11151 gfc_free_expr (init_expr
);
11157 switch (flag_init_real
)
11159 case GFC_INIT_REAL_SNAN
:
11160 init_expr
->is_snan
= 1;
11161 /* Fall through. */
11162 case GFC_INIT_REAL_NAN
:
11163 mpfr_set_nan (init_expr
->value
.real
);
11166 case GFC_INIT_REAL_INF
:
11167 mpfr_set_inf (init_expr
->value
.real
, 1);
11170 case GFC_INIT_REAL_NEG_INF
:
11171 mpfr_set_inf (init_expr
->value
.real
, -1);
11174 case GFC_INIT_REAL_ZERO
:
11175 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
11179 gfc_free_expr (init_expr
);
11186 switch (flag_init_real
)
11188 case GFC_INIT_REAL_SNAN
:
11189 init_expr
->is_snan
= 1;
11190 /* Fall through. */
11191 case GFC_INIT_REAL_NAN
:
11192 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
11193 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
11196 case GFC_INIT_REAL_INF
:
11197 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
11198 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
11201 case GFC_INIT_REAL_NEG_INF
:
11202 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
11203 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
11206 case GFC_INIT_REAL_ZERO
:
11207 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
11211 gfc_free_expr (init_expr
);
11218 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
11219 init_expr
->value
.logical
= 0;
11220 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
11221 init_expr
->value
.logical
= 1;
11224 gfc_free_expr (init_expr
);
11230 /* For characters, the length must be constant in order to
11231 create a default initializer. */
11232 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
11233 && sym
->ts
.u
.cl
->length
11234 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11236 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
11237 init_expr
->value
.character
.length
= char_len
;
11238 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
11239 for (i
= 0; i
< char_len
; i
++)
11240 init_expr
->value
.character
.string
[i
]
11241 = (unsigned char) gfc_option
.flag_init_character_value
;
11245 gfc_free_expr (init_expr
);
11248 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
11249 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
11251 gfc_actual_arglist
*arg
;
11252 init_expr
= gfc_get_expr ();
11253 init_expr
->where
= sym
->declared_at
;
11254 init_expr
->ts
= sym
->ts
;
11255 init_expr
->expr_type
= EXPR_FUNCTION
;
11256 init_expr
->value
.function
.isym
=
11257 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
11258 init_expr
->value
.function
.name
= "repeat";
11259 arg
= gfc_get_actual_arglist ();
11260 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
11262 arg
->expr
->value
.character
.string
[0]
11263 = gfc_option
.flag_init_character_value
;
11264 arg
->next
= gfc_get_actual_arglist ();
11265 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
11266 init_expr
->value
.function
.actual
= arg
;
11271 gfc_free_expr (init_expr
);
11277 /* Add an initialization expression to a local variable. */
11279 apply_default_init_local (gfc_symbol
*sym
)
11281 gfc_expr
*init
= NULL
;
11283 /* The symbol should be a variable or a function return value. */
11284 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11285 || (sym
->attr
.function
&& sym
->result
!= sym
))
11288 /* Try to build the initializer expression. If we can't initialize
11289 this symbol, then init will be NULL. */
11290 init
= build_default_init_expr (sym
);
11294 /* For saved variables, we don't want to add an initializer at function
11295 entry, so we just add a static initializer. Note that automatic variables
11296 are stack allocated even with -fno-automatic; we have also to exclude
11297 result variable, which are also nonstatic. */
11298 if (sym
->attr
.save
|| sym
->ns
->save_all
11299 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
11300 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
11301 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
11303 /* Don't clobber an existing initializer! */
11304 gcc_assert (sym
->value
== NULL
);
11309 build_init_assign (sym
, init
);
11313 /* Resolution of common features of flavors variable and procedure. */
11316 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11318 gfc_array_spec
*as
;
11320 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11321 as
= CLASS_DATA (sym
)->as
;
11325 /* Constraints on deferred shape variable. */
11326 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11328 bool pointer
, allocatable
, dimension
;
11330 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11332 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11333 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11334 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11338 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11339 allocatable
= sym
->attr
.allocatable
;
11340 dimension
= sym
->attr
.dimension
;
11345 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11347 gfc_error ("Allocatable array %qs at %L must have a deferred "
11348 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11351 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11352 "%qs at %L may not be ALLOCATABLE",
11353 sym
->name
, &sym
->declared_at
))
11357 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11359 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11360 "assumed rank", sym
->name
, &sym
->declared_at
);
11366 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11367 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11369 gfc_error ("Array %qs at %L cannot have a deferred shape",
11370 sym
->name
, &sym
->declared_at
);
11375 /* Constraints on polymorphic variables. */
11376 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11379 if (sym
->attr
.class_ok
11380 && !sym
->attr
.select_type_temporary
11381 && !UNLIMITED_POLY (sym
)
11382 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11384 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11385 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11386 &sym
->declared_at
);
11391 /* Assume that use associated symbols were checked in the module ns.
11392 Class-variables that are associate-names are also something special
11393 and excepted from the test. */
11394 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11396 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11397 "or pointer", sym
->name
, &sym
->declared_at
);
11406 /* Additional checks for symbols with flavor variable and derived
11407 type. To be called from resolve_fl_variable. */
11410 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11412 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11414 /* Check to see if a derived type is blocked from being host
11415 associated by the presence of another class I symbol in the same
11416 namespace. 14.6.1.3 of the standard and the discussion on
11417 comp.lang.fortran. */
11418 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11419 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11422 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11423 if (s
&& s
->attr
.generic
)
11424 s
= gfc_find_dt_in_generic (s
);
11425 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11427 gfc_error ("The type %qs cannot be host associated at %L "
11428 "because it is blocked by an incompatible object "
11429 "of the same name declared at %L",
11430 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11436 /* 4th constraint in section 11.3: "If an object of a type for which
11437 component-initialization is specified (R429) appears in the
11438 specification-part of a module and does not have the ALLOCATABLE
11439 or POINTER attribute, the object shall have the SAVE attribute."
11441 The check for initializers is performed with
11442 gfc_has_default_initializer because gfc_default_initializer generates
11443 a hidden default for allocatable components. */
11444 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11445 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11446 && !sym
->ns
->save_all
&& !sym
->attr
.save
11447 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11448 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11449 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11450 "%qs at %L, needed due to the default "
11451 "initialization", sym
->name
, &sym
->declared_at
))
11454 /* Assign default initializer. */
11455 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11456 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11458 sym
->value
= gfc_default_initializer (&sym
->ts
);
11465 /* Resolve symbols with flavor variable. */
11468 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11470 int no_init_flag
, automatic_flag
;
11472 const char *auto_save_msg
;
11473 bool saved_specification_expr
;
11475 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11478 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11481 /* Set this flag to check that variables are parameters of all entries.
11482 This check is effected by the call to gfc_resolve_expr through
11483 is_non_constant_shape_array. */
11484 saved_specification_expr
= specification_expr
;
11485 specification_expr
= true;
11487 if (sym
->ns
->proc_name
11488 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11489 || sym
->ns
->proc_name
->attr
.is_main_program
)
11490 && !sym
->attr
.use_assoc
11491 && !sym
->attr
.allocatable
11492 && !sym
->attr
.pointer
11493 && is_non_constant_shape_array (sym
))
11495 /* The shape of a main program or module array needs to be
11497 gfc_error ("The module or main program array %qs at %L must "
11498 "have constant shape", sym
->name
, &sym
->declared_at
);
11499 specification_expr
= saved_specification_expr
;
11503 /* Constraints on deferred type parameter. */
11504 if (sym
->ts
.deferred
11505 && !(sym
->attr
.pointer
11506 || sym
->attr
.allocatable
11507 || sym
->attr
.omp_udr_artificial_var
))
11509 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11510 "requires either the pointer or allocatable attribute",
11511 sym
->name
, &sym
->declared_at
);
11512 specification_expr
= saved_specification_expr
;
11516 if (sym
->ts
.type
== BT_CHARACTER
)
11518 /* Make sure that character string variables with assumed length are
11519 dummy arguments. */
11520 e
= sym
->ts
.u
.cl
->length
;
11521 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11522 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11523 && !sym
->attr
.omp_udr_artificial_var
)
11525 gfc_error ("Entity with assumed character length at %L must be a "
11526 "dummy argument or a PARAMETER", &sym
->declared_at
);
11527 specification_expr
= saved_specification_expr
;
11531 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11533 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11534 specification_expr
= saved_specification_expr
;
11538 if (!gfc_is_constant_expr (e
)
11539 && !(e
->expr_type
== EXPR_VARIABLE
11540 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11542 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11543 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11544 || sym
->ns
->proc_name
->attr
.is_main_program
))
11546 gfc_error ("%qs at %L must have constant character length "
11547 "in this context", sym
->name
, &sym
->declared_at
);
11548 specification_expr
= saved_specification_expr
;
11551 if (sym
->attr
.in_common
)
11553 gfc_error ("COMMON variable %qs at %L must have constant "
11554 "character length", sym
->name
, &sym
->declared_at
);
11555 specification_expr
= saved_specification_expr
;
11561 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11562 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11564 /* Determine if the symbol may not have an initializer. */
11565 no_init_flag
= automatic_flag
= 0;
11566 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11567 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11569 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11570 && is_non_constant_shape_array (sym
))
11572 no_init_flag
= automatic_flag
= 1;
11574 /* Also, they must not have the SAVE attribute.
11575 SAVE_IMPLICIT is checked below. */
11576 if (sym
->as
&& sym
->attr
.codimension
)
11578 int corank
= sym
->as
->corank
;
11579 sym
->as
->corank
= 0;
11580 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11581 sym
->as
->corank
= corank
;
11583 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11585 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11586 specification_expr
= saved_specification_expr
;
11591 /* Ensure that any initializer is simplified. */
11593 gfc_simplify_expr (sym
->value
, 1);
11595 /* Reject illegal initializers. */
11596 if (!sym
->mark
&& sym
->value
)
11598 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11599 && CLASS_DATA (sym
)->attr
.allocatable
))
11600 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11601 sym
->name
, &sym
->declared_at
);
11602 else if (sym
->attr
.external
)
11603 gfc_error ("External %qs at %L cannot have an initializer",
11604 sym
->name
, &sym
->declared_at
);
11605 else if (sym
->attr
.dummy
11606 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11607 gfc_error ("Dummy %qs at %L cannot have an initializer",
11608 sym
->name
, &sym
->declared_at
);
11609 else if (sym
->attr
.intrinsic
)
11610 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11611 sym
->name
, &sym
->declared_at
);
11612 else if (sym
->attr
.result
)
11613 gfc_error ("Function result %qs at %L cannot have an initializer",
11614 sym
->name
, &sym
->declared_at
);
11615 else if (automatic_flag
)
11616 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11617 sym
->name
, &sym
->declared_at
);
11619 goto no_init_error
;
11620 specification_expr
= saved_specification_expr
;
11625 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11627 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11628 specification_expr
= saved_specification_expr
;
11632 specification_expr
= saved_specification_expr
;
11637 /* Compare the dummy characteristics of a module procedure interface
11638 declaration with the corresponding declaration in a submodule. */
11639 static gfc_formal_arglist
*new_formal
;
11640 static char errmsg
[200];
11643 compare_fsyms (gfc_symbol
*sym
)
11647 if (sym
== NULL
|| new_formal
== NULL
)
11650 fsym
= new_formal
->sym
;
11655 if (strcmp (sym
->name
, fsym
->name
) == 0)
11657 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
11658 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
11663 /* Resolve a procedure. */
11666 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11668 gfc_formal_arglist
*arg
;
11670 if (sym
->attr
.function
11671 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11674 if (sym
->ts
.type
== BT_CHARACTER
)
11676 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11678 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11679 && !resolve_charlen (cl
))
11682 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11683 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11685 gfc_error ("Character-valued statement function %qs at %L must "
11686 "have constant length", sym
->name
, &sym
->declared_at
);
11691 /* Ensure that derived type for are not of a private type. Internal
11692 module procedures are excluded by 2.2.3.3 - i.e., they are not
11693 externally accessible and can access all the objects accessible in
11695 if (!(sym
->ns
->parent
11696 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11697 && gfc_check_symbol_access (sym
))
11699 gfc_interface
*iface
;
11701 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11704 && arg
->sym
->ts
.type
== BT_DERIVED
11705 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11706 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11707 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11708 "and cannot be a dummy argument"
11709 " of %qs, which is PUBLIC at %L",
11710 arg
->sym
->name
, sym
->name
,
11711 &sym
->declared_at
))
11713 /* Stop this message from recurring. */
11714 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11719 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11720 PRIVATE to the containing module. */
11721 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11723 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11726 && arg
->sym
->ts
.type
== BT_DERIVED
11727 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11728 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11729 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11730 "PUBLIC interface %qs at %L "
11731 "takes dummy arguments of %qs which "
11732 "is PRIVATE", iface
->sym
->name
,
11733 sym
->name
, &iface
->sym
->declared_at
,
11734 gfc_typename(&arg
->sym
->ts
)))
11736 /* Stop this message from recurring. */
11737 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11744 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11745 && !sym
->attr
.proc_pointer
)
11747 gfc_error ("Function %qs at %L cannot have an initializer",
11748 sym
->name
, &sym
->declared_at
);
11752 /* An external symbol may not have an initializer because it is taken to be
11753 a procedure. Exception: Procedure Pointers. */
11754 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11756 gfc_error ("External object %qs at %L may not have an initializer",
11757 sym
->name
, &sym
->declared_at
);
11761 /* An elemental function is required to return a scalar 12.7.1 */
11762 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11764 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11765 "result", sym
->name
, &sym
->declared_at
);
11766 /* Reset so that the error only occurs once. */
11767 sym
->attr
.elemental
= 0;
11771 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11772 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11774 gfc_error ("Statement function %qs at %L may not have pointer or "
11775 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11779 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11780 char-len-param shall not be array-valued, pointer-valued, recursive
11781 or pure. ....snip... A character value of * may only be used in the
11782 following ways: (i) Dummy arg of procedure - dummy associates with
11783 actual length; (ii) To declare a named constant; or (iii) External
11784 function - but length must be declared in calling scoping unit. */
11785 if (sym
->attr
.function
11786 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11787 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11789 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11790 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11792 if (sym
->as
&& sym
->as
->rank
)
11793 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11794 "array-valued", sym
->name
, &sym
->declared_at
);
11796 if (sym
->attr
.pointer
)
11797 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11798 "pointer-valued", sym
->name
, &sym
->declared_at
);
11800 if (sym
->attr
.pure
)
11801 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11802 "pure", sym
->name
, &sym
->declared_at
);
11804 if (sym
->attr
.recursive
)
11805 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11806 "recursive", sym
->name
, &sym
->declared_at
);
11811 /* Appendix B.2 of the standard. Contained functions give an
11812 error anyway. Deferred character length is an F2003 feature.
11813 Don't warn on intrinsic conversion functions, which start
11814 with two underscores. */
11815 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11816 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11817 gfc_notify_std (GFC_STD_F95_OBS
,
11818 "CHARACTER(*) function %qs at %L",
11819 sym
->name
, &sym
->declared_at
);
11822 /* F2008, C1218. */
11823 if (sym
->attr
.elemental
)
11825 if (sym
->attr
.proc_pointer
)
11827 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11828 sym
->name
, &sym
->declared_at
);
11831 if (sym
->attr
.dummy
)
11833 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11834 sym
->name
, &sym
->declared_at
);
11839 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11841 gfc_formal_arglist
*curr_arg
;
11842 int has_non_interop_arg
= 0;
11844 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11845 sym
->common_block
))
11847 /* Clear these to prevent looking at them again if there was an
11849 sym
->attr
.is_bind_c
= 0;
11850 sym
->attr
.is_c_interop
= 0;
11851 sym
->ts
.is_c_interop
= 0;
11855 /* So far, no errors have been found. */
11856 sym
->attr
.is_c_interop
= 1;
11857 sym
->ts
.is_c_interop
= 1;
11860 curr_arg
= gfc_sym_get_dummy_args (sym
);
11861 while (curr_arg
!= NULL
)
11863 /* Skip implicitly typed dummy args here. */
11864 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11865 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11866 /* If something is found to fail, record the fact so we
11867 can mark the symbol for the procedure as not being
11868 BIND(C) to try and prevent multiple errors being
11870 has_non_interop_arg
= 1;
11872 curr_arg
= curr_arg
->next
;
11875 /* See if any of the arguments were not interoperable and if so, clear
11876 the procedure symbol to prevent duplicate error messages. */
11877 if (has_non_interop_arg
!= 0)
11879 sym
->attr
.is_c_interop
= 0;
11880 sym
->ts
.is_c_interop
= 0;
11881 sym
->attr
.is_bind_c
= 0;
11885 if (!sym
->attr
.proc_pointer
)
11887 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11889 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11890 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11893 if (sym
->attr
.intent
)
11895 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11896 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11899 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11901 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11902 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11905 if (sym
->attr
.external
&& sym
->attr
.function
11906 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11907 || sym
->attr
.contained
))
11909 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11910 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11913 if (strcmp ("ppr@", sym
->name
) == 0)
11915 gfc_error ("Procedure pointer result %qs at %L "
11916 "is missing the pointer attribute",
11917 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11922 /* Assume that a procedure whose body is not known has references
11923 to external arrays. */
11924 if (sym
->attr
.if_source
!= IFSRC_DECL
)
11925 sym
->attr
.array_outer_dependency
= 1;
11927 /* Compare the characteristics of a module procedure with the
11928 interface declaration. Ideally this would be done with
11929 gfc_compare_interfaces but, at present, the formal interface
11930 cannot be copied to the ts.interface. */
11931 if (sym
->attr
.module_procedure
11932 && sym
->attr
.if_source
== IFSRC_DECL
)
11935 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
11937 char *submodule_name
;
11938 strcpy (name
, sym
->ns
->proc_name
->name
);
11939 module_name
= strtok (name
, ".");
11940 submodule_name
= strtok (NULL
, ".");
11942 /* Stop the dummy characteristics test from using the interface
11943 symbol instead of 'sym'. */
11944 iface
= sym
->ts
.interface
;
11945 sym
->ts
.interface
= NULL
;
11950 /* Check the procedure characteristics. */
11951 if (sym
->attr
.pure
!= iface
->attr
.pure
)
11953 gfc_error ("Mismatch in PURE attribute between MODULE "
11954 "PROCEDURE at %L and its interface in %s",
11955 &sym
->declared_at
, module_name
);
11959 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
11961 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
11962 "PROCEDURE at %L and its interface in %s",
11963 &sym
->declared_at
, module_name
);
11967 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
11969 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
11970 "PROCEDURE at %L and its interface in %s",
11971 &sym
->declared_at
, module_name
);
11975 /* Check the result characteristics. */
11976 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
11978 gfc_error ("%s between the MODULE PROCEDURE declaration "
11979 "in module %s and the declaration at %L in "
11980 "SUBMODULE %s", errmsg
, module_name
,
11981 &sym
->declared_at
, submodule_name
);
11986 /* Check the charcateristics of the formal arguments. */
11987 if (sym
->formal
&& sym
->formal_ns
)
11989 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
11992 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
11996 sym
->ts
.interface
= iface
;
12002 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12003 been defined and we now know their defined arguments, check that they fulfill
12004 the requirements of the standard for procedures used as finalizers. */
12007 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12009 gfc_finalizer
* list
;
12010 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12011 bool result
= true;
12012 bool seen_scalar
= false;
12015 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12018 gfc_resolve_finalizers (parent
, finalizable
);
12020 /* Return early when not finalizable. Additionally, ensure that derived-type
12021 components have a their finalizables resolved. */
12022 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
12024 bool has_final
= false;
12025 for (c
= derived
->components
; c
; c
= c
->next
)
12026 if (c
->ts
.type
== BT_DERIVED
12027 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12029 bool has_final2
= false;
12030 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
12031 return false; /* Error. */
12032 has_final
= has_final
|| has_final2
;
12037 *finalizable
= false;
12042 /* Walk over the list of finalizer-procedures, check them, and if any one
12043 does not fit in with the standard's definition, print an error and remove
12044 it from the list. */
12045 prev_link
= &derived
->f2k_derived
->finalizers
;
12046 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12048 gfc_formal_arglist
*dummy_args
;
12053 /* Skip this finalizer if we already resolved it. */
12054 if (list
->proc_tree
)
12056 prev_link
= &(list
->next
);
12060 /* Check this exists and is a SUBROUTINE. */
12061 if (!list
->proc_sym
->attr
.subroutine
)
12063 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12064 list
->proc_sym
->name
, &list
->where
);
12068 /* We should have exactly one argument. */
12069 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12070 if (!dummy_args
|| dummy_args
->next
)
12072 gfc_error ("FINAL procedure at %L must have exactly one argument",
12076 arg
= dummy_args
->sym
;
12078 /* This argument must be of our type. */
12079 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12081 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12082 &arg
->declared_at
, derived
->name
);
12086 /* It must neither be a pointer nor allocatable nor optional. */
12087 if (arg
->attr
.pointer
)
12089 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12090 &arg
->declared_at
);
12093 if (arg
->attr
.allocatable
)
12095 gfc_error ("Argument of FINAL procedure at %L must not be"
12096 " ALLOCATABLE", &arg
->declared_at
);
12099 if (arg
->attr
.optional
)
12101 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12102 &arg
->declared_at
);
12106 /* It must not be INTENT(OUT). */
12107 if (arg
->attr
.intent
== INTENT_OUT
)
12109 gfc_error ("Argument of FINAL procedure at %L must not be"
12110 " INTENT(OUT)", &arg
->declared_at
);
12114 /* Warn if the procedure is non-scalar and not assumed shape. */
12115 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
12116 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
12117 gfc_warning (OPT_Wsurprising
,
12118 "Non-scalar FINAL procedure at %L should have assumed"
12119 " shape argument", &arg
->declared_at
);
12121 /* Check that it does not match in kind and rank with a FINAL procedure
12122 defined earlier. To really loop over the *earlier* declarations,
12123 we need to walk the tail of the list as new ones were pushed at the
12125 /* TODO: Handle kind parameters once they are implemented. */
12126 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
12127 for (i
= list
->next
; i
; i
= i
->next
)
12129 gfc_formal_arglist
*dummy_args
;
12131 /* Argument list might be empty; that is an error signalled earlier,
12132 but we nevertheless continued resolving. */
12133 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
12136 gfc_symbol
* i_arg
= dummy_args
->sym
;
12137 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
12138 if (i_rank
== my_rank
)
12140 gfc_error ("FINAL procedure %qs declared at %L has the same"
12141 " rank (%d) as %qs",
12142 list
->proc_sym
->name
, &list
->where
, my_rank
,
12143 i
->proc_sym
->name
);
12149 /* Is this the/a scalar finalizer procedure? */
12150 if (!arg
->as
|| arg
->as
->rank
== 0)
12151 seen_scalar
= true;
12153 /* Find the symtree for this procedure. */
12154 gcc_assert (!list
->proc_tree
);
12155 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
12157 prev_link
= &list
->next
;
12160 /* Remove wrong nodes immediately from the list so we don't risk any
12161 troubles in the future when they might fail later expectations. */
12164 *prev_link
= list
->next
;
12165 gfc_free_finalizer (i
);
12169 if (result
== false)
12172 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12173 were nodes in the list, must have been for arrays. It is surely a good
12174 idea to have a scalar version there if there's something to finalize. */
12175 if (warn_surprising
&& result
&& !seen_scalar
)
12176 gfc_warning (OPT_Wsurprising
,
12177 "Only array FINAL procedures declared for derived type %qs"
12178 " defined at %L, suggest also scalar one",
12179 derived
->name
, &derived
->declared_at
);
12181 vtab
= gfc_find_derived_vtab (derived
);
12182 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
12183 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
12186 *finalizable
= true;
12192 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12195 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
12196 const char* generic_name
, locus where
)
12198 gfc_symbol
*sym1
, *sym2
;
12199 const char *pass1
, *pass2
;
12200 gfc_formal_arglist
*dummy_args
;
12202 gcc_assert (t1
->specific
&& t2
->specific
);
12203 gcc_assert (!t1
->specific
->is_generic
);
12204 gcc_assert (!t2
->specific
->is_generic
);
12205 gcc_assert (t1
->is_operator
== t2
->is_operator
);
12207 sym1
= t1
->specific
->u
.specific
->n
.sym
;
12208 sym2
= t2
->specific
->u
.specific
->n
.sym
;
12213 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12214 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
12215 || sym1
->attr
.function
!= sym2
->attr
.function
)
12217 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12218 " GENERIC %qs at %L",
12219 sym1
->name
, sym2
->name
, generic_name
, &where
);
12223 /* Determine PASS arguments. */
12224 if (t1
->specific
->nopass
)
12226 else if (t1
->specific
->pass_arg
)
12227 pass1
= t1
->specific
->pass_arg
;
12230 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
12232 pass1
= dummy_args
->sym
->name
;
12236 if (t2
->specific
->nopass
)
12238 else if (t2
->specific
->pass_arg
)
12239 pass2
= t2
->specific
->pass_arg
;
12242 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
12244 pass2
= dummy_args
->sym
->name
;
12249 /* Compare the interfaces. */
12250 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
12251 NULL
, 0, pass1
, pass2
))
12253 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12254 sym1
->name
, sym2
->name
, generic_name
, &where
);
12262 /* Worker function for resolving a generic procedure binding; this is used to
12263 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12265 The difference between those cases is finding possible inherited bindings
12266 that are overridden, as one has to look for them in tb_sym_root,
12267 tb_uop_root or tb_op, respectively. Thus the caller must already find
12268 the super-type and set p->overridden correctly. */
12271 resolve_tb_generic_targets (gfc_symbol
* super_type
,
12272 gfc_typebound_proc
* p
, const char* name
)
12274 gfc_tbp_generic
* target
;
12275 gfc_symtree
* first_target
;
12276 gfc_symtree
* inherited
;
12278 gcc_assert (p
&& p
->is_generic
);
12280 /* Try to find the specific bindings for the symtrees in our target-list. */
12281 gcc_assert (p
->u
.generic
);
12282 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12283 if (!target
->specific
)
12285 gfc_typebound_proc
* overridden_tbp
;
12286 gfc_tbp_generic
* g
;
12287 const char* target_name
;
12289 target_name
= target
->specific_st
->name
;
12291 /* Defined for this type directly. */
12292 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
12294 target
->specific
= target
->specific_st
->n
.tb
;
12295 goto specific_found
;
12298 /* Look for an inherited specific binding. */
12301 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
12306 gcc_assert (inherited
->n
.tb
);
12307 target
->specific
= inherited
->n
.tb
;
12308 goto specific_found
;
12312 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12313 " at %L", target_name
, name
, &p
->where
);
12316 /* Once we've found the specific binding, check it is not ambiguous with
12317 other specifics already found or inherited for the same GENERIC. */
12319 gcc_assert (target
->specific
);
12321 /* This must really be a specific binding! */
12322 if (target
->specific
->is_generic
)
12324 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12325 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
12329 /* Check those already resolved on this type directly. */
12330 for (g
= p
->u
.generic
; g
; g
= g
->next
)
12331 if (g
!= target
&& g
->specific
12332 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12335 /* Check for ambiguity with inherited specific targets. */
12336 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
12337 overridden_tbp
= overridden_tbp
->overridden
)
12338 if (overridden_tbp
->is_generic
)
12340 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
12342 gcc_assert (g
->specific
);
12343 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
12349 /* If we attempt to "overwrite" a specific binding, this is an error. */
12350 if (p
->overridden
&& !p
->overridden
->is_generic
)
12352 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12353 " the same name", name
, &p
->where
);
12357 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12358 all must have the same attributes here. */
12359 first_target
= p
->u
.generic
->specific
->u
.specific
;
12360 gcc_assert (first_target
);
12361 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
12362 p
->function
= first_target
->n
.sym
->attr
.function
;
12368 /* Resolve a GENERIC procedure binding for a derived type. */
12371 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
12373 gfc_symbol
* super_type
;
12375 /* Find the overridden binding if any. */
12376 st
->n
.tb
->overridden
= NULL
;
12377 super_type
= gfc_get_derived_super_type (derived
);
12380 gfc_symtree
* overridden
;
12381 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
12384 if (overridden
&& overridden
->n
.tb
)
12385 st
->n
.tb
->overridden
= overridden
->n
.tb
;
12388 /* Resolve using worker function. */
12389 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
12393 /* Retrieve the target-procedure of an operator binding and do some checks in
12394 common for intrinsic and user-defined type-bound operators. */
12397 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
12399 gfc_symbol
* target_proc
;
12401 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
12402 target_proc
= target
->specific
->u
.specific
->n
.sym
;
12403 gcc_assert (target_proc
);
12405 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12406 if (target
->specific
->nopass
)
12408 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12412 return target_proc
;
12416 /* Resolve a type-bound intrinsic operator. */
12419 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12420 gfc_typebound_proc
* p
)
12422 gfc_symbol
* super_type
;
12423 gfc_tbp_generic
* target
;
12425 /* If there's already an error here, do nothing (but don't fail again). */
12429 /* Operators should always be GENERIC bindings. */
12430 gcc_assert (p
->is_generic
);
12432 /* Look for an overridden binding. */
12433 super_type
= gfc_get_derived_super_type (derived
);
12434 if (super_type
&& super_type
->f2k_derived
)
12435 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12438 p
->overridden
= NULL
;
12440 /* Resolve general GENERIC properties using worker function. */
12441 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
12444 /* Check the targets to be procedures of correct interface. */
12445 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12447 gfc_symbol
* target_proc
;
12449 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12453 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12456 /* Add target to non-typebound operator list. */
12457 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12458 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12460 gfc_interface
*head
, *intr
;
12461 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
12463 head
= derived
->ns
->op
[op
];
12464 intr
= gfc_get_interface ();
12465 intr
->sym
= target_proc
;
12466 intr
->where
= p
->where
;
12468 derived
->ns
->op
[op
] = intr
;
12480 /* Resolve a type-bound user operator (tree-walker callback). */
12482 static gfc_symbol
* resolve_bindings_derived
;
12483 static bool resolve_bindings_result
;
12485 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
12488 resolve_typebound_user_op (gfc_symtree
* stree
)
12490 gfc_symbol
* super_type
;
12491 gfc_tbp_generic
* target
;
12493 gcc_assert (stree
&& stree
->n
.tb
);
12495 if (stree
->n
.tb
->error
)
12498 /* Operators should always be GENERIC bindings. */
12499 gcc_assert (stree
->n
.tb
->is_generic
);
12501 /* Find overridden procedure, if any. */
12502 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12503 if (super_type
&& super_type
->f2k_derived
)
12505 gfc_symtree
* overridden
;
12506 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12507 stree
->name
, true, NULL
);
12509 if (overridden
&& overridden
->n
.tb
)
12510 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12513 stree
->n
.tb
->overridden
= NULL
;
12515 /* Resolve basically using worker function. */
12516 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12519 /* Check the targets to be functions of correct interface. */
12520 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12522 gfc_symbol
* target_proc
;
12524 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12528 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12535 resolve_bindings_result
= false;
12536 stree
->n
.tb
->error
= 1;
12540 /* Resolve the type-bound procedures for a derived type. */
12543 resolve_typebound_procedure (gfc_symtree
* stree
)
12547 gfc_symbol
* me_arg
;
12548 gfc_symbol
* super_type
;
12549 gfc_component
* comp
;
12551 gcc_assert (stree
);
12553 /* Undefined specific symbol from GENERIC target definition. */
12557 if (stree
->n
.tb
->error
)
12560 /* If this is a GENERIC binding, use that routine. */
12561 if (stree
->n
.tb
->is_generic
)
12563 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12568 /* Get the target-procedure to check it. */
12569 gcc_assert (!stree
->n
.tb
->is_generic
);
12570 gcc_assert (stree
->n
.tb
->u
.specific
);
12571 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12572 where
= stree
->n
.tb
->where
;
12574 /* Default access should already be resolved from the parser. */
12575 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12577 if (stree
->n
.tb
->deferred
)
12579 if (!check_proc_interface (proc
, &where
))
12584 /* Check for F08:C465. */
12585 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12586 || (proc
->attr
.proc
!= PROC_MODULE
12587 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12588 || proc
->attr
.abstract
)
12590 gfc_error ("%qs must be a module procedure or an external procedure with"
12591 " an explicit interface at %L", proc
->name
, &where
);
12596 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12597 stree
->n
.tb
->function
= proc
->attr
.function
;
12599 /* Find the super-type of the current derived type. We could do this once and
12600 store in a global if speed is needed, but as long as not I believe this is
12601 more readable and clearer. */
12602 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12604 /* If PASS, resolve and check arguments if not already resolved / loaded
12605 from a .mod file. */
12606 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12608 gfc_formal_arglist
*dummy_args
;
12610 dummy_args
= gfc_sym_get_dummy_args (proc
);
12611 if (stree
->n
.tb
->pass_arg
)
12613 gfc_formal_arglist
*i
;
12615 /* If an explicit passing argument name is given, walk the arg-list
12616 and look for it. */
12619 stree
->n
.tb
->pass_arg_num
= 1;
12620 for (i
= dummy_args
; i
; i
= i
->next
)
12622 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12627 ++stree
->n
.tb
->pass_arg_num
;
12632 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12634 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12635 stree
->n
.tb
->pass_arg
);
12641 /* Otherwise, take the first one; there should in fact be at least
12643 stree
->n
.tb
->pass_arg_num
= 1;
12646 gfc_error ("Procedure %qs with PASS at %L must have at"
12647 " least one argument", proc
->name
, &where
);
12650 me_arg
= dummy_args
->sym
;
12653 /* Now check that the argument-type matches and the passed-object
12654 dummy argument is generally fine. */
12656 gcc_assert (me_arg
);
12658 if (me_arg
->ts
.type
!= BT_CLASS
)
12660 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12661 " at %L", proc
->name
, &where
);
12665 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12666 != resolve_bindings_derived
)
12668 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12669 " the derived-type %qs", me_arg
->name
, proc
->name
,
12670 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12674 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12675 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12677 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12678 " scalar", proc
->name
, &where
);
12681 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12683 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12684 " be ALLOCATABLE", proc
->name
, &where
);
12687 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12689 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12690 " be POINTER", proc
->name
, &where
);
12695 /* If we are extending some type, check that we don't override a procedure
12696 flagged NON_OVERRIDABLE. */
12697 stree
->n
.tb
->overridden
= NULL
;
12700 gfc_symtree
* overridden
;
12701 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12702 stree
->name
, true, NULL
);
12706 if (overridden
->n
.tb
)
12707 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12709 if (!gfc_check_typebound_override (stree
, overridden
))
12714 /* See if there's a name collision with a component directly in this type. */
12715 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12716 if (!strcmp (comp
->name
, stree
->name
))
12718 gfc_error ("Procedure %qs at %L has the same name as a component of"
12720 stree
->name
, &where
, resolve_bindings_derived
->name
);
12724 /* Try to find a name collision with an inherited component. */
12725 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12727 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12728 " component of %qs",
12729 stree
->name
, &where
, resolve_bindings_derived
->name
);
12733 stree
->n
.tb
->error
= 0;
12737 resolve_bindings_result
= false;
12738 stree
->n
.tb
->error
= 1;
12743 resolve_typebound_procedures (gfc_symbol
* derived
)
12746 gfc_symbol
* super_type
;
12748 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12751 super_type
= gfc_get_derived_super_type (derived
);
12753 resolve_symbol (super_type
);
12755 resolve_bindings_derived
= derived
;
12756 resolve_bindings_result
= true;
12758 if (derived
->f2k_derived
->tb_sym_root
)
12759 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12760 &resolve_typebound_procedure
);
12762 if (derived
->f2k_derived
->tb_uop_root
)
12763 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12764 &resolve_typebound_user_op
);
12766 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12768 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12769 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12770 (gfc_intrinsic_op
)op
, p
))
12771 resolve_bindings_result
= false;
12774 return resolve_bindings_result
;
12778 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12779 to give all identical derived types the same backend_decl. */
12781 add_dt_to_dt_list (gfc_symbol
*derived
)
12783 gfc_dt_list
*dt_list
;
12785 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12786 if (derived
== dt_list
->derived
)
12789 dt_list
= gfc_get_dt_list ();
12790 dt_list
->next
= gfc_derived_types
;
12791 dt_list
->derived
= derived
;
12792 gfc_derived_types
= dt_list
;
12796 /* Ensure that a derived-type is really not abstract, meaning that every
12797 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12800 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12805 if (!ensure_not_abstract_walker (sub
, st
->left
))
12807 if (!ensure_not_abstract_walker (sub
, st
->right
))
12810 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12812 gfc_symtree
* overriding
;
12813 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12816 gcc_assert (overriding
->n
.tb
);
12817 if (overriding
->n
.tb
->deferred
)
12819 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12820 " %qs is DEFERRED and not overridden",
12821 sub
->name
, &sub
->declared_at
, st
->name
);
12830 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12832 /* The algorithm used here is to recursively travel up the ancestry of sub
12833 and for each ancestor-type, check all bindings. If any of them is
12834 DEFERRED, look it up starting from sub and see if the found (overriding)
12835 binding is not DEFERRED.
12836 This is not the most efficient way to do this, but it should be ok and is
12837 clearer than something sophisticated. */
12839 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12841 if (!ancestor
->attr
.abstract
)
12844 /* Walk bindings of this ancestor. */
12845 if (ancestor
->f2k_derived
)
12848 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12853 /* Find next ancestor type and recurse on it. */
12854 ancestor
= gfc_get_derived_super_type (ancestor
);
12856 return ensure_not_abstract (sub
, ancestor
);
12862 /* This check for typebound defined assignments is done recursively
12863 since the order in which derived types are resolved is not always in
12864 order of the declarations. */
12867 check_defined_assignments (gfc_symbol
*derived
)
12871 for (c
= derived
->components
; c
; c
= c
->next
)
12873 if (c
->ts
.type
!= BT_DERIVED
12875 || c
->attr
.allocatable
12876 || c
->attr
.proc_pointer_comp
12877 || c
->attr
.class_pointer
12878 || c
->attr
.proc_pointer
)
12881 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12882 || (c
->ts
.u
.derived
->f2k_derived
12883 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12885 derived
->attr
.defined_assign_comp
= 1;
12889 check_defined_assignments (c
->ts
.u
.derived
);
12890 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12892 derived
->attr
.defined_assign_comp
= 1;
12899 /* Resolve the components of a derived type. This does not have to wait until
12900 resolution stage, but can be done as soon as the dt declaration has been
12904 resolve_fl_derived0 (gfc_symbol
*sym
)
12906 gfc_symbol
* super_type
;
12909 if (sym
->attr
.unlimited_polymorphic
)
12912 super_type
= gfc_get_derived_super_type (sym
);
12915 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12917 gfc_error ("As extending type %qs at %L has a coarray component, "
12918 "parent type %qs shall also have one", sym
->name
,
12919 &sym
->declared_at
, super_type
->name
);
12923 /* Ensure the extended type gets resolved before we do. */
12924 if (super_type
&& !resolve_fl_derived0 (super_type
))
12927 /* An ABSTRACT type must be extensible. */
12928 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12930 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12931 sym
->name
, &sym
->declared_at
);
12935 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12938 bool success
= true;
12940 for ( ; c
!= NULL
; c
= c
->next
)
12942 if (c
->attr
.artificial
)
12946 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12947 && c
->attr
.codimension
12948 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12950 gfc_error ("Coarray component %qs at %L must be allocatable with "
12951 "deferred shape", c
->name
, &c
->loc
);
12957 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12958 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12960 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12961 "shall not be a coarray", c
->name
, &c
->loc
);
12967 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12968 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12969 || c
->attr
.allocatable
))
12971 gfc_error ("Component %qs at %L with coarray component "
12972 "shall be a nonpointer, nonallocatable scalar",
12979 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12981 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12982 "is not an array pointer", c
->name
, &c
->loc
);
12987 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12989 gfc_symbol
*ifc
= c
->ts
.interface
;
12991 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
12998 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13000 /* Resolve interface and copy attributes. */
13001 if (ifc
->formal
&& !ifc
->formal_ns
)
13002 resolve_symbol (ifc
);
13003 if (ifc
->attr
.intrinsic
)
13004 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13008 c
->ts
= ifc
->result
->ts
;
13009 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13010 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13011 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13012 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13013 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13018 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13019 c
->attr
.pointer
= ifc
->attr
.pointer
;
13020 c
->attr
.dimension
= ifc
->attr
.dimension
;
13021 c
->as
= gfc_copy_array_spec (ifc
->as
);
13022 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13024 c
->ts
.interface
= ifc
;
13025 c
->attr
.function
= ifc
->attr
.function
;
13026 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13028 c
->attr
.pure
= ifc
->attr
.pure
;
13029 c
->attr
.elemental
= ifc
->attr
.elemental
;
13030 c
->attr
.recursive
= ifc
->attr
.recursive
;
13031 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13032 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13033 /* Copy char length. */
13034 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13036 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13037 if (cl
->length
&& !cl
->resolved
13038 && !gfc_resolve_expr (cl
->length
))
13048 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13050 /* Since PPCs are not implicitly typed, a PPC without an explicit
13051 interface must be a subroutine. */
13052 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13055 /* Procedure pointer components: Check PASS arg. */
13056 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13057 && !sym
->attr
.vtype
)
13059 gfc_symbol
* me_arg
;
13061 if (c
->tb
->pass_arg
)
13063 gfc_formal_arglist
* i
;
13065 /* If an explicit passing argument name is given, walk the arg-list
13066 and look for it. */
13069 c
->tb
->pass_arg_num
= 1;
13070 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13072 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13077 c
->tb
->pass_arg_num
++;
13082 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13083 "at %L has no argument %qs", c
->name
,
13084 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
13092 /* Otherwise, take the first one; there should in fact be at least
13094 c
->tb
->pass_arg_num
= 1;
13095 if (!c
->ts
.interface
->formal
)
13097 gfc_error ("Procedure pointer component %qs with PASS at %L "
13098 "must have at least one argument",
13104 me_arg
= c
->ts
.interface
->formal
->sym
;
13107 /* Now check that the argument-type matches. */
13108 gcc_assert (me_arg
);
13109 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
13110 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
13111 || (me_arg
->ts
.type
== BT_CLASS
13112 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
13114 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13115 " the derived type %qs", me_arg
->name
, c
->name
,
13116 me_arg
->name
, &c
->loc
, sym
->name
);
13122 /* Check for C453. */
13123 if (me_arg
->attr
.dimension
)
13125 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13126 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
13133 if (me_arg
->attr
.pointer
)
13135 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13136 "may not have the POINTER attribute", me_arg
->name
,
13137 c
->name
, me_arg
->name
, &c
->loc
);
13143 if (me_arg
->attr
.allocatable
)
13145 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13146 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
13147 me_arg
->name
, &c
->loc
);
13153 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
13155 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13156 " at %L", c
->name
, &c
->loc
);
13163 /* Check type-spec if this is not the parent-type component. */
13164 if (((sym
->attr
.is_class
13165 && (!sym
->components
->ts
.u
.derived
->attr
.extension
13166 || c
!= sym
->components
->ts
.u
.derived
->components
))
13167 || (!sym
->attr
.is_class
13168 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
13169 && !sym
->attr
.vtype
13170 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
13173 /* If this type is an extension, set the accessibility of the parent
13176 && ((sym
->attr
.is_class
13177 && c
== sym
->components
->ts
.u
.derived
->components
)
13178 || (!sym
->attr
.is_class
&& c
== sym
->components
))
13179 && strcmp (super_type
->name
, c
->name
) == 0)
13180 c
->attr
.access
= super_type
->attr
.access
;
13182 /* If this type is an extension, see if this component has the same name
13183 as an inherited type-bound procedure. */
13184 if (super_type
&& !sym
->attr
.is_class
13185 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
13187 gfc_error ("Component %qs of %qs at %L has the same name as an"
13188 " inherited type-bound procedure",
13189 c
->name
, sym
->name
, &c
->loc
);
13193 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
13194 && !c
->ts
.deferred
)
13196 if (c
->ts
.u
.cl
->length
== NULL
13197 || (!resolve_charlen(c
->ts
.u
.cl
))
13198 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
13200 gfc_error ("Character length of component %qs needs to "
13201 "be a constant specification expression at %L",
13203 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
13208 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
13209 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
13211 gfc_error ("Character component %qs of %qs at %L with deferred "
13212 "length must be a POINTER or ALLOCATABLE",
13213 c
->name
, sym
->name
, &c
->loc
);
13217 /* Add the hidden deferred length field. */
13218 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
13219 && !sym
->attr
.is_class
)
13221 char name
[GFC_MAX_SYMBOL_LEN
+9];
13222 gfc_component
*strlen
;
13223 sprintf (name
, "_%s_length", c
->name
);
13224 strlen
= gfc_find_component (sym
, name
, true, true);
13225 if (strlen
== NULL
)
13227 if (!gfc_add_component (sym
, name
, &strlen
))
13229 strlen
->ts
.type
= BT_INTEGER
;
13230 strlen
->ts
.kind
= gfc_charlen_int_kind
;
13231 strlen
->attr
.access
= ACCESS_PRIVATE
;
13232 strlen
->attr
.artificial
= 1;
13236 if (c
->ts
.type
== BT_DERIVED
13237 && sym
->component_access
!= ACCESS_PRIVATE
13238 && gfc_check_symbol_access (sym
)
13239 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
13240 && !c
->ts
.u
.derived
->attr
.use_assoc
13241 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
13242 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
13243 "PRIVATE type and cannot be a component of "
13244 "%qs, which is PUBLIC at %L", c
->name
,
13245 sym
->name
, &sym
->declared_at
))
13248 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
13250 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13251 "type %s", c
->name
, &c
->loc
, sym
->name
);
13255 if (sym
->attr
.sequence
)
13257 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
13259 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13260 "not have the SEQUENCE attribute",
13261 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
13266 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
13267 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
13268 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13269 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
13270 CLASS_DATA (c
)->ts
.u
.derived
13271 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
13273 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
13274 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
13275 && !c
->ts
.u
.derived
->attr
.zero_comp
)
13277 gfc_error ("The pointer component %qs of %qs at %L is a type "
13278 "that has not been declared", c
->name
, sym
->name
,
13283 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
13284 && CLASS_DATA (c
)->attr
.class_pointer
13285 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
13286 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
13287 && !UNLIMITED_POLY (c
))
13289 gfc_error ("The pointer component %qs of %qs at %L is a type "
13290 "that has not been declared", c
->name
, sym
->name
,
13296 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
13297 && (!c
->attr
.class_ok
13298 || !(CLASS_DATA (c
)->attr
.class_pointer
13299 || CLASS_DATA (c
)->attr
.allocatable
)))
13301 gfc_error ("Component %qs with CLASS at %L must be allocatable "
13302 "or pointer", c
->name
, &c
->loc
);
13303 /* Prevent a recurrence of the error. */
13304 c
->ts
.type
= BT_UNKNOWN
;
13308 /* Ensure that all the derived type components are put on the
13309 derived type list; even in formal namespaces, where derived type
13310 pointer components might not have been declared. */
13311 if (c
->ts
.type
== BT_DERIVED
13313 && c
->ts
.u
.derived
->components
13315 && sym
!= c
->ts
.u
.derived
)
13316 add_dt_to_dt_list (c
->ts
.u
.derived
);
13318 if (!gfc_resolve_array_spec (c
->as
,
13319 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
13320 || c
->attr
.allocatable
)))
13323 if (c
->initializer
&& !sym
->attr
.vtype
13324 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
13331 check_defined_assignments (sym
);
13333 if (!sym
->attr
.defined_assign_comp
&& super_type
)
13334 sym
->attr
.defined_assign_comp
13335 = super_type
->attr
.defined_assign_comp
;
13337 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13338 all DEFERRED bindings are overridden. */
13339 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
13340 && !sym
->attr
.is_class
13341 && !ensure_not_abstract (sym
, super_type
))
13344 /* Add derived type to the derived type list. */
13345 add_dt_to_dt_list (sym
);
13351 /* The following procedure does the full resolution of a derived type,
13352 including resolution of all type-bound procedures (if present). In contrast
13353 to 'resolve_fl_derived0' this can only be done after the module has been
13354 parsed completely. */
13357 resolve_fl_derived (gfc_symbol
*sym
)
13359 gfc_symbol
*gen_dt
= NULL
;
13361 if (sym
->attr
.unlimited_polymorphic
)
13364 if (!sym
->attr
.is_class
)
13365 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
13366 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
13367 && (!gen_dt
->generic
->sym
->attr
.use_assoc
13368 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
13369 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
13370 "%qs at %L being the same name as derived "
13371 "type at %L", sym
->name
,
13372 gen_dt
->generic
->sym
== sym
13373 ? gen_dt
->generic
->next
->sym
->name
13374 : gen_dt
->generic
->sym
->name
,
13375 gen_dt
->generic
->sym
== sym
13376 ? &gen_dt
->generic
->next
->sym
->declared_at
13377 : &gen_dt
->generic
->sym
->declared_at
,
13378 &sym
->declared_at
))
13381 /* Resolve the finalizer procedures. */
13382 if (!gfc_resolve_finalizers (sym
, NULL
))
13385 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
13387 /* Fix up incomplete CLASS symbols. */
13388 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
13389 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
13391 /* Nothing more to do for unlimited polymorphic entities. */
13392 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
13394 else if (vptr
->ts
.u
.derived
== NULL
)
13396 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
13398 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
13402 if (!resolve_fl_derived0 (sym
))
13405 /* Resolve the type-bound procedures. */
13406 if (!resolve_typebound_procedures (sym
))
13414 resolve_fl_namelist (gfc_symbol
*sym
)
13419 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13421 /* Check again, the check in match only works if NAMELIST comes
13423 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
13425 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13426 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13430 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
13431 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13432 "with assumed shape in namelist %qs at %L",
13433 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13436 if (is_non_constant_shape_array (nl
->sym
)
13437 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
13438 "with nonconstant shape in namelist %qs at %L",
13439 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
13442 if (nl
->sym
->ts
.type
== BT_CHARACTER
13443 && (nl
->sym
->ts
.u
.cl
->length
== NULL
13444 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13445 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
13446 "nonconstant character length in "
13447 "namelist %qs at %L", nl
->sym
->name
,
13448 sym
->name
, &sym
->declared_at
))
13451 /* FIXME: Once UDDTIO is implemented, the following can be
13453 if (nl
->sym
->ts
.type
== BT_CLASS
)
13455 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13456 "polymorphic and requires a defined input/output "
13457 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13461 if (nl
->sym
->ts
.type
== BT_DERIVED
13462 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13463 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13465 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
13466 "namelist %qs at %L with ALLOCATABLE "
13467 "or POINTER components", nl
->sym
->name
,
13468 sym
->name
, &sym
->declared_at
))
13471 /* FIXME: Once UDDTIO is implemented, the following can be
13473 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13474 "ALLOCATABLE or POINTER components and thus requires "
13475 "a defined input/output procedure", nl
->sym
->name
,
13476 sym
->name
, &sym
->declared_at
);
13481 /* Reject PRIVATE objects in a PUBLIC namelist. */
13482 if (gfc_check_symbol_access (sym
))
13484 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13486 if (!nl
->sym
->attr
.use_assoc
13487 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13488 && !gfc_check_symbol_access (nl
->sym
))
13490 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13491 "cannot be member of PUBLIC namelist %qs at %L",
13492 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13496 /* Types with private components that came here by USE-association. */
13497 if (nl
->sym
->ts
.type
== BT_DERIVED
13498 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13500 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13501 "components and cannot be member of namelist %qs at %L",
13502 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13506 /* Types with private components that are defined in the same module. */
13507 if (nl
->sym
->ts
.type
== BT_DERIVED
13508 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13509 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13511 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13512 "cannot be a member of PUBLIC namelist %qs at %L",
13513 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13520 /* 14.1.2 A module or internal procedure represent local entities
13521 of the same type as a namelist member and so are not allowed. */
13522 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13524 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13527 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13528 if ((nl
->sym
== sym
->ns
->proc_name
)
13530 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13535 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13536 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13538 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13539 "attribute in %qs at %L", nlsym
->name
,
13540 &sym
->declared_at
);
13550 resolve_fl_parameter (gfc_symbol
*sym
)
13552 /* A parameter array's shape needs to be constant. */
13553 if (sym
->as
!= NULL
13554 && (sym
->as
->type
== AS_DEFERRED
13555 || is_non_constant_shape_array (sym
)))
13557 gfc_error ("Parameter array %qs at %L cannot be automatic "
13558 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13562 /* Make sure a parameter that has been implicitly typed still
13563 matches the implicit type, since PARAMETER statements can precede
13564 IMPLICIT statements. */
13565 if (sym
->attr
.implicit_type
13566 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13569 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13570 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13574 /* Make sure the types of derived parameters are consistent. This
13575 type checking is deferred until resolution because the type may
13576 refer to a derived type from the host. */
13577 if (sym
->ts
.type
== BT_DERIVED
13578 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13580 gfc_error ("Incompatible derived type in PARAMETER at %L",
13581 &sym
->value
->where
);
13588 /* Do anything necessary to resolve a symbol. Right now, we just
13589 assume that an otherwise unknown symbol is a variable. This sort
13590 of thing commonly happens for symbols in module. */
13593 resolve_symbol (gfc_symbol
*sym
)
13595 int check_constant
, mp_flag
;
13596 gfc_symtree
*symtree
;
13597 gfc_symtree
*this_symtree
;
13600 symbol_attribute class_attr
;
13601 gfc_array_spec
*as
;
13602 bool saved_specification_expr
;
13608 if (sym
->attr
.artificial
)
13611 if (sym
->attr
.unlimited_polymorphic
)
13614 if (sym
->attr
.flavor
== FL_UNKNOWN
13615 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13616 && !sym
->attr
.generic
&& !sym
->attr
.external
13617 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13618 && sym
->ts
.type
== BT_UNKNOWN
))
13621 /* If we find that a flavorless symbol is an interface in one of the
13622 parent namespaces, find its symtree in this namespace, free the
13623 symbol and set the symtree to point to the interface symbol. */
13624 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13626 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13627 if (symtree
&& (symtree
->n
.sym
->generic
||
13628 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13629 && sym
->ns
->construct_entities
)))
13631 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13633 if (this_symtree
->n
.sym
== sym
)
13635 symtree
->n
.sym
->refs
++;
13636 gfc_release_symbol (sym
);
13637 this_symtree
->n
.sym
= symtree
->n
.sym
;
13643 /* Otherwise give it a flavor according to such attributes as
13645 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13646 && sym
->attr
.intrinsic
== 0)
13647 sym
->attr
.flavor
= FL_VARIABLE
;
13648 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13650 sym
->attr
.flavor
= FL_PROCEDURE
;
13651 if (sym
->attr
.dimension
)
13652 sym
->attr
.function
= 1;
13656 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13657 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13659 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13660 && !resolve_procedure_interface (sym
))
13663 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13664 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13666 if (sym
->attr
.external
)
13667 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13668 "at %L", &sym
->declared_at
);
13670 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13671 "at %L", &sym
->declared_at
);
13676 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13679 /* Symbols that are module procedures with results (functions) have
13680 the types and array specification copied for type checking in
13681 procedures that call them, as well as for saving to a module
13682 file. These symbols can't stand the scrutiny that their results
13684 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13686 /* Make sure that the intrinsic is consistent with its internal
13687 representation. This needs to be done before assigning a default
13688 type to avoid spurious warnings. */
13689 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13690 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13693 /* Resolve associate names. */
13695 resolve_assoc_var (sym
, true);
13697 /* Assign default type to symbols that need one and don't have one. */
13698 if (sym
->ts
.type
== BT_UNKNOWN
)
13700 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13702 gfc_set_default_type (sym
, 1, NULL
);
13705 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13706 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13707 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13708 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13710 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13712 /* The specific case of an external procedure should emit an error
13713 in the case that there is no implicit type. */
13715 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13718 /* Result may be in another namespace. */
13719 resolve_symbol (sym
->result
);
13721 if (!sym
->result
->attr
.proc_pointer
)
13723 sym
->ts
= sym
->result
->ts
;
13724 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13725 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13726 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13727 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13728 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13733 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13735 bool saved_specification_expr
= specification_expr
;
13736 specification_expr
= true;
13737 gfc_resolve_array_spec (sym
->result
->as
, false);
13738 specification_expr
= saved_specification_expr
;
13741 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13743 as
= CLASS_DATA (sym
)->as
;
13744 class_attr
= CLASS_DATA (sym
)->attr
;
13745 class_attr
.pointer
= class_attr
.class_pointer
;
13749 class_attr
= sym
->attr
;
13754 if (sym
->attr
.contiguous
13755 && (!class_attr
.dimension
13756 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13757 && !class_attr
.pointer
)))
13759 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13760 "array pointer or an assumed-shape or assumed-rank array",
13761 sym
->name
, &sym
->declared_at
);
13765 /* Assumed size arrays and assumed shape arrays must be dummy
13766 arguments. Array-spec's of implied-shape should have been resolved to
13767 AS_EXPLICIT already. */
13771 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13772 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13773 || as
->type
== AS_ASSUMED_SHAPE
)
13774 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13776 if (as
->type
== AS_ASSUMED_SIZE
)
13777 gfc_error ("Assumed size array at %L must be a dummy argument",
13778 &sym
->declared_at
);
13780 gfc_error ("Assumed shape array at %L must be a dummy argument",
13781 &sym
->declared_at
);
13784 /* TS 29113, C535a. */
13785 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13786 && !sym
->attr
.select_type_temporary
)
13788 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13789 &sym
->declared_at
);
13792 if (as
->type
== AS_ASSUMED_RANK
13793 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13795 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13796 "CODIMENSION attribute", &sym
->declared_at
);
13801 /* Make sure symbols with known intent or optional are really dummy
13802 variable. Because of ENTRY statement, this has to be deferred
13803 until resolution time. */
13805 if (!sym
->attr
.dummy
13806 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13808 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13812 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13814 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13815 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13819 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13821 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13822 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13824 gfc_error ("Character dummy variable %qs at %L with VALUE "
13825 "attribute must have constant length",
13826 sym
->name
, &sym
->declared_at
);
13830 if (sym
->ts
.is_c_interop
13831 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13833 gfc_error ("C interoperable character dummy variable %qs at %L "
13834 "with VALUE attribute must have length one",
13835 sym
->name
, &sym
->declared_at
);
13840 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13841 && sym
->ts
.u
.derived
->attr
.generic
)
13843 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13844 if (!sym
->ts
.u
.derived
)
13846 gfc_error ("The derived type %qs at %L is of type %qs, "
13847 "which has not been defined", sym
->name
,
13848 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13849 sym
->ts
.type
= BT_UNKNOWN
;
13854 /* Use the same constraints as TYPE(*), except for the type check
13855 and that only scalars and assumed-size arrays are permitted. */
13856 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13858 if (!sym
->attr
.dummy
)
13860 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13861 "a dummy argument", sym
->name
, &sym
->declared_at
);
13865 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13866 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13867 && sym
->ts
.type
!= BT_COMPLEX
)
13869 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13870 "of type TYPE(*) or of an numeric intrinsic type",
13871 sym
->name
, &sym
->declared_at
);
13875 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13876 || sym
->attr
.pointer
|| sym
->attr
.value
)
13878 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13879 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13880 "attribute", sym
->name
, &sym
->declared_at
);
13884 if (sym
->attr
.intent
== INTENT_OUT
)
13886 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13887 "have the INTENT(OUT) attribute",
13888 sym
->name
, &sym
->declared_at
);
13891 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13893 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13894 "either be a scalar or an assumed-size array",
13895 sym
->name
, &sym
->declared_at
);
13899 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13900 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13902 sym
->ts
.type
= BT_ASSUMED
;
13903 sym
->as
= gfc_get_array_spec ();
13904 sym
->as
->type
= AS_ASSUMED_SIZE
;
13906 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13908 else if (sym
->ts
.type
== BT_ASSUMED
)
13910 /* TS 29113, C407a. */
13911 if (!sym
->attr
.dummy
)
13913 gfc_error ("Assumed type of variable %s at %L is only permitted "
13914 "for dummy variables", sym
->name
, &sym
->declared_at
);
13917 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13918 || sym
->attr
.pointer
|| sym
->attr
.value
)
13920 gfc_error ("Assumed-type variable %s at %L may not have the "
13921 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13922 sym
->name
, &sym
->declared_at
);
13925 if (sym
->attr
.intent
== INTENT_OUT
)
13927 gfc_error ("Assumed-type variable %s at %L may not have the "
13928 "INTENT(OUT) attribute",
13929 sym
->name
, &sym
->declared_at
);
13932 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13934 gfc_error ("Assumed-type variable %s at %L shall not be an "
13935 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13940 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13941 do this for something that was implicitly typed because that is handled
13942 in gfc_set_default_type. Handle dummy arguments and procedure
13943 definitions separately. Also, anything that is use associated is not
13944 handled here but instead is handled in the module it is declared in.
13945 Finally, derived type definitions are allowed to be BIND(C) since that
13946 only implies that they're interoperable, and they are checked fully for
13947 interoperability when a variable is declared of that type. */
13948 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13949 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13950 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13954 /* First, make sure the variable is declared at the
13955 module-level scope (J3/04-007, Section 15.3). */
13956 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13957 sym
->attr
.in_common
== 0)
13959 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13960 "is neither a COMMON block nor declared at the "
13961 "module level scope", sym
->name
, &(sym
->declared_at
));
13964 else if (sym
->common_head
!= NULL
)
13966 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13970 /* If type() declaration, we need to verify that the components
13971 of the given type are all C interoperable, etc. */
13972 if (sym
->ts
.type
== BT_DERIVED
&&
13973 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13975 /* Make sure the user marked the derived type as BIND(C). If
13976 not, call the verify routine. This could print an error
13977 for the derived type more than once if multiple variables
13978 of that type are declared. */
13979 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13980 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13984 /* Verify the variable itself as C interoperable if it
13985 is BIND(C). It is not possible for this to succeed if
13986 the verify_bind_c_derived_type failed, so don't have to handle
13987 any error returned by verify_bind_c_derived_type. */
13988 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13989 sym
->common_block
);
13994 /* clear the is_bind_c flag to prevent reporting errors more than
13995 once if something failed. */
13996 sym
->attr
.is_bind_c
= 0;
14001 /* If a derived type symbol has reached this point, without its
14002 type being declared, we have an error. Notice that most
14003 conditions that produce undefined derived types have already
14004 been dealt with. However, the likes of:
14005 implicit type(t) (t) ..... call foo (t) will get us here if
14006 the type is not declared in the scope of the implicit
14007 statement. Change the type to BT_UNKNOWN, both because it is so
14008 and to prevent an ICE. */
14009 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
14010 && sym
->ts
.u
.derived
->components
== NULL
14011 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
14013 gfc_error ("The derived type %qs at %L is of type %qs, "
14014 "which has not been defined", sym
->name
,
14015 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14016 sym
->ts
.type
= BT_UNKNOWN
;
14020 /* Make sure that the derived type has been resolved and that the
14021 derived type is visible in the symbol's namespace, if it is a
14022 module function and is not PRIVATE. */
14023 if (sym
->ts
.type
== BT_DERIVED
14024 && sym
->ts
.u
.derived
->attr
.use_assoc
14025 && sym
->ns
->proc_name
14026 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14027 && !resolve_fl_derived (sym
->ts
.u
.derived
))
14030 /* Unless the derived-type declaration is use associated, Fortran 95
14031 does not allow public entries of private derived types.
14032 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14033 161 in 95-006r3. */
14034 if (sym
->ts
.type
== BT_DERIVED
14035 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14036 && !sym
->ts
.u
.derived
->attr
.use_assoc
14037 && gfc_check_symbol_access (sym
)
14038 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14039 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
14040 "derived type %qs",
14041 (sym
->attr
.flavor
== FL_PARAMETER
)
14042 ? "parameter" : "variable",
14043 sym
->name
, &sym
->declared_at
,
14044 sym
->ts
.u
.derived
->name
))
14047 /* F2008, C1302. */
14048 if (sym
->ts
.type
== BT_DERIVED
14049 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14050 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
14051 || sym
->ts
.u
.derived
->attr
.lock_comp
)
14052 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14054 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14055 "type LOCK_TYPE must be a coarray", sym
->name
,
14056 &sym
->declared_at
);
14060 /* TS18508, C702/C703. */
14061 if (sym
->ts
.type
== BT_DERIVED
14062 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
14063 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
14064 || sym
->ts
.u
.derived
->attr
.event_comp
)
14065 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
14067 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14068 "type LOCK_TYPE must be a coarray", sym
->name
,
14069 &sym
->declared_at
);
14073 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14074 default initialization is defined (5.1.2.4.4). */
14075 if (sym
->ts
.type
== BT_DERIVED
14077 && sym
->attr
.intent
== INTENT_OUT
14079 && sym
->as
->type
== AS_ASSUMED_SIZE
)
14081 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
14083 if (c
->initializer
)
14085 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14086 "ASSUMED SIZE and so cannot have a default initializer",
14087 sym
->name
, &sym
->declared_at
);
14094 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14095 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
14097 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14098 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14103 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
14104 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
14106 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14107 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
14112 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14113 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14114 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14115 || class_attr
.codimension
)
14116 && (sym
->attr
.result
|| sym
->result
== sym
))
14118 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14119 "a coarray component", sym
->name
, &sym
->declared_at
);
14124 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
14125 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
14127 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14128 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
14133 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14134 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14135 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14136 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
14137 || class_attr
.allocatable
))
14139 gfc_error ("Variable %qs at %L with coarray component shall be a "
14140 "nonpointer, nonallocatable scalar, which is not a coarray",
14141 sym
->name
, &sym
->declared_at
);
14145 /* F2008, C526. The function-result case was handled above. */
14146 if (class_attr
.codimension
14147 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
14148 || sym
->attr
.select_type_temporary
14149 || sym
->ns
->save_all
14150 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14151 || sym
->ns
->proc_name
->attr
.is_main_program
14152 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
14154 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14155 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
14159 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
14160 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
14162 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
14163 "deferred shape", sym
->name
, &sym
->declared_at
);
14166 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
14167 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
14169 gfc_error ("Allocatable coarray variable %qs at %L must have "
14170 "deferred shape", sym
->name
, &sym
->declared_at
);
14175 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
14176 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
14177 && CLASS_DATA (sym
)->attr
.coarray_comp
))
14178 || (class_attr
.codimension
&& class_attr
.allocatable
))
14179 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
14181 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
14182 "allocatable coarray or have coarray components",
14183 sym
->name
, &sym
->declared_at
);
14187 if (class_attr
.codimension
&& sym
->attr
.dummy
14188 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
14190 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
14191 "procedure %qs", sym
->name
, &sym
->declared_at
,
14192 sym
->ns
->proc_name
->name
);
14196 if (sym
->ts
.type
== BT_LOGICAL
14197 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
14198 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
14199 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
14202 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
14203 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
14205 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
14206 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
14207 "%L with non-C_Bool kind in BIND(C) procedure "
14208 "%qs", sym
->name
, &sym
->declared_at
,
14209 sym
->ns
->proc_name
->name
))
14211 else if (!gfc_logical_kinds
[i
].c_bool
14212 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
14213 "%qs at %L with non-C_Bool kind in "
14214 "BIND(C) procedure %qs", sym
->name
,
14216 sym
->attr
.function
? sym
->name
14217 : sym
->ns
->proc_name
->name
))
14221 switch (sym
->attr
.flavor
)
14224 if (!resolve_fl_variable (sym
, mp_flag
))
14229 if (!resolve_fl_procedure (sym
, mp_flag
))
14234 if (!resolve_fl_namelist (sym
))
14239 if (!resolve_fl_parameter (sym
))
14247 /* Resolve array specifier. Check as well some constraints
14248 on COMMON blocks. */
14250 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
14252 /* Set the formal_arg_flag so that check_conflict will not throw
14253 an error for host associated variables in the specification
14254 expression for an array_valued function. */
14255 if (sym
->attr
.function
&& sym
->as
)
14256 formal_arg_flag
= 1;
14258 saved_specification_expr
= specification_expr
;
14259 specification_expr
= true;
14260 gfc_resolve_array_spec (sym
->as
, check_constant
);
14261 specification_expr
= saved_specification_expr
;
14263 formal_arg_flag
= 0;
14265 /* Resolve formal namespaces. */
14266 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
14267 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
14268 gfc_resolve (sym
->formal_ns
);
14270 /* Make sure the formal namespace is present. */
14271 if (sym
->formal
&& !sym
->formal_ns
)
14273 gfc_formal_arglist
*formal
= sym
->formal
;
14274 while (formal
&& !formal
->sym
)
14275 formal
= formal
->next
;
14279 sym
->formal_ns
= formal
->sym
->ns
;
14280 if (sym
->ns
!= formal
->sym
->ns
)
14281 sym
->formal_ns
->refs
++;
14285 /* Check threadprivate restrictions. */
14286 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
14287 && (!sym
->attr
.in_common
14288 && sym
->module
== NULL
14289 && (sym
->ns
->proc_name
== NULL
14290 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14291 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
14293 /* Check omp declare target restrictions. */
14294 if (sym
->attr
.omp_declare_target
14295 && sym
->attr
.flavor
== FL_VARIABLE
14297 && !sym
->ns
->save_all
14298 && (!sym
->attr
.in_common
14299 && sym
->module
== NULL
14300 && (sym
->ns
->proc_name
== NULL
14301 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
14302 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14303 sym
->name
, &sym
->declared_at
);
14305 /* If we have come this far we can apply default-initializers, as
14306 described in 14.7.5, to those variables that have not already
14307 been assigned one. */
14308 if (sym
->ts
.type
== BT_DERIVED
14310 && !sym
->attr
.allocatable
14311 && !sym
->attr
.alloc_comp
)
14313 symbol_attribute
*a
= &sym
->attr
;
14315 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
14316 && !a
->in_common
&& !a
->use_assoc
14317 && !a
->result
&& !a
->function
)
14318 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
14319 apply_default_init (sym
);
14320 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
14321 && (sym
->ts
.u
.derived
->attr
.alloc_comp
14322 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
14323 /* Mark the result symbol to be referenced, when it has allocatable
14325 sym
->result
->attr
.referenced
= 1;
14328 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
14329 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
14330 && !CLASS_DATA (sym
)->attr
.class_pointer
14331 && !CLASS_DATA (sym
)->attr
.allocatable
)
14332 apply_default_init (sym
);
14334 /* If this symbol has a type-spec, check it. */
14335 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
14336 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
14337 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
14342 /************* Resolve DATA statements *************/
14346 gfc_data_value
*vnode
;
14352 /* Advance the values structure to point to the next value in the data list. */
14355 next_data_value (void)
14357 while (mpz_cmp_ui (values
.left
, 0) == 0)
14360 if (values
.vnode
->next
== NULL
)
14363 values
.vnode
= values
.vnode
->next
;
14364 mpz_set (values
.left
, values
.vnode
->repeat
);
14372 check_data_variable (gfc_data_variable
*var
, locus
*where
)
14378 ar_type mark
= AR_UNKNOWN
;
14380 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
14386 if (!gfc_resolve_expr (var
->expr
))
14390 mpz_init_set_si (offset
, 0);
14393 if (e
->expr_type
!= EXPR_VARIABLE
)
14394 gfc_internal_error ("check_data_variable(): Bad expression");
14396 sym
= e
->symtree
->n
.sym
;
14398 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
14400 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
14401 sym
->name
, &sym
->declared_at
);
14404 if (e
->ref
== NULL
&& sym
->as
)
14406 gfc_error ("DATA array %qs at %L must be specified in a previous"
14407 " declaration", sym
->name
, where
);
14411 has_pointer
= sym
->attr
.pointer
;
14413 if (gfc_is_coindexed (e
))
14415 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
14420 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14422 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
14426 && ref
->type
== REF_ARRAY
14427 && ref
->u
.ar
.type
!= AR_FULL
)
14429 gfc_error ("DATA element %qs at %L is a pointer and so must "
14430 "be a full array", sym
->name
, where
);
14435 if (e
->rank
== 0 || has_pointer
)
14437 mpz_init_set_ui (size
, 1);
14444 /* Find the array section reference. */
14445 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
14447 if (ref
->type
!= REF_ARRAY
)
14449 if (ref
->u
.ar
.type
== AR_ELEMENT
)
14455 /* Set marks according to the reference pattern. */
14456 switch (ref
->u
.ar
.type
)
14464 /* Get the start position of array section. */
14465 gfc_get_section_index (ar
, section_index
, &offset
);
14470 gcc_unreachable ();
14473 if (!gfc_array_size (e
, &size
))
14475 gfc_error ("Nonconstant array section at %L in DATA statement",
14477 mpz_clear (offset
);
14484 while (mpz_cmp_ui (size
, 0) > 0)
14486 if (!next_data_value ())
14488 gfc_error ("DATA statement at %L has more variables than values",
14494 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
14498 /* If we have more than one element left in the repeat count,
14499 and we have more than one element left in the target variable,
14500 then create a range assignment. */
14501 /* FIXME: Only done for full arrays for now, since array sections
14503 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
14504 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
14508 if (mpz_cmp (size
, values
.left
) >= 0)
14510 mpz_init_set (range
, values
.left
);
14511 mpz_sub (size
, size
, values
.left
);
14512 mpz_set_ui (values
.left
, 0);
14516 mpz_init_set (range
, size
);
14517 mpz_sub (values
.left
, values
.left
, size
);
14518 mpz_set_ui (size
, 0);
14521 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14524 mpz_add (offset
, offset
, range
);
14531 /* Assign initial value to symbol. */
14534 mpz_sub_ui (values
.left
, values
.left
, 1);
14535 mpz_sub_ui (size
, size
, 1);
14537 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14542 if (mark
== AR_FULL
)
14543 mpz_add_ui (offset
, offset
, 1);
14545 /* Modify the array section indexes and recalculate the offset
14546 for next element. */
14547 else if (mark
== AR_SECTION
)
14548 gfc_advance_section (section_index
, ar
, &offset
);
14552 if (mark
== AR_SECTION
)
14554 for (i
= 0; i
< ar
->dimen
; i
++)
14555 mpz_clear (section_index
[i
]);
14559 mpz_clear (offset
);
14565 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14567 /* Iterate over a list of elements in a DATA statement. */
14570 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14573 iterator_stack frame
;
14574 gfc_expr
*e
, *start
, *end
, *step
;
14575 bool retval
= true;
14577 mpz_init (frame
.value
);
14580 start
= gfc_copy_expr (var
->iter
.start
);
14581 end
= gfc_copy_expr (var
->iter
.end
);
14582 step
= gfc_copy_expr (var
->iter
.step
);
14584 if (!gfc_simplify_expr (start
, 1)
14585 || start
->expr_type
!= EXPR_CONSTANT
)
14587 gfc_error ("start of implied-do loop at %L could not be "
14588 "simplified to a constant value", &start
->where
);
14592 if (!gfc_simplify_expr (end
, 1)
14593 || end
->expr_type
!= EXPR_CONSTANT
)
14595 gfc_error ("end of implied-do loop at %L could not be "
14596 "simplified to a constant value", &start
->where
);
14600 if (!gfc_simplify_expr (step
, 1)
14601 || step
->expr_type
!= EXPR_CONSTANT
)
14603 gfc_error ("step of implied-do loop at %L could not be "
14604 "simplified to a constant value", &start
->where
);
14609 mpz_set (trip
, end
->value
.integer
);
14610 mpz_sub (trip
, trip
, start
->value
.integer
);
14611 mpz_add (trip
, trip
, step
->value
.integer
);
14613 mpz_div (trip
, trip
, step
->value
.integer
);
14615 mpz_set (frame
.value
, start
->value
.integer
);
14617 frame
.prev
= iter_stack
;
14618 frame
.variable
= var
->iter
.var
->symtree
;
14619 iter_stack
= &frame
;
14621 while (mpz_cmp_ui (trip
, 0) > 0)
14623 if (!traverse_data_var (var
->list
, where
))
14629 e
= gfc_copy_expr (var
->expr
);
14630 if (!gfc_simplify_expr (e
, 1))
14637 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14639 mpz_sub_ui (trip
, trip
, 1);
14643 mpz_clear (frame
.value
);
14646 gfc_free_expr (start
);
14647 gfc_free_expr (end
);
14648 gfc_free_expr (step
);
14650 iter_stack
= frame
.prev
;
14655 /* Type resolve variables in the variable list of a DATA statement. */
14658 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14662 for (; var
; var
= var
->next
)
14664 if (var
->expr
== NULL
)
14665 t
= traverse_data_list (var
, where
);
14667 t
= check_data_variable (var
, where
);
14677 /* Resolve the expressions and iterators associated with a data statement.
14678 This is separate from the assignment checking because data lists should
14679 only be resolved once. */
14682 resolve_data_variables (gfc_data_variable
*d
)
14684 for (; d
; d
= d
->next
)
14686 if (d
->list
== NULL
)
14688 if (!gfc_resolve_expr (d
->expr
))
14693 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14696 if (!resolve_data_variables (d
->list
))
14705 /* Resolve a single DATA statement. We implement this by storing a pointer to
14706 the value list into static variables, and then recursively traversing the
14707 variables list, expanding iterators and such. */
14710 resolve_data (gfc_data
*d
)
14713 if (!resolve_data_variables (d
->var
))
14716 values
.vnode
= d
->value
;
14717 if (d
->value
== NULL
)
14718 mpz_set_ui (values
.left
, 0);
14720 mpz_set (values
.left
, d
->value
->repeat
);
14722 if (!traverse_data_var (d
->var
, &d
->where
))
14725 /* At this point, we better not have any values left. */
14727 if (next_data_value ())
14728 gfc_error ("DATA statement at %L has more values than variables",
14733 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14734 accessed by host or use association, is a dummy argument to a pure function,
14735 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14736 is storage associated with any such variable, shall not be used in the
14737 following contexts: (clients of this function). */
14739 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14740 procedure. Returns zero if assignment is OK, nonzero if there is a
14743 gfc_impure_variable (gfc_symbol
*sym
)
14748 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14751 /* Check if the symbol's ns is inside the pure procedure. */
14752 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14756 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14760 proc
= sym
->ns
->proc_name
;
14761 if (sym
->attr
.dummy
14762 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14763 || proc
->attr
.function
))
14766 /* TODO: Sort out what can be storage associated, if anything, and include
14767 it here. In principle equivalences should be scanned but it does not
14768 seem to be possible to storage associate an impure variable this way. */
14773 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14774 current namespace is inside a pure procedure. */
14777 gfc_pure (gfc_symbol
*sym
)
14779 symbol_attribute attr
;
14784 /* Check if the current namespace or one of its parents
14785 belongs to a pure procedure. */
14786 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14788 sym
= ns
->proc_name
;
14792 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14800 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14804 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14805 checks if the current namespace is implicitly pure. Note that this
14806 function returns false for a PURE procedure. */
14809 gfc_implicit_pure (gfc_symbol
*sym
)
14815 /* Check if the current procedure is implicit_pure. Walk up
14816 the procedure list until we find a procedure. */
14817 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14819 sym
= ns
->proc_name
;
14823 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14828 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14829 && !sym
->attr
.pure
;
14834 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14840 /* Check if the current procedure is implicit_pure. Walk up
14841 the procedure list until we find a procedure. */
14842 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14844 sym
= ns
->proc_name
;
14848 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14853 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14854 sym
->attr
.implicit_pure
= 0;
14856 sym
->attr
.pure
= 0;
14860 /* Test whether the current procedure is elemental or not. */
14863 gfc_elemental (gfc_symbol
*sym
)
14865 symbol_attribute attr
;
14868 sym
= gfc_current_ns
->proc_name
;
14873 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14877 /* Warn about unused labels. */
14880 warn_unused_fortran_label (gfc_st_label
*label
)
14885 warn_unused_fortran_label (label
->left
);
14887 if (label
->defined
== ST_LABEL_UNKNOWN
)
14890 switch (label
->referenced
)
14892 case ST_LABEL_UNKNOWN
:
14893 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
14897 case ST_LABEL_BAD_TARGET
:
14898 gfc_warning (0, "Label %d at %L defined but cannot be used",
14899 label
->value
, &label
->where
);
14906 warn_unused_fortran_label (label
->right
);
14910 /* Returns the sequence type of a symbol or sequence. */
14913 sequence_type (gfc_typespec ts
)
14922 if (ts
.u
.derived
->components
== NULL
)
14923 return SEQ_NONDEFAULT
;
14925 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14926 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14927 if (sequence_type (c
->ts
) != result
)
14933 if (ts
.kind
!= gfc_default_character_kind
)
14934 return SEQ_NONDEFAULT
;
14936 return SEQ_CHARACTER
;
14939 if (ts
.kind
!= gfc_default_integer_kind
)
14940 return SEQ_NONDEFAULT
;
14942 return SEQ_NUMERIC
;
14945 if (!(ts
.kind
== gfc_default_real_kind
14946 || ts
.kind
== gfc_default_double_kind
))
14947 return SEQ_NONDEFAULT
;
14949 return SEQ_NUMERIC
;
14952 if (ts
.kind
!= gfc_default_complex_kind
)
14953 return SEQ_NONDEFAULT
;
14955 return SEQ_NUMERIC
;
14958 if (ts
.kind
!= gfc_default_logical_kind
)
14959 return SEQ_NONDEFAULT
;
14961 return SEQ_NUMERIC
;
14964 return SEQ_NONDEFAULT
;
14969 /* Resolve derived type EQUIVALENCE object. */
14972 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14974 gfc_component
*c
= derived
->components
;
14979 /* Shall not be an object of nonsequence derived type. */
14980 if (!derived
->attr
.sequence
)
14982 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14983 "attribute to be an EQUIVALENCE object", sym
->name
,
14988 /* Shall not have allocatable components. */
14989 if (derived
->attr
.alloc_comp
)
14991 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14992 "components to be an EQUIVALENCE object",sym
->name
,
14997 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14999 gfc_error ("Derived type variable %qs at %L with default "
15000 "initialization cannot be in EQUIVALENCE with a variable "
15001 "in COMMON", sym
->name
, &e
->where
);
15005 for (; c
; c
= c
->next
)
15007 if (c
->ts
.type
== BT_DERIVED
15008 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
15011 /* Shall not be an object of sequence derived type containing a pointer
15012 in the structure. */
15013 if (c
->attr
.pointer
)
15015 gfc_error ("Derived type variable %qs at %L with pointer "
15016 "component(s) cannot be an EQUIVALENCE object",
15017 sym
->name
, &e
->where
);
15025 /* Resolve equivalence object.
15026 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15027 an allocatable array, an object of nonsequence derived type, an object of
15028 sequence derived type containing a pointer at any level of component
15029 selection, an automatic object, a function name, an entry name, a result
15030 name, a named constant, a structure component, or a subobject of any of
15031 the preceding objects. A substring shall not have length zero. A
15032 derived type shall not have components with default initialization nor
15033 shall two objects of an equivalence group be initialized.
15034 Either all or none of the objects shall have an protected attribute.
15035 The simple constraints are done in symbol.c(check_conflict) and the rest
15036 are implemented here. */
15039 resolve_equivalence (gfc_equiv
*eq
)
15042 gfc_symbol
*first_sym
;
15045 locus
*last_where
= NULL
;
15046 seq_type eq_type
, last_eq_type
;
15047 gfc_typespec
*last_ts
;
15048 int object
, cnt_protected
;
15051 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
15053 first_sym
= eq
->expr
->symtree
->n
.sym
;
15057 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
15061 e
->ts
= e
->symtree
->n
.sym
->ts
;
15062 /* match_varspec might not know yet if it is seeing
15063 array reference or substring reference, as it doesn't
15065 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
15067 gfc_ref
*ref
= e
->ref
;
15068 sym
= e
->symtree
->n
.sym
;
15070 if (sym
->attr
.dimension
)
15072 ref
->u
.ar
.as
= sym
->as
;
15076 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15077 if (e
->ts
.type
== BT_CHARACTER
15079 && ref
->type
== REF_ARRAY
15080 && ref
->u
.ar
.dimen
== 1
15081 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
15082 && ref
->u
.ar
.stride
[0] == NULL
)
15084 gfc_expr
*start
= ref
->u
.ar
.start
[0];
15085 gfc_expr
*end
= ref
->u
.ar
.end
[0];
15088 /* Optimize away the (:) reference. */
15089 if (start
== NULL
&& end
== NULL
)
15092 e
->ref
= ref
->next
;
15094 e
->ref
->next
= ref
->next
;
15099 ref
->type
= REF_SUBSTRING
;
15101 start
= gfc_get_int_expr (gfc_default_integer_kind
,
15103 ref
->u
.ss
.start
= start
;
15104 if (end
== NULL
&& e
->ts
.u
.cl
)
15105 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
15106 ref
->u
.ss
.end
= end
;
15107 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
15114 /* Any further ref is an error. */
15117 gcc_assert (ref
->type
== REF_ARRAY
);
15118 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15124 if (!gfc_resolve_expr (e
))
15127 sym
= e
->symtree
->n
.sym
;
15129 if (sym
->attr
.is_protected
)
15131 if (cnt_protected
> 0 && cnt_protected
!= object
)
15133 gfc_error ("Either all or none of the objects in the "
15134 "EQUIVALENCE set at %L shall have the "
15135 "PROTECTED attribute",
15140 /* Shall not equivalence common block variables in a PURE procedure. */
15141 if (sym
->ns
->proc_name
15142 && sym
->ns
->proc_name
->attr
.pure
15143 && sym
->attr
.in_common
)
15145 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
15146 "object in the pure procedure %qs",
15147 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
15151 /* Shall not be a named constant. */
15152 if (e
->expr_type
== EXPR_CONSTANT
)
15154 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
15155 "object", sym
->name
, &e
->where
);
15159 if (e
->ts
.type
== BT_DERIVED
15160 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
15163 /* Check that the types correspond correctly:
15165 A numeric sequence structure may be equivalenced to another sequence
15166 structure, an object of default integer type, default real type, double
15167 precision real type, default logical type such that components of the
15168 structure ultimately only become associated to objects of the same
15169 kind. A character sequence structure may be equivalenced to an object
15170 of default character kind or another character sequence structure.
15171 Other objects may be equivalenced only to objects of the same type and
15172 kind parameters. */
15174 /* Identical types are unconditionally OK. */
15175 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
15176 goto identical_types
;
15178 last_eq_type
= sequence_type (*last_ts
);
15179 eq_type
= sequence_type (sym
->ts
);
15181 /* Since the pair of objects is not of the same type, mixed or
15182 non-default sequences can be rejected. */
15184 msg
= "Sequence %s with mixed components in EQUIVALENCE "
15185 "statement at %L with different type objects";
15187 && last_eq_type
== SEQ_MIXED
15188 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15189 || (eq_type
== SEQ_MIXED
15190 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15193 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
15194 "statement at %L with objects of different type";
15196 && last_eq_type
== SEQ_NONDEFAULT
15197 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
15198 || (eq_type
== SEQ_NONDEFAULT
15199 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
15202 msg
="Non-CHARACTER object %qs in default CHARACTER "
15203 "EQUIVALENCE statement at %L";
15204 if (last_eq_type
== SEQ_CHARACTER
15205 && eq_type
!= SEQ_CHARACTER
15206 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15209 msg
="Non-NUMERIC object %qs in default NUMERIC "
15210 "EQUIVALENCE statement at %L";
15211 if (last_eq_type
== SEQ_NUMERIC
15212 && eq_type
!= SEQ_NUMERIC
15213 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
15218 last_where
= &e
->where
;
15223 /* Shall not be an automatic array. */
15224 if (e
->ref
->type
== REF_ARRAY
15225 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
15227 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15228 "an EQUIVALENCE object", sym
->name
, &e
->where
);
15235 /* Shall not be a structure component. */
15236 if (r
->type
== REF_COMPONENT
)
15238 gfc_error ("Structure component %qs at %L cannot be an "
15239 "EQUIVALENCE object",
15240 r
->u
.c
.component
->name
, &e
->where
);
15244 /* A substring shall not have length zero. */
15245 if (r
->type
== REF_SUBSTRING
)
15247 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
15249 gfc_error ("Substring at %L has length zero",
15250 &r
->u
.ss
.start
->where
);
15260 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15263 resolve_fntype (gfc_namespace
*ns
)
15265 gfc_entry_list
*el
;
15268 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
15271 /* If there are any entries, ns->proc_name is the entry master
15272 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15274 sym
= ns
->entries
->sym
;
15276 sym
= ns
->proc_name
;
15277 if (sym
->result
== sym
15278 && sym
->ts
.type
== BT_UNKNOWN
15279 && !gfc_set_default_type (sym
, 0, NULL
)
15280 && !sym
->attr
.untyped
)
15282 gfc_error ("Function %qs at %L has no IMPLICIT type",
15283 sym
->name
, &sym
->declared_at
);
15284 sym
->attr
.untyped
= 1;
15287 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
15288 && !sym
->attr
.contained
15289 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15290 && gfc_check_symbol_access (sym
))
15292 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
15293 "%L of PRIVATE type %qs", sym
->name
,
15294 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15298 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
15300 if (el
->sym
->result
== el
->sym
15301 && el
->sym
->ts
.type
== BT_UNKNOWN
15302 && !gfc_set_default_type (el
->sym
, 0, NULL
)
15303 && !el
->sym
->attr
.untyped
)
15305 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
15306 el
->sym
->name
, &el
->sym
->declared_at
);
15307 el
->sym
->attr
.untyped
= 1;
15313 /* 12.3.2.1.1 Defined operators. */
15316 check_uop_procedure (gfc_symbol
*sym
, locus where
)
15318 gfc_formal_arglist
*formal
;
15320 if (!sym
->attr
.function
)
15322 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
15323 sym
->name
, &where
);
15327 if (sym
->ts
.type
== BT_CHARACTER
15328 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
15329 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
15330 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
15332 gfc_error ("User operator procedure %qs at %L cannot be assumed "
15333 "character length", sym
->name
, &where
);
15337 formal
= gfc_sym_get_dummy_args (sym
);
15338 if (!formal
|| !formal
->sym
)
15340 gfc_error ("User operator procedure %qs at %L must have at least "
15341 "one argument", sym
->name
, &where
);
15345 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15347 gfc_error ("First argument of operator interface at %L must be "
15348 "INTENT(IN)", &where
);
15352 if (formal
->sym
->attr
.optional
)
15354 gfc_error ("First argument of operator interface at %L cannot be "
15355 "optional", &where
);
15359 formal
= formal
->next
;
15360 if (!formal
|| !formal
->sym
)
15363 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
15365 gfc_error ("Second argument of operator interface at %L must be "
15366 "INTENT(IN)", &where
);
15370 if (formal
->sym
->attr
.optional
)
15372 gfc_error ("Second argument of operator interface at %L cannot be "
15373 "optional", &where
);
15379 gfc_error ("Operator interface at %L must have, at most, two "
15380 "arguments", &where
);
15388 gfc_resolve_uops (gfc_symtree
*symtree
)
15390 gfc_interface
*itr
;
15392 if (symtree
== NULL
)
15395 gfc_resolve_uops (symtree
->left
);
15396 gfc_resolve_uops (symtree
->right
);
15398 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
15399 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
15403 /* Examine all of the expressions associated with a program unit,
15404 assign types to all intermediate expressions, make sure that all
15405 assignments are to compatible types and figure out which names
15406 refer to which functions or subroutines. It doesn't check code
15407 block, which is handled by gfc_resolve_code. */
15410 resolve_types (gfc_namespace
*ns
)
15416 gfc_namespace
* old_ns
= gfc_current_ns
;
15418 if (ns
->types_resolved
)
15421 /* Check that all IMPLICIT types are ok. */
15422 if (!ns
->seen_implicit_none
)
15425 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
15426 if (ns
->set_flag
[letter
]
15427 && !resolve_typespec_used (&ns
->default_type
[letter
],
15428 &ns
->implicit_loc
[letter
], NULL
))
15432 gfc_current_ns
= ns
;
15434 resolve_entries (ns
);
15436 resolve_common_vars (&ns
->blank_common
, false);
15437 resolve_common_blocks (ns
->common_root
);
15439 resolve_contained_functions (ns
);
15441 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
15442 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
15443 resolve_formal_arglist (ns
->proc_name
);
15445 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
15447 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
15448 resolve_charlen (cl
);
15450 gfc_traverse_ns (ns
, resolve_symbol
);
15452 resolve_fntype (ns
);
15454 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15456 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
15457 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
15458 "also be PURE", n
->proc_name
->name
,
15459 &n
->proc_name
->declared_at
);
15465 gfc_do_concurrent_flag
= 0;
15466 gfc_check_interfaces (ns
);
15468 gfc_traverse_ns (ns
, resolve_values
);
15474 for (d
= ns
->data
; d
; d
= d
->next
)
15478 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
15480 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
15482 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
15483 resolve_equivalence (eq
);
15485 /* Warn about unused labels. */
15486 if (warn_unused_label
)
15487 warn_unused_fortran_label (ns
->st_labels
);
15489 gfc_resolve_uops (ns
->uop_root
);
15491 gfc_resolve_omp_declare_simd (ns
);
15493 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
15495 ns
->types_resolved
= 1;
15497 gfc_current_ns
= old_ns
;
15501 /* Call gfc_resolve_code recursively. */
15504 resolve_codes (gfc_namespace
*ns
)
15507 bitmap_obstack old_obstack
;
15509 if (ns
->resolved
== 1)
15512 for (n
= ns
->contained
; n
; n
= n
->sibling
)
15515 gfc_current_ns
= ns
;
15517 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15518 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
15521 /* Set to an out of range value. */
15522 current_entry_id
= -1;
15524 old_obstack
= labels_obstack
;
15525 bitmap_obstack_initialize (&labels_obstack
);
15527 gfc_resolve_oacc_declare (ns
);
15528 gfc_resolve_code (ns
->code
, ns
);
15530 bitmap_obstack_release (&labels_obstack
);
15531 labels_obstack
= old_obstack
;
15535 /* This function is called after a complete program unit has been compiled.
15536 Its purpose is to examine all of the expressions associated with a program
15537 unit, assign types to all intermediate expressions, make sure that all
15538 assignments are to compatible types and figure out which names refer to
15539 which functions or subroutines. */
15542 gfc_resolve (gfc_namespace
*ns
)
15544 gfc_namespace
*old_ns
;
15545 code_stack
*old_cs_base
;
15546 struct gfc_omp_saved_state old_omp_state
;
15552 old_ns
= gfc_current_ns
;
15553 old_cs_base
= cs_base
;
15555 /* As gfc_resolve can be called during resolution of an OpenMP construct
15556 body, we should clear any state associated to it, so that say NS's
15557 DO loops are not interpreted as OpenMP loops. */
15558 gfc_omp_save_and_clear_state (&old_omp_state
);
15560 resolve_types (ns
);
15561 component_assignment_level
= 0;
15562 resolve_codes (ns
);
15564 gfc_current_ns
= old_ns
;
15565 cs_base
= old_cs_base
;
15568 gfc_run_passes (ns
);
15570 gfc_omp_restore_state (&old_omp_state
);