1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 #include "target-memory.h" /* for gfc_simplify_transfer */
33 #include "constructor.h"
35 /* Types used in equivalence statements. */
39 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
43 /* Stack to keep track of the nesting of blocks as we move through the
44 code. See resolve_branch() and resolve_code(). */
46 typedef struct code_stack
48 struct gfc_code
*head
, *current
;
49 struct code_stack
*prev
;
51 /* This bitmap keeps track of the targets valid for a branch from
52 inside this block except for END {IF|SELECT}s of enclosing
54 bitmap reachable_labels
;
58 static code_stack
*cs_base
= NULL
;
61 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
63 static int forall_flag
;
64 static int do_concurrent_flag
;
66 static bool assumed_type_expr_allowed
= false;
68 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
70 static int omp_workshare_flag
;
72 /* Nonzero if we are processing a formal arglist. The corresponding function
73 resets the flag each time that it is read. */
74 static int formal_arg_flag
= 0;
76 /* True if we are resolving a specification expression. */
77 static int specification_expr
= 0;
79 /* The id of the last entry seen. */
80 static int current_entry_id
;
82 /* We use bitmaps to determine if a branch target is valid. */
83 static bitmap_obstack labels_obstack
;
85 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
86 static bool inquiry_argument
= false;
89 gfc_is_formal_arg (void)
91 return formal_arg_flag
;
94 /* Is the symbol host associated? */
96 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
98 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
107 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
108 an ABSTRACT derived-type. If where is not NULL, an error message with that
109 locus is printed, optionally using name. */
112 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
114 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
119 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
120 name
, where
, ts
->u
.derived
->name
);
122 gfc_error ("ABSTRACT type '%s' used at %L",
123 ts
->u
.derived
->name
, where
);
133 static void resolve_symbol (gfc_symbol
*sym
);
134 static gfc_try
resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
);
137 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
140 resolve_procedure_interface (gfc_symbol
*sym
)
142 if (sym
->ts
.interface
== sym
)
144 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
145 sym
->name
, &sym
->declared_at
);
148 if (sym
->ts
.interface
->attr
.procedure
)
150 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
151 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
152 sym
->name
, &sym
->declared_at
);
156 /* Get the attributes from the interface (now resolved). */
157 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
159 gfc_symbol
*ifc
= sym
->ts
.interface
;
160 resolve_symbol (ifc
);
162 if (ifc
->attr
.intrinsic
)
163 resolve_intrinsic (ifc
, &ifc
->declared_at
);
167 sym
->ts
= ifc
->result
->ts
;
172 sym
->ts
.interface
= ifc
;
173 sym
->attr
.function
= ifc
->attr
.function
;
174 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
175 gfc_copy_formal_args (sym
, ifc
);
177 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
178 sym
->attr
.pointer
= ifc
->attr
.pointer
;
179 sym
->attr
.pure
= ifc
->attr
.pure
;
180 sym
->attr
.elemental
= ifc
->attr
.elemental
;
181 sym
->attr
.dimension
= ifc
->attr
.dimension
;
182 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
183 sym
->attr
.recursive
= ifc
->attr
.recursive
;
184 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
185 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
186 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
187 /* Copy array spec. */
188 sym
->as
= gfc_copy_array_spec (ifc
->as
);
192 for (i
= 0; i
< sym
->as
->rank
; i
++)
194 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
195 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
198 /* Copy char length. */
199 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
201 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
202 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
203 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
204 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
208 else if (sym
->ts
.interface
->name
[0] != '\0')
210 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
211 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
219 /* Resolve types of formal argument lists. These have to be done early so that
220 the formal argument lists of module procedures can be copied to the
221 containing module before the individual procedures are resolved
222 individually. We also resolve argument lists of procedures in interface
223 blocks because they are self-contained scoping units.
225 Since a dummy argument cannot be a non-dummy procedure, the only
226 resort left for untyped names are the IMPLICIT types. */
229 resolve_formal_arglist (gfc_symbol
*proc
)
231 gfc_formal_arglist
*f
;
235 if (proc
->result
!= NULL
)
240 if (gfc_elemental (proc
)
241 || sym
->attr
.pointer
|| sym
->attr
.allocatable
242 || (sym
->as
&& sym
->as
->rank
> 0))
244 proc
->attr
.always_explicit
= 1;
245 sym
->attr
.always_explicit
= 1;
250 for (f
= proc
->formal
; f
; f
= f
->next
)
256 /* Alternate return placeholder. */
257 if (gfc_elemental (proc
))
258 gfc_error ("Alternate return specifier in elemental subroutine "
259 "'%s' at %L is not allowed", proc
->name
,
261 if (proc
->attr
.function
)
262 gfc_error ("Alternate return specifier in function "
263 "'%s' at %L is not allowed", proc
->name
,
267 else if (sym
->attr
.procedure
&& sym
->ts
.interface
268 && sym
->attr
.if_source
!= IFSRC_DECL
)
269 resolve_procedure_interface (sym
);
271 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
272 resolve_formal_arglist (sym
);
274 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
276 if (sym
->attr
.flavor
== FL_UNKNOWN
)
277 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
281 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
282 && (!sym
->attr
.function
|| sym
->result
== sym
))
283 gfc_set_default_type (sym
, 1, sym
->ns
);
286 gfc_resolve_array_spec (sym
->as
, 0);
288 /* We can't tell if an array with dimension (:) is assumed or deferred
289 shape until we know if it has the pointer or allocatable attributes.
291 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
292 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
)
293 && sym
->attr
.flavor
!= FL_PROCEDURE
)
295 sym
->as
->type
= AS_ASSUMED_SHAPE
;
296 for (i
= 0; i
< sym
->as
->rank
; i
++)
297 sym
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
301 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
302 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
303 || sym
->attr
.optional
)
305 proc
->attr
.always_explicit
= 1;
307 proc
->result
->attr
.always_explicit
= 1;
310 /* If the flavor is unknown at this point, it has to be a variable.
311 A procedure specification would have already set the type. */
313 if (sym
->attr
.flavor
== FL_UNKNOWN
)
314 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
318 if (sym
->attr
.flavor
== FL_PROCEDURE
)
323 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
324 "also be PURE", sym
->name
, &sym
->declared_at
);
328 else if (!sym
->attr
.pointer
)
330 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
333 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s'"
334 " of pure function '%s' at %L with VALUE "
335 "attribute but without INTENT(IN)",
336 sym
->name
, proc
->name
, &sym
->declared_at
);
338 gfc_error ("Argument '%s' of pure function '%s' at %L must "
339 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
343 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
346 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s'"
347 " of pure subroutine '%s' at %L with VALUE "
348 "attribute but without INTENT", sym
->name
,
349 proc
->name
, &sym
->declared_at
);
351 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
352 "must have its INTENT specified or have the "
353 "VALUE attribute", sym
->name
, proc
->name
,
359 if (proc
->attr
.implicit_pure
)
361 if (sym
->attr
.flavor
== FL_PROCEDURE
)
364 proc
->attr
.implicit_pure
= 0;
366 else if (!sym
->attr
.pointer
)
368 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
369 proc
->attr
.implicit_pure
= 0;
371 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
372 proc
->attr
.implicit_pure
= 0;
376 if (gfc_elemental (proc
))
379 if (sym
->attr
.codimension
380 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
381 && CLASS_DATA (sym
)->attr
.codimension
))
383 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
384 "procedure", sym
->name
, &sym
->declared_at
);
388 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
389 && CLASS_DATA (sym
)->as
))
391 gfc_error ("Argument '%s' of elemental procedure at %L must "
392 "be scalar", sym
->name
, &sym
->declared_at
);
396 if (sym
->attr
.allocatable
397 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
398 && CLASS_DATA (sym
)->attr
.allocatable
))
400 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
401 "have the ALLOCATABLE attribute", sym
->name
,
406 if (sym
->attr
.pointer
407 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
408 && CLASS_DATA (sym
)->attr
.class_pointer
))
410 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
411 "have the POINTER attribute", sym
->name
,
416 if (sym
->attr
.flavor
== FL_PROCEDURE
)
418 gfc_error ("Dummy procedure '%s' not allowed in elemental "
419 "procedure '%s' at %L", sym
->name
, proc
->name
,
424 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
426 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
427 "have its INTENT specified", sym
->name
, proc
->name
,
433 /* Each dummy shall be specified to be scalar. */
434 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
438 gfc_error ("Argument '%s' of statement function at %L must "
439 "be scalar", sym
->name
, &sym
->declared_at
);
443 if (sym
->ts
.type
== BT_CHARACTER
)
445 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
446 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
448 gfc_error ("Character-valued argument '%s' of statement "
449 "function at %L must have constant length",
450 sym
->name
, &sym
->declared_at
);
460 /* Work function called when searching for symbols that have argument lists
461 associated with them. */
464 find_arglists (gfc_symbol
*sym
)
466 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
467 || sym
->attr
.flavor
== FL_DERIVED
)
470 resolve_formal_arglist (sym
);
474 /* Given a namespace, resolve all formal argument lists within the namespace.
478 resolve_formal_arglists (gfc_namespace
*ns
)
483 gfc_traverse_ns (ns
, find_arglists
);
488 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
492 /* If this namespace is not a function or an entry master function,
494 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
495 || sym
->attr
.entry_master
)
498 /* Try to find out of what the return type is. */
499 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
501 t
= gfc_set_default_type (sym
->result
, 0, ns
);
503 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
505 if (sym
->result
== sym
)
506 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
507 sym
->name
, &sym
->declared_at
);
508 else if (!sym
->result
->attr
.proc_pointer
)
509 gfc_error ("Result '%s' of contained function '%s' at %L has "
510 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
511 &sym
->result
->declared_at
);
512 sym
->result
->attr
.untyped
= 1;
516 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
517 type, lists the only ways a character length value of * can be used:
518 dummy arguments of procedures, named constants, and function results
519 in external functions. Internal function results and results of module
520 procedures are not on this list, ergo, not permitted. */
522 if (sym
->result
->ts
.type
== BT_CHARACTER
)
524 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
525 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
527 /* See if this is a module-procedure and adapt error message
530 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
531 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
533 gfc_error ("Character-valued %s '%s' at %L must not be"
535 module_proc
? _("module procedure")
536 : _("internal function"),
537 sym
->name
, &sym
->declared_at
);
543 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
544 introduce duplicates. */
547 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
549 gfc_formal_arglist
*f
, *new_arglist
;
552 for (; new_args
!= NULL
; new_args
= new_args
->next
)
554 new_sym
= new_args
->sym
;
555 /* See if this arg is already in the formal argument list. */
556 for (f
= proc
->formal
; f
; f
= f
->next
)
558 if (new_sym
== f
->sym
)
565 /* Add a new argument. Argument order is not important. */
566 new_arglist
= gfc_get_formal_arglist ();
567 new_arglist
->sym
= new_sym
;
568 new_arglist
->next
= proc
->formal
;
569 proc
->formal
= new_arglist
;
574 /* Flag the arguments that are not present in all entries. */
577 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
579 gfc_formal_arglist
*f
, *head
;
582 for (f
= proc
->formal
; f
; f
= f
->next
)
587 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
589 if (new_args
->sym
== f
->sym
)
596 f
->sym
->attr
.not_always_present
= 1;
601 /* Resolve alternate entry points. If a symbol has multiple entry points we
602 create a new master symbol for the main routine, and turn the existing
603 symbol into an entry point. */
606 resolve_entries (gfc_namespace
*ns
)
608 gfc_namespace
*old_ns
;
612 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
613 static int master_count
= 0;
615 if (ns
->proc_name
== NULL
)
618 /* No need to do anything if this procedure doesn't have alternate entry
623 /* We may already have resolved alternate entry points. */
624 if (ns
->proc_name
->attr
.entry_master
)
627 /* If this isn't a procedure something has gone horribly wrong. */
628 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
630 /* Remember the current namespace. */
631 old_ns
= gfc_current_ns
;
635 /* Add the main entry point to the list of entry points. */
636 el
= gfc_get_entry_list ();
637 el
->sym
= ns
->proc_name
;
639 el
->next
= ns
->entries
;
641 ns
->proc_name
->attr
.entry
= 1;
643 /* If it is a module function, it needs to be in the right namespace
644 so that gfc_get_fake_result_decl can gather up the results. The
645 need for this arose in get_proc_name, where these beasts were
646 left in their own namespace, to keep prior references linked to
647 the entry declaration.*/
648 if (ns
->proc_name
->attr
.function
649 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
652 /* Do the same for entries where the master is not a module
653 procedure. These are retained in the module namespace because
654 of the module procedure declaration. */
655 for (el
= el
->next
; el
; el
= el
->next
)
656 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
657 && el
->sym
->attr
.mod_proc
)
661 /* Add an entry statement for it. */
668 /* Create a new symbol for the master function. */
669 /* Give the internal function a unique name (within this file).
670 Also include the function name so the user has some hope of figuring
671 out what is going on. */
672 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
673 master_count
++, ns
->proc_name
->name
);
674 gfc_get_ha_symbol (name
, &proc
);
675 gcc_assert (proc
!= NULL
);
677 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
678 if (ns
->proc_name
->attr
.subroutine
)
679 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
683 gfc_typespec
*ts
, *fts
;
684 gfc_array_spec
*as
, *fas
;
685 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
687 fas
= ns
->entries
->sym
->as
;
688 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
689 fts
= &ns
->entries
->sym
->result
->ts
;
690 if (fts
->type
== BT_UNKNOWN
)
691 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
692 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
694 ts
= &el
->sym
->result
->ts
;
696 as
= as
? as
: el
->sym
->result
->as
;
697 if (ts
->type
== BT_UNKNOWN
)
698 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
700 if (! gfc_compare_types (ts
, fts
)
701 || (el
->sym
->result
->attr
.dimension
702 != ns
->entries
->sym
->result
->attr
.dimension
)
703 || (el
->sym
->result
->attr
.pointer
704 != ns
->entries
->sym
->result
->attr
.pointer
))
706 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
707 && gfc_compare_array_spec (as
, fas
) == 0)
708 gfc_error ("Function %s at %L has entries with mismatched "
709 "array specifications", ns
->entries
->sym
->name
,
710 &ns
->entries
->sym
->declared_at
);
711 /* The characteristics need to match and thus both need to have
712 the same string length, i.e. both len=*, or both len=4.
713 Having both len=<variable> is also possible, but difficult to
714 check at compile time. */
715 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
716 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
717 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
719 && ts
->u
.cl
->length
->expr_type
720 != fts
->u
.cl
->length
->expr_type
)
722 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
723 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
724 fts
->u
.cl
->length
->value
.integer
) != 0)))
725 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
726 "entries returning variables of different "
727 "string lengths", ns
->entries
->sym
->name
,
728 &ns
->entries
->sym
->declared_at
);
733 sym
= ns
->entries
->sym
->result
;
734 /* All result types the same. */
736 if (sym
->attr
.dimension
)
737 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
738 if (sym
->attr
.pointer
)
739 gfc_add_pointer (&proc
->attr
, NULL
);
743 /* Otherwise the result will be passed through a union by
745 proc
->attr
.mixed_entry_master
= 1;
746 for (el
= ns
->entries
; el
; el
= el
->next
)
748 sym
= el
->sym
->result
;
749 if (sym
->attr
.dimension
)
751 if (el
== ns
->entries
)
752 gfc_error ("FUNCTION result %s can't be an array in "
753 "FUNCTION %s at %L", sym
->name
,
754 ns
->entries
->sym
->name
, &sym
->declared_at
);
756 gfc_error ("ENTRY result %s can't be an array in "
757 "FUNCTION %s at %L", sym
->name
,
758 ns
->entries
->sym
->name
, &sym
->declared_at
);
760 else if (sym
->attr
.pointer
)
762 if (el
== ns
->entries
)
763 gfc_error ("FUNCTION result %s can't be a POINTER in "
764 "FUNCTION %s at %L", sym
->name
,
765 ns
->entries
->sym
->name
, &sym
->declared_at
);
767 gfc_error ("ENTRY result %s can't be a POINTER in "
768 "FUNCTION %s at %L", sym
->name
,
769 ns
->entries
->sym
->name
, &sym
->declared_at
);
774 if (ts
->type
== BT_UNKNOWN
)
775 ts
= gfc_get_default_type (sym
->name
, NULL
);
779 if (ts
->kind
== gfc_default_integer_kind
)
783 if (ts
->kind
== gfc_default_real_kind
784 || ts
->kind
== gfc_default_double_kind
)
788 if (ts
->kind
== gfc_default_complex_kind
)
792 if (ts
->kind
== gfc_default_logical_kind
)
796 /* We will issue error elsewhere. */
804 if (el
== ns
->entries
)
805 gfc_error ("FUNCTION result %s can't be of type %s "
806 "in FUNCTION %s at %L", sym
->name
,
807 gfc_typename (ts
), ns
->entries
->sym
->name
,
810 gfc_error ("ENTRY result %s can't be of type %s "
811 "in FUNCTION %s at %L", sym
->name
,
812 gfc_typename (ts
), ns
->entries
->sym
->name
,
819 proc
->attr
.access
= ACCESS_PRIVATE
;
820 proc
->attr
.entry_master
= 1;
822 /* Merge all the entry point arguments. */
823 for (el
= ns
->entries
; el
; el
= el
->next
)
824 merge_argument_lists (proc
, el
->sym
->formal
);
826 /* Check the master formal arguments for any that are not
827 present in all entry points. */
828 for (el
= ns
->entries
; el
; el
= el
->next
)
829 check_argument_lists (proc
, el
->sym
->formal
);
831 /* Use the master function for the function body. */
832 ns
->proc_name
= proc
;
834 /* Finalize the new symbols. */
835 gfc_commit_symbols ();
837 /* Restore the original namespace. */
838 gfc_current_ns
= old_ns
;
842 /* Resolve common variables. */
844 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
846 gfc_symbol
*csym
= sym
;
848 for (; csym
; csym
= csym
->common_next
)
850 if (csym
->value
|| csym
->attr
.data
)
852 if (!csym
->ns
->is_block_data
)
853 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
854 "but only in BLOCK DATA initialization is "
855 "allowed", csym
->name
, &csym
->declared_at
);
856 else if (!named_common
)
857 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
858 "in a blank COMMON but initialization is only "
859 "allowed in named common blocks", csym
->name
,
863 if (csym
->ts
.type
!= BT_DERIVED
)
866 if (!(csym
->ts
.u
.derived
->attr
.sequence
867 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
868 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
869 "has neither the SEQUENCE nor the BIND(C) "
870 "attribute", csym
->name
, &csym
->declared_at
);
871 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
872 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
873 "has an ultimate component that is "
874 "allocatable", csym
->name
, &csym
->declared_at
);
875 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
876 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
877 "may not have default initializer", csym
->name
,
880 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
881 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
885 /* Resolve common blocks. */
887 resolve_common_blocks (gfc_symtree
*common_root
)
891 if (common_root
== NULL
)
894 if (common_root
->left
)
895 resolve_common_blocks (common_root
->left
);
896 if (common_root
->right
)
897 resolve_common_blocks (common_root
->right
);
899 resolve_common_vars (common_root
->n
.common
->head
, true);
901 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
905 if (sym
->attr
.flavor
== FL_PARAMETER
)
906 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
907 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
909 if (sym
->attr
.external
)
910 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
911 sym
->name
, &common_root
->n
.common
->where
);
913 if (sym
->attr
.intrinsic
)
914 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
915 sym
->name
, &common_root
->n
.common
->where
);
916 else if (sym
->attr
.result
917 || gfc_is_function_return_value (sym
, gfc_current_ns
))
918 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
919 "that is also a function result", sym
->name
,
920 &common_root
->n
.common
->where
);
921 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
922 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
923 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
924 "that is also a global procedure", sym
->name
,
925 &common_root
->n
.common
->where
);
929 /* Resolve contained function types. Because contained functions can call one
930 another, they have to be worked out before any of the contained procedures
933 The good news is that if a function doesn't already have a type, the only
934 way it can get one is through an IMPLICIT type or a RESULT variable, because
935 by definition contained functions are contained namespace they're contained
936 in, not in a sibling or parent namespace. */
939 resolve_contained_functions (gfc_namespace
*ns
)
941 gfc_namespace
*child
;
944 resolve_formal_arglists (ns
);
946 for (child
= ns
->contained
; child
; child
= child
->sibling
)
948 /* Resolve alternate entry points first. */
949 resolve_entries (child
);
951 /* Then check function return types. */
952 resolve_contained_fntype (child
->proc_name
, child
);
953 for (el
= child
->entries
; el
; el
= el
->next
)
954 resolve_contained_fntype (el
->sym
, child
);
959 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
962 /* Resolve all of the elements of a structure constructor and make sure that
963 the types are correct. The 'init' flag indicates that the given
964 constructor is an initializer. */
967 resolve_structure_cons (gfc_expr
*expr
, int init
)
969 gfc_constructor
*cons
;
976 if (expr
->ts
.type
== BT_DERIVED
)
977 resolve_fl_derived0 (expr
->ts
.u
.derived
);
979 cons
= gfc_constructor_first (expr
->value
.constructor
);
981 /* See if the user is trying to invoke a structure constructor for one of
982 the iso_c_binding derived types. */
983 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
984 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
985 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
987 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
988 expr
->ts
.u
.derived
->name
, &(expr
->where
));
992 /* Return if structure constructor is c_null_(fun)prt. */
993 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
994 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
995 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
998 /* A constructor may have references if it is the result of substituting a
999 parameter variable. In this case we just pull out the component we
1002 comp
= expr
->ref
->u
.c
.sym
->components
;
1004 comp
= expr
->ts
.u
.derived
->components
;
1006 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1013 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1019 rank
= comp
->as
? comp
->as
->rank
: 0;
1020 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1021 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1023 gfc_error ("The rank of the element in the structure "
1024 "constructor at %L does not match that of the "
1025 "component (%d/%d)", &cons
->expr
->where
,
1026 cons
->expr
->rank
, rank
);
1030 /* If we don't have the right type, try to convert it. */
1032 if (!comp
->attr
.proc_pointer
&&
1033 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1036 if (strcmp (comp
->name
, "_extends") == 0)
1038 /* Can afford to be brutal with the _extends initializer.
1039 The derived type can get lost because it is PRIVATE
1040 but it is not usage constrained by the standard. */
1041 cons
->expr
->ts
= comp
->ts
;
1044 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1045 gfc_error ("The element in the structure constructor at %L, "
1046 "for pointer component '%s', is %s but should be %s",
1047 &cons
->expr
->where
, comp
->name
,
1048 gfc_basic_typename (cons
->expr
->ts
.type
),
1049 gfc_basic_typename (comp
->ts
.type
));
1051 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1054 /* For strings, the length of the constructor should be the same as
1055 the one of the structure, ensure this if the lengths are known at
1056 compile time and when we are dealing with PARAMETER or structure
1058 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1059 && comp
->ts
.u
.cl
->length
1060 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1061 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1062 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1063 && cons
->expr
->rank
!= 0
1064 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1065 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1067 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1068 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1070 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1071 to make use of the gfc_resolve_character_array_constructor
1072 machinery. The expression is later simplified away to
1073 an array of string literals. */
1074 gfc_expr
*para
= cons
->expr
;
1075 cons
->expr
= gfc_get_expr ();
1076 cons
->expr
->ts
= para
->ts
;
1077 cons
->expr
->where
= para
->where
;
1078 cons
->expr
->expr_type
= EXPR_ARRAY
;
1079 cons
->expr
->rank
= para
->rank
;
1080 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1081 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1082 para
, &cons
->expr
->where
);
1084 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1087 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1088 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1090 gfc_charlen
*cl
, *cl2
;
1093 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1095 if (cl
== cons
->expr
->ts
.u
.cl
)
1103 cl2
->next
= cl
->next
;
1105 gfc_free_expr (cl
->length
);
1109 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1110 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1111 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1112 gfc_resolve_character_array_constructor (cons
->expr
);
1116 if (cons
->expr
->expr_type
== EXPR_NULL
1117 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1118 || comp
->attr
.proc_pointer
1119 || (comp
->ts
.type
== BT_CLASS
1120 && (CLASS_DATA (comp
)->attr
.class_pointer
1121 || CLASS_DATA (comp
)->attr
.allocatable
))))
1124 gfc_error ("The NULL in the structure constructor at %L is "
1125 "being applied to component '%s', which is neither "
1126 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1130 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1132 /* Check procedure pointer interface. */
1133 gfc_symbol
*s2
= NULL
;
1138 if (gfc_is_proc_ptr_comp (cons
->expr
, &c2
))
1140 s2
= c2
->ts
.interface
;
1143 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1145 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1146 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1148 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1150 s2
= cons
->expr
->symtree
->n
.sym
;
1151 name
= cons
->expr
->symtree
->n
.sym
->name
;
1154 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1157 gfc_error ("Interface mismatch for procedure-pointer component "
1158 "'%s' in structure constructor at %L: %s",
1159 comp
->name
, &cons
->expr
->where
, err
);
1164 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1165 || cons
->expr
->expr_type
== EXPR_NULL
)
1168 a
= gfc_expr_attr (cons
->expr
);
1170 if (!a
.pointer
&& !a
.target
)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component '%s' should be a POINTER or "
1175 "a TARGET", &cons
->expr
->where
, comp
->name
);
1180 /* F08:C461. Additional checks for pointer initialization. */
1184 gfc_error ("Pointer initialization target at %L "
1185 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1190 gfc_error ("Pointer initialization target at %L "
1191 "must have the SAVE attribute", &cons
->expr
->where
);
1195 /* F2003, C1272 (3). */
1196 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1197 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1198 || gfc_is_coindexed (cons
->expr
)))
1201 gfc_error ("Invalid expression in the structure constructor for "
1202 "pointer component '%s' at %L in PURE procedure",
1203 comp
->name
, &cons
->expr
->where
);
1206 if (gfc_implicit_pure (NULL
)
1207 && cons
->expr
->expr_type
== EXPR_VARIABLE
1208 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1209 || gfc_is_coindexed (cons
->expr
)))
1210 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1218 /****************** Expression name resolution ******************/
1220 /* Returns 0 if a symbol was not declared with a type or
1221 attribute declaration statement, nonzero otherwise. */
1224 was_declared (gfc_symbol
*sym
)
1230 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1233 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1234 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1235 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1236 || a
.asynchronous
|| a
.codimension
)
1243 /* Determine if a symbol is generic or not. */
1246 generic_sym (gfc_symbol
*sym
)
1250 if (sym
->attr
.generic
||
1251 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1254 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1257 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1264 return generic_sym (s
);
1271 /* Determine if a symbol is specific or not. */
1274 specific_sym (gfc_symbol
*sym
)
1278 if (sym
->attr
.if_source
== IFSRC_IFBODY
1279 || sym
->attr
.proc
== PROC_MODULE
1280 || sym
->attr
.proc
== PROC_INTERNAL
1281 || sym
->attr
.proc
== PROC_ST_FUNCTION
1282 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1283 || sym
->attr
.external
)
1286 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1289 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1291 return (s
== NULL
) ? 0 : specific_sym (s
);
1295 /* Figure out if the procedure is specific, generic or unknown. */
1298 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1302 procedure_kind (gfc_symbol
*sym
)
1304 if (generic_sym (sym
))
1305 return PTYPE_GENERIC
;
1307 if (specific_sym (sym
))
1308 return PTYPE_SPECIFIC
;
1310 return PTYPE_UNKNOWN
;
1313 /* Check references to assumed size arrays. The flag need_full_assumed_size
1314 is nonzero when matching actual arguments. */
1316 static int need_full_assumed_size
= 0;
1319 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1321 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1324 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1325 What should it be? */
1326 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1327 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1328 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1330 gfc_error ("The upper bound in the last dimension must "
1331 "appear in the reference to the assumed size "
1332 "array '%s' at %L", sym
->name
, &e
->where
);
1339 /* Look for bad assumed size array references in argument expressions
1340 of elemental and array valued intrinsic procedures. Since this is
1341 called from procedure resolution functions, it only recurses at
1345 resolve_assumed_size_actual (gfc_expr
*e
)
1350 switch (e
->expr_type
)
1353 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1358 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1359 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1370 /* Check a generic procedure, passed as an actual argument, to see if
1371 there is a matching specific name. If none, it is an error, and if
1372 more than one, the reference is ambiguous. */
1374 count_specific_procs (gfc_expr
*e
)
1381 sym
= e
->symtree
->n
.sym
;
1383 for (p
= sym
->generic
; p
; p
= p
->next
)
1384 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1386 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1392 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1396 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1397 "argument at %L", sym
->name
, &e
->where
);
1403 /* See if a call to sym could possibly be a not allowed RECURSION because of
1404 a missing RECURIVE declaration. This means that either sym is the current
1405 context itself, or sym is the parent of a contained procedure calling its
1406 non-RECURSIVE containing procedure.
1407 This also works if sym is an ENTRY. */
1410 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1412 gfc_symbol
* proc_sym
;
1413 gfc_symbol
* context_proc
;
1414 gfc_namespace
* real_context
;
1416 if (sym
->attr
.flavor
== FL_PROGRAM
1417 || sym
->attr
.flavor
== FL_DERIVED
)
1420 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1422 /* If we've got an ENTRY, find real procedure. */
1423 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1424 proc_sym
= sym
->ns
->entries
->sym
;
1428 /* If sym is RECURSIVE, all is well of course. */
1429 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1432 /* Find the context procedure's "real" symbol if it has entries.
1433 We look for a procedure symbol, so recurse on the parents if we don't
1434 find one (like in case of a BLOCK construct). */
1435 for (real_context
= context
; ; real_context
= real_context
->parent
)
1437 /* We should find something, eventually! */
1438 gcc_assert (real_context
);
1440 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1441 : real_context
->proc_name
);
1443 /* In some special cases, there may not be a proc_name, like for this
1445 real(bad_kind()) function foo () ...
1446 when checking the call to bad_kind ().
1447 In these cases, we simply return here and assume that the
1452 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1456 /* A call from sym's body to itself is recursion, of course. */
1457 if (context_proc
== proc_sym
)
1460 /* The same is true if context is a contained procedure and sym the
1462 if (context_proc
->attr
.contained
)
1464 gfc_symbol
* parent_proc
;
1466 gcc_assert (context
->parent
);
1467 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1468 : context
->parent
->proc_name
);
1470 if (parent_proc
== proc_sym
)
1478 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1479 its typespec and formal argument list. */
1482 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1484 gfc_intrinsic_sym
* isym
= NULL
;
1490 /* Already resolved. */
1491 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1494 /* We already know this one is an intrinsic, so we don't call
1495 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1496 gfc_find_subroutine directly to check whether it is a function or
1499 if (sym
->intmod_sym_id
)
1500 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1501 else if (!sym
->attr
.subroutine
)
1502 isym
= gfc_find_function (sym
->name
);
1506 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1507 && !sym
->attr
.implicit_type
)
1508 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1509 " ignored", sym
->name
, &sym
->declared_at
);
1511 if (!sym
->attr
.function
&&
1512 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1517 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1519 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1521 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1522 " specifier", sym
->name
, &sym
->declared_at
);
1526 if (!sym
->attr
.subroutine
&&
1527 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1532 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1537 gfc_copy_formal_args_intr (sym
, isym
);
1539 /* Check it is actually available in the standard settings. */
1540 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1543 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1544 " available in the current standard settings but %s. Use"
1545 " an appropriate -std=* option or enable -fall-intrinsics"
1546 " in order to use it.",
1547 sym
->name
, &sym
->declared_at
, symstd
);
1555 /* Resolve a procedure expression, like passing it to a called procedure or as
1556 RHS for a procedure pointer assignment. */
1559 resolve_procedure_expression (gfc_expr
* expr
)
1563 if (expr
->expr_type
!= EXPR_VARIABLE
)
1565 gcc_assert (expr
->symtree
);
1567 sym
= expr
->symtree
->n
.sym
;
1569 if (sym
->attr
.intrinsic
)
1570 resolve_intrinsic (sym
, &expr
->where
);
1572 if (sym
->attr
.flavor
!= FL_PROCEDURE
1573 || (sym
->attr
.function
&& sym
->result
== sym
))
1576 /* A non-RECURSIVE procedure that is used as procedure expression within its
1577 own body is in danger of being called recursively. */
1578 if (is_illegal_recursion (sym
, gfc_current_ns
))
1579 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1580 " itself recursively. Declare it RECURSIVE or use"
1581 " -frecursive", sym
->name
, &expr
->where
);
1587 /* Resolve an actual argument list. Most of the time, this is just
1588 resolving the expressions in the list.
1589 The exception is that we sometimes have to decide whether arguments
1590 that look like procedure arguments are really simple variable
1594 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1595 bool no_formal_args
)
1598 gfc_symtree
*parent_st
;
1600 int save_need_full_assumed_size
;
1602 assumed_type_expr_allowed
= true;
1604 for (; arg
; arg
= arg
->next
)
1609 /* Check the label is a valid branching target. */
1612 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1614 gfc_error ("Label %d referenced at %L is never defined",
1615 arg
->label
->value
, &arg
->label
->where
);
1622 if (e
->expr_type
== EXPR_VARIABLE
1623 && e
->symtree
->n
.sym
->attr
.generic
1625 && count_specific_procs (e
) != 1)
1628 if (e
->ts
.type
!= BT_PROCEDURE
)
1630 save_need_full_assumed_size
= need_full_assumed_size
;
1631 if (e
->expr_type
!= EXPR_VARIABLE
)
1632 need_full_assumed_size
= 0;
1633 if (gfc_resolve_expr (e
) != SUCCESS
)
1635 need_full_assumed_size
= save_need_full_assumed_size
;
1639 /* See if the expression node should really be a variable reference. */
1641 sym
= e
->symtree
->n
.sym
;
1643 if (sym
->attr
.flavor
== FL_PROCEDURE
1644 || sym
->attr
.intrinsic
1645 || sym
->attr
.external
)
1649 /* If a procedure is not already determined to be something else
1650 check if it is intrinsic. */
1651 if (!sym
->attr
.intrinsic
1652 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1653 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1654 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1655 sym
->attr
.intrinsic
= 1;
1657 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1659 gfc_error ("Statement function '%s' at %L is not allowed as an "
1660 "actual argument", sym
->name
, &e
->where
);
1663 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1664 sym
->attr
.subroutine
);
1665 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1667 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1668 "actual argument", sym
->name
, &e
->where
);
1671 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1672 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1674 if (gfc_notify_std (GFC_STD_F2008
,
1675 "Fortran 2008: Internal procedure '%s' is"
1676 " used as actual argument at %L",
1677 sym
->name
, &e
->where
) == FAILURE
)
1681 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1683 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1684 "allowed as an actual argument at %L", sym
->name
,
1688 /* Check if a generic interface has a specific procedure
1689 with the same name before emitting an error. */
1690 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1693 /* Just in case a specific was found for the expression. */
1694 sym
= e
->symtree
->n
.sym
;
1696 /* If the symbol is the function that names the current (or
1697 parent) scope, then we really have a variable reference. */
1699 if (gfc_is_function_return_value (sym
, sym
->ns
))
1702 /* If all else fails, see if we have a specific intrinsic. */
1703 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1705 gfc_intrinsic_sym
*isym
;
1707 isym
= gfc_find_function (sym
->name
);
1708 if (isym
== NULL
|| !isym
->specific
)
1710 gfc_error ("Unable to find a specific INTRINSIC procedure "
1711 "for the reference '%s' at %L", sym
->name
,
1716 sym
->attr
.intrinsic
= 1;
1717 sym
->attr
.function
= 1;
1720 if (gfc_resolve_expr (e
) == FAILURE
)
1725 /* See if the name is a module procedure in a parent unit. */
1727 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1730 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1732 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1736 if (parent_st
== NULL
)
1739 sym
= parent_st
->n
.sym
;
1740 e
->symtree
= parent_st
; /* Point to the right thing. */
1742 if (sym
->attr
.flavor
== FL_PROCEDURE
1743 || sym
->attr
.intrinsic
1744 || sym
->attr
.external
)
1746 if (gfc_resolve_expr (e
) == FAILURE
)
1752 e
->expr_type
= EXPR_VARIABLE
;
1754 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1755 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1756 && CLASS_DATA (sym
)->as
))
1758 e
->rank
= sym
->ts
.type
== BT_CLASS
1759 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1760 e
->ref
= gfc_get_ref ();
1761 e
->ref
->type
= REF_ARRAY
;
1762 e
->ref
->u
.ar
.type
= AR_FULL
;
1763 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1764 ? CLASS_DATA (sym
)->as
: sym
->as
;
1767 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1768 primary.c (match_actual_arg). If above code determines that it
1769 is a variable instead, it needs to be resolved as it was not
1770 done at the beginning of this function. */
1771 save_need_full_assumed_size
= need_full_assumed_size
;
1772 if (e
->expr_type
!= EXPR_VARIABLE
)
1773 need_full_assumed_size
= 0;
1774 if (gfc_resolve_expr (e
) != SUCCESS
)
1776 need_full_assumed_size
= save_need_full_assumed_size
;
1779 /* Check argument list functions %VAL, %LOC and %REF. There is
1780 nothing to do for %REF. */
1781 if (arg
->name
&& arg
->name
[0] == '%')
1783 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1785 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1787 gfc_error ("By-value argument at %L is not of numeric "
1794 gfc_error ("By-value argument at %L cannot be an array or "
1795 "an array section", &e
->where
);
1799 /* Intrinsics are still PROC_UNKNOWN here. However,
1800 since same file external procedures are not resolvable
1801 in gfortran, it is a good deal easier to leave them to
1803 if (ptype
!= PROC_UNKNOWN
1804 && ptype
!= PROC_DUMMY
1805 && ptype
!= PROC_EXTERNAL
1806 && ptype
!= PROC_MODULE
)
1808 gfc_error ("By-value argument at %L is not allowed "
1809 "in this context", &e
->where
);
1814 /* Statement functions have already been excluded above. */
1815 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1816 && e
->ts
.type
== BT_PROCEDURE
)
1818 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1820 gfc_error ("Passing internal procedure at %L by location "
1821 "not allowed", &e
->where
);
1827 /* Fortran 2008, C1237. */
1828 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1829 && gfc_has_ultimate_pointer (e
))
1831 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1832 "component", &e
->where
);
1836 assumed_type_expr_allowed
= false;
1842 /* Do the checks of the actual argument list that are specific to elemental
1843 procedures. If called with c == NULL, we have a function, otherwise if
1844 expr == NULL, we have a subroutine. */
1847 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1849 gfc_actual_arglist
*arg0
;
1850 gfc_actual_arglist
*arg
;
1851 gfc_symbol
*esym
= NULL
;
1852 gfc_intrinsic_sym
*isym
= NULL
;
1854 gfc_intrinsic_arg
*iformal
= NULL
;
1855 gfc_formal_arglist
*eformal
= NULL
;
1856 bool formal_optional
= false;
1857 bool set_by_optional
= false;
1861 /* Is this an elemental procedure? */
1862 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1864 if (expr
->value
.function
.esym
!= NULL
1865 && expr
->value
.function
.esym
->attr
.elemental
)
1867 arg0
= expr
->value
.function
.actual
;
1868 esym
= expr
->value
.function
.esym
;
1870 else if (expr
->value
.function
.isym
!= NULL
1871 && expr
->value
.function
.isym
->elemental
)
1873 arg0
= expr
->value
.function
.actual
;
1874 isym
= expr
->value
.function
.isym
;
1879 else if (c
&& c
->ext
.actual
!= NULL
)
1881 arg0
= c
->ext
.actual
;
1883 if (c
->resolved_sym
)
1884 esym
= c
->resolved_sym
;
1886 esym
= c
->symtree
->n
.sym
;
1889 if (!esym
->attr
.elemental
)
1895 /* The rank of an elemental is the rank of its array argument(s). */
1896 for (arg
= arg0
; arg
; arg
= arg
->next
)
1898 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1900 rank
= arg
->expr
->rank
;
1901 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1902 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1903 set_by_optional
= true;
1905 /* Function specific; set the result rank and shape. */
1909 if (!expr
->shape
&& arg
->expr
->shape
)
1911 expr
->shape
= gfc_get_shape (rank
);
1912 for (i
= 0; i
< rank
; i
++)
1913 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1920 /* If it is an array, it shall not be supplied as an actual argument
1921 to an elemental procedure unless an array of the same rank is supplied
1922 as an actual argument corresponding to a nonoptional dummy argument of
1923 that elemental procedure(12.4.1.5). */
1924 formal_optional
= false;
1926 iformal
= isym
->formal
;
1928 eformal
= esym
->formal
;
1930 for (arg
= arg0
; arg
; arg
= arg
->next
)
1934 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1935 formal_optional
= true;
1936 eformal
= eformal
->next
;
1938 else if (isym
&& iformal
)
1940 if (iformal
->optional
)
1941 formal_optional
= true;
1942 iformal
= iformal
->next
;
1945 formal_optional
= true;
1947 if (pedantic
&& arg
->expr
!= NULL
1948 && arg
->expr
->expr_type
== EXPR_VARIABLE
1949 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1952 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1953 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1955 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1956 "MISSING, it cannot be the actual argument of an "
1957 "ELEMENTAL procedure unless there is a non-optional "
1958 "argument with the same rank (12.4.1.5)",
1959 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1964 for (arg
= arg0
; arg
; arg
= arg
->next
)
1966 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1969 /* Being elemental, the last upper bound of an assumed size array
1970 argument must be present. */
1971 if (resolve_assumed_size_actual (arg
->expr
))
1974 /* Elemental procedure's array actual arguments must conform. */
1977 if (gfc_check_conformance (arg
->expr
, e
,
1978 "elemental procedure") == FAILURE
)
1985 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1986 is an array, the intent inout/out variable needs to be also an array. */
1987 if (rank
> 0 && esym
&& expr
== NULL
)
1988 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1989 arg
= arg
->next
, eformal
= eformal
->next
)
1990 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1991 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1992 && arg
->expr
&& arg
->expr
->rank
== 0)
1994 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1995 "ELEMENTAL subroutine '%s' is a scalar, but another "
1996 "actual argument is an array", &arg
->expr
->where
,
1997 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1998 : "INOUT", eformal
->sym
->name
, esym
->name
);
2005 /* This function does the checking of references to global procedures
2006 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2007 77 and 95 standards. It checks for a gsymbol for the name, making
2008 one if it does not already exist. If it already exists, then the
2009 reference being resolved must correspond to the type of gsymbol.
2010 Otherwise, the new symbol is equipped with the attributes of the
2011 reference. The corresponding code that is called in creating
2012 global entities is parse.c.
2014 In addition, for all but -std=legacy, the gsymbols are used to
2015 check the interfaces of external procedures from the same file.
2016 The namespace of the gsymbol is resolved and then, once this is
2017 done the interface is checked. */
2021 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2023 if (!gsym_ns
->proc_name
->attr
.recursive
)
2026 if (sym
->ns
== gsym_ns
)
2029 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2036 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2038 if (gsym_ns
->entries
)
2040 gfc_entry_list
*entry
= gsym_ns
->entries
;
2042 for (; entry
; entry
= entry
->next
)
2044 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2046 if (strcmp (gsym_ns
->proc_name
->name
,
2047 sym
->ns
->proc_name
->name
) == 0)
2051 && strcmp (gsym_ns
->proc_name
->name
,
2052 sym
->ns
->parent
->proc_name
->name
) == 0)
2061 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2062 gfc_actual_arglist
**actual
, int sub
)
2066 enum gfc_symbol_type type
;
2068 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2070 gsym
= gfc_get_gsymbol (sym
->name
);
2072 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2073 gfc_global_used (gsym
, where
);
2075 if (gfc_option
.flag_whole_file
2076 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2077 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2078 && gsym
->type
!= GSYM_UNKNOWN
2080 && gsym
->ns
->resolved
!= -1
2081 && gsym
->ns
->proc_name
2082 && not_in_recursive (sym
, gsym
->ns
)
2083 && not_entry_self_reference (sym
, gsym
->ns
))
2085 gfc_symbol
*def_sym
;
2087 /* Resolve the gsymbol namespace if needed. */
2088 if (!gsym
->ns
->resolved
)
2090 gfc_dt_list
*old_dt_list
;
2091 struct gfc_omp_saved_state old_omp_state
;
2093 /* Stash away derived types so that the backend_decls do not
2095 old_dt_list
= gfc_derived_types
;
2096 gfc_derived_types
= NULL
;
2097 /* And stash away openmp state. */
2098 gfc_omp_save_and_clear_state (&old_omp_state
);
2100 gfc_resolve (gsym
->ns
);
2102 /* Store the new derived types with the global namespace. */
2103 if (gfc_derived_types
)
2104 gsym
->ns
->derived_types
= gfc_derived_types
;
2106 /* Restore the derived types of this namespace. */
2107 gfc_derived_types
= old_dt_list
;
2108 /* And openmp state. */
2109 gfc_omp_restore_state (&old_omp_state
);
2112 /* Make sure that translation for the gsymbol occurs before
2113 the procedure currently being resolved. */
2114 ns
= gfc_global_ns_list
;
2115 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2117 if (ns
->sibling
== gsym
->ns
)
2119 ns
->sibling
= gsym
->ns
->sibling
;
2120 gsym
->ns
->sibling
= gfc_global_ns_list
;
2121 gfc_global_ns_list
= gsym
->ns
;
2126 def_sym
= gsym
->ns
->proc_name
;
2127 if (def_sym
->attr
.entry_master
)
2129 gfc_entry_list
*entry
;
2130 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2131 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2133 def_sym
= entry
->sym
;
2138 /* Differences in constant character lengths. */
2139 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2141 long int l1
= 0, l2
= 0;
2142 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2143 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2146 && cl1
->length
!= NULL
2147 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2148 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2151 && cl2
->length
!= NULL
2152 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2153 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2155 if (l1
&& l2
&& l1
!= l2
)
2156 gfc_error ("Character length mismatch in return type of "
2157 "function '%s' at %L (%ld/%ld)", sym
->name
,
2158 &sym
->declared_at
, l1
, l2
);
2161 /* Type mismatch of function return type and expected type. */
2162 if (sym
->attr
.function
2163 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2164 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2165 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2166 gfc_typename (&def_sym
->ts
));
2168 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2170 gfc_formal_arglist
*arg
= def_sym
->formal
;
2171 for ( ; arg
; arg
= arg
->next
)
2174 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2175 else if (arg
->sym
->attr
.allocatable
2176 || arg
->sym
->attr
.asynchronous
2177 || arg
->sym
->attr
.optional
2178 || arg
->sym
->attr
.pointer
2179 || arg
->sym
->attr
.target
2180 || arg
->sym
->attr
.value
2181 || arg
->sym
->attr
.volatile_
)
2183 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2184 "has an attribute that requires an explicit "
2185 "interface for this procedure", arg
->sym
->name
,
2186 sym
->name
, &sym
->declared_at
);
2189 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2190 else if (arg
->sym
&& arg
->sym
->as
2191 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2193 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2194 "argument '%s' must have an explicit interface",
2195 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2198 /* F2008, 12.4.2.2 (2c) */
2199 else if (arg
->sym
->attr
.codimension
)
2201 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2202 "'%s' must have an explicit interface",
2203 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2206 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2207 else if (false) /* TODO: is a parametrized derived type */
2209 gfc_error ("Procedure '%s' at %L with parametrized derived "
2210 "type argument '%s' must have an explicit "
2211 "interface", sym
->name
, &sym
->declared_at
,
2215 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2216 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2218 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2219 "argument '%s' must have an explicit interface",
2220 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2225 if (def_sym
->attr
.function
)
2227 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2228 if (def_sym
->as
&& def_sym
->as
->rank
2229 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2230 gfc_error ("The reference to function '%s' at %L either needs an "
2231 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2234 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2235 if ((def_sym
->result
->attr
.pointer
2236 || def_sym
->result
->attr
.allocatable
)
2237 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2238 || def_sym
->result
->attr
.pointer
2239 != sym
->result
->attr
.pointer
2240 || def_sym
->result
->attr
.allocatable
2241 != sym
->result
->attr
.allocatable
))
2242 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2243 "result must have an explicit interface", sym
->name
,
2246 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2247 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2248 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2250 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2252 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2253 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2255 gfc_error ("Nonconstant character-length function '%s' at %L "
2256 "must have an explicit interface", sym
->name
,
2262 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2263 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2265 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2266 "interface", sym
->name
, &sym
->declared_at
);
2269 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2270 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2272 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2273 "an explicit interface", sym
->name
, &sym
->declared_at
);
2276 if (gfc_option
.flag_whole_file
== 1
2277 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2278 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2279 gfc_errors_to_warnings (1);
2281 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2282 gfc_procedure_use (def_sym
, actual
, where
);
2284 gfc_errors_to_warnings (0);
2287 if (gsym
->type
== GSYM_UNKNOWN
)
2290 gsym
->where
= *where
;
2297 /************* Function resolution *************/
2299 /* Resolve a function call known to be generic.
2300 Section 14.1.2.4.1. */
2303 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2307 if (sym
->attr
.generic
)
2309 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2312 expr
->value
.function
.name
= s
->name
;
2313 expr
->value
.function
.esym
= s
;
2315 if (s
->ts
.type
!= BT_UNKNOWN
)
2317 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2318 expr
->ts
= s
->result
->ts
;
2321 expr
->rank
= s
->as
->rank
;
2322 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2323 expr
->rank
= s
->result
->as
->rank
;
2325 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2330 /* TODO: Need to search for elemental references in generic
2334 if (sym
->attr
.intrinsic
)
2335 return gfc_intrinsic_func_interface (expr
, 0);
2342 resolve_generic_f (gfc_expr
*expr
)
2346 gfc_interface
*intr
= NULL
;
2348 sym
= expr
->symtree
->n
.sym
;
2352 m
= resolve_generic_f0 (expr
, sym
);
2355 else if (m
== MATCH_ERROR
)
2360 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2361 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2364 if (sym
->ns
->parent
== NULL
)
2366 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2370 if (!generic_sym (sym
))
2374 /* Last ditch attempt. See if the reference is to an intrinsic
2375 that possesses a matching interface. 14.1.2.4 */
2376 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2378 gfc_error ("There is no specific function for the generic '%s' "
2379 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2385 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2388 return resolve_structure_cons (expr
, 0);
2391 m
= gfc_intrinsic_func_interface (expr
, 0);
2396 gfc_error ("Generic function '%s' at %L is not consistent with a "
2397 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2404 /* Resolve a function call known to be specific. */
2407 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2411 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2413 if (sym
->attr
.dummy
)
2415 sym
->attr
.proc
= PROC_DUMMY
;
2419 sym
->attr
.proc
= PROC_EXTERNAL
;
2423 if (sym
->attr
.proc
== PROC_MODULE
2424 || sym
->attr
.proc
== PROC_ST_FUNCTION
2425 || sym
->attr
.proc
== PROC_INTERNAL
)
2428 if (sym
->attr
.intrinsic
)
2430 m
= gfc_intrinsic_func_interface (expr
, 1);
2434 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2435 "with an intrinsic", sym
->name
, &expr
->where
);
2443 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2446 expr
->ts
= sym
->result
->ts
;
2449 expr
->value
.function
.name
= sym
->name
;
2450 expr
->value
.function
.esym
= sym
;
2451 if (sym
->as
!= NULL
)
2452 expr
->rank
= sym
->as
->rank
;
2459 resolve_specific_f (gfc_expr
*expr
)
2464 sym
= expr
->symtree
->n
.sym
;
2468 m
= resolve_specific_f0 (sym
, expr
);
2471 if (m
== MATCH_ERROR
)
2474 if (sym
->ns
->parent
== NULL
)
2477 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2483 gfc_error ("Unable to resolve the specific function '%s' at %L",
2484 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2490 /* Resolve a procedure call not known to be generic nor specific. */
2493 resolve_unknown_f (gfc_expr
*expr
)
2498 sym
= expr
->symtree
->n
.sym
;
2500 if (sym
->attr
.dummy
)
2502 sym
->attr
.proc
= PROC_DUMMY
;
2503 expr
->value
.function
.name
= sym
->name
;
2507 /* See if we have an intrinsic function reference. */
2509 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2511 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2516 /* The reference is to an external name. */
2518 sym
->attr
.proc
= PROC_EXTERNAL
;
2519 expr
->value
.function
.name
= sym
->name
;
2520 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2522 if (sym
->as
!= NULL
)
2523 expr
->rank
= sym
->as
->rank
;
2525 /* Type of the expression is either the type of the symbol or the
2526 default type of the symbol. */
2529 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2531 if (sym
->ts
.type
!= BT_UNKNOWN
)
2535 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2537 if (ts
->type
== BT_UNKNOWN
)
2539 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2540 sym
->name
, &expr
->where
);
2551 /* Return true, if the symbol is an external procedure. */
2553 is_external_proc (gfc_symbol
*sym
)
2555 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2556 && !(sym
->attr
.intrinsic
2557 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2558 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2559 && !sym
->attr
.proc_pointer
2560 && !sym
->attr
.use_assoc
2568 /* Figure out if a function reference is pure or not. Also set the name
2569 of the function for a potential error message. Return nonzero if the
2570 function is PURE, zero if not. */
2572 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2575 pure_function (gfc_expr
*e
, const char **name
)
2581 if (e
->symtree
!= NULL
2582 && e
->symtree
->n
.sym
!= NULL
2583 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2584 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2586 if (e
->value
.function
.esym
)
2588 pure
= gfc_pure (e
->value
.function
.esym
);
2589 *name
= e
->value
.function
.esym
->name
;
2591 else if (e
->value
.function
.isym
)
2593 pure
= e
->value
.function
.isym
->pure
2594 || e
->value
.function
.isym
->elemental
;
2595 *name
= e
->value
.function
.isym
->name
;
2599 /* Implicit functions are not pure. */
2601 *name
= e
->value
.function
.name
;
2609 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2610 int *f ATTRIBUTE_UNUSED
)
2614 /* Don't bother recursing into other statement functions
2615 since they will be checked individually for purity. */
2616 if (e
->expr_type
!= EXPR_FUNCTION
2618 || e
->symtree
->n
.sym
== sym
2619 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2622 return pure_function (e
, &name
) ? false : true;
2627 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2629 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2634 is_scalar_expr_ptr (gfc_expr
*expr
)
2636 gfc_try retval
= SUCCESS
;
2641 /* See if we have a gfc_ref, which means we have a substring, array
2642 reference, or a component. */
2643 if (expr
->ref
!= NULL
)
2646 while (ref
->next
!= NULL
)
2652 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2653 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2658 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2660 else if (ref
->u
.ar
.type
== AR_FULL
)
2662 /* The user can give a full array if the array is of size 1. */
2663 if (ref
->u
.ar
.as
!= NULL
2664 && ref
->u
.ar
.as
->rank
== 1
2665 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2666 && ref
->u
.ar
.as
->lower
[0] != NULL
2667 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2668 && ref
->u
.ar
.as
->upper
[0] != NULL
2669 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2671 /* If we have a character string, we need to check if
2672 its length is one. */
2673 if (expr
->ts
.type
== BT_CHARACTER
)
2675 if (expr
->ts
.u
.cl
== NULL
2676 || expr
->ts
.u
.cl
->length
== NULL
2677 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2683 /* We have constant lower and upper bounds. If the
2684 difference between is 1, it can be considered a
2686 FIXME: Use gfc_dep_compare_expr instead. */
2687 start
= (int) mpz_get_si
2688 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2689 end
= (int) mpz_get_si
2690 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2691 if (end
- start
+ 1 != 1)
2706 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2708 /* Character string. Make sure it's of length 1. */
2709 if (expr
->ts
.u
.cl
== NULL
2710 || expr
->ts
.u
.cl
->length
== NULL
2711 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2714 else if (expr
->rank
!= 0)
2721 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2722 and, in the case of c_associated, set the binding label based on
2726 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2727 gfc_symbol
**new_sym
)
2729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2730 int optional_arg
= 0;
2731 gfc_try retval
= SUCCESS
;
2732 gfc_symbol
*args_sym
;
2733 gfc_typespec
*arg_ts
;
2734 symbol_attribute arg_attr
;
2736 if (args
->expr
->expr_type
== EXPR_CONSTANT
2737 || args
->expr
->expr_type
== EXPR_OP
2738 || args
->expr
->expr_type
== EXPR_NULL
)
2740 gfc_error ("Argument to '%s' at %L is not a variable",
2741 sym
->name
, &(args
->expr
->where
));
2745 args_sym
= args
->expr
->symtree
->n
.sym
;
2747 /* The typespec for the actual arg should be that stored in the expr
2748 and not necessarily that of the expr symbol (args_sym), because
2749 the actual expression could be a part-ref of the expr symbol. */
2750 arg_ts
= &(args
->expr
->ts
);
2751 arg_attr
= gfc_expr_attr (args
->expr
);
2753 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2755 /* If the user gave two args then they are providing something for
2756 the optional arg (the second cptr). Therefore, set the name and
2757 binding label to the c_associated for two cptrs. Otherwise,
2758 set c_associated to expect one cptr. */
2762 sprintf (name
, "%s_2", sym
->name
);
2768 sprintf (name
, "%s_1", sym
->name
);
2772 /* Get a new symbol for the version of c_associated that
2774 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2776 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2777 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2779 sprintf (name
, "%s", sym
->name
);
2781 /* Error check the call. */
2782 if (args
->next
!= NULL
)
2784 gfc_error_now ("More actual than formal arguments in '%s' "
2785 "call at %L", name
, &(args
->expr
->where
));
2788 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2793 /* Make sure we have either the target or pointer attribute. */
2794 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2796 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2797 "a TARGET or an associated pointer",
2799 sym
->name
, &(args
->expr
->where
));
2803 if (gfc_is_coindexed (args
->expr
))
2805 gfc_error_now ("Coindexed argument not permitted"
2806 " in '%s' call at %L", name
,
2807 &(args
->expr
->where
));
2811 /* Follow references to make sure there are no array
2813 seen_section
= false;
2815 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2817 if (ref
->type
== REF_ARRAY
)
2819 if (ref
->u
.ar
.type
== AR_SECTION
)
2820 seen_section
= true;
2822 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2825 for (r
= ref
->next
; r
; r
=r
->next
)
2826 if (r
->type
== REF_COMPONENT
)
2828 gfc_error_now ("Array section not permitted"
2829 " in '%s' call at %L", name
,
2830 &(args
->expr
->where
));
2838 if (seen_section
&& retval
== SUCCESS
)
2839 gfc_warning ("Array section in '%s' call at %L", name
,
2840 &(args
->expr
->where
));
2842 /* See if we have interoperable type and type param. */
2843 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2844 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2846 if (args_sym
->attr
.target
== 1)
2848 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2849 has the target attribute and is interoperable. */
2850 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2851 allocatable variable that has the TARGET attribute and
2852 is not an array of zero size. */
2853 if (args_sym
->attr
.allocatable
== 1)
2855 if (args_sym
->attr
.dimension
!= 0
2856 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2858 gfc_error_now ("Allocatable variable '%s' used as a "
2859 "parameter to '%s' at %L must not be "
2860 "an array of zero size",
2861 args_sym
->name
, sym
->name
,
2862 &(args
->expr
->where
));
2868 /* A non-allocatable target variable with C
2869 interoperable type and type parameters must be
2871 if (args_sym
&& args_sym
->attr
.dimension
)
2873 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2875 gfc_error ("Assumed-shape array '%s' at %L "
2876 "cannot be an argument to the "
2877 "procedure '%s' because "
2878 "it is not C interoperable",
2880 &(args
->expr
->where
), sym
->name
);
2883 else if (args_sym
->as
->type
== AS_DEFERRED
)
2885 gfc_error ("Deferred-shape array '%s' at %L "
2886 "cannot be an argument to the "
2887 "procedure '%s' because "
2888 "it is not C interoperable",
2890 &(args
->expr
->where
), sym
->name
);
2895 /* Make sure it's not a character string. Arrays of
2896 any type should be ok if the variable is of a C
2897 interoperable type. */
2898 if (arg_ts
->type
== BT_CHARACTER
)
2899 if (arg_ts
->u
.cl
!= NULL
2900 && (arg_ts
->u
.cl
->length
== NULL
2901 || arg_ts
->u
.cl
->length
->expr_type
2904 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2906 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2908 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2909 "at %L must have a length of 1",
2910 args_sym
->name
, sym
->name
,
2911 &(args
->expr
->where
));
2916 else if (arg_attr
.pointer
2917 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2919 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2921 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2922 "associated scalar POINTER", args_sym
->name
,
2923 sym
->name
, &(args
->expr
->where
));
2929 /* The parameter is not required to be C interoperable. If it
2930 is not C interoperable, it must be a nonpolymorphic scalar
2931 with no length type parameters. It still must have either
2932 the pointer or target attribute, and it can be
2933 allocatable (but must be allocated when c_loc is called). */
2934 if (args
->expr
->rank
!= 0
2935 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2937 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2938 "scalar", args_sym
->name
, sym
->name
,
2939 &(args
->expr
->where
));
2942 else if (arg_ts
->type
== BT_CHARACTER
2943 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2945 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2946 "%L must have a length of 1",
2947 args_sym
->name
, sym
->name
,
2948 &(args
->expr
->where
));
2951 else if (arg_ts
->type
== BT_CLASS
)
2953 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2954 "polymorphic", args_sym
->name
, sym
->name
,
2955 &(args
->expr
->where
));
2960 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2962 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2964 /* TODO: Update this error message to allow for procedure
2965 pointers once they are implemented. */
2966 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2968 args_sym
->name
, sym
->name
,
2969 &(args
->expr
->where
));
2972 else if (args_sym
->attr
.is_bind_c
!= 1)
2974 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2976 args_sym
->name
, sym
->name
,
2977 &(args
->expr
->where
));
2982 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2987 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2988 "iso_c_binding function: '%s'!\n", sym
->name
);
2995 /* Resolve a function call, which means resolving the arguments, then figuring
2996 out which entity the name refers to. */
2999 resolve_function (gfc_expr
*expr
)
3001 gfc_actual_arglist
*arg
;
3006 procedure_type p
= PROC_INTRINSIC
;
3007 bool no_formal_args
;
3011 sym
= expr
->symtree
->n
.sym
;
3013 /* If this is a procedure pointer component, it has already been resolved. */
3014 if (gfc_is_proc_ptr_comp (expr
, NULL
))
3017 if (sym
&& sym
->attr
.intrinsic
3018 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3021 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3023 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3027 /* If this ia a deferred TBP with an abstract interface (which may
3028 of course be referenced), expr->value.function.esym will be set. */
3029 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3031 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3032 sym
->name
, &expr
->where
);
3036 /* Switch off assumed size checking and do this again for certain kinds
3037 of procedure, once the procedure itself is resolved. */
3038 need_full_assumed_size
++;
3040 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3041 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3043 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3044 inquiry_argument
= true;
3045 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3047 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3048 p
, no_formal_args
) == FAILURE
)
3050 inquiry_argument
= false;
3054 inquiry_argument
= false;
3056 /* Need to setup the call to the correct c_associated, depending on
3057 the number of cptrs to user gives to compare. */
3058 if (sym
&& sym
->attr
.is_iso_c
== 1)
3060 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3064 /* Get the symtree for the new symbol (resolved func).
3065 the old one will be freed later, when it's no longer used. */
3066 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3069 /* Resume assumed_size checking. */
3070 need_full_assumed_size
--;
3072 /* If the procedure is external, check for usage. */
3073 if (sym
&& is_external_proc (sym
))
3074 resolve_global_procedure (sym
, &expr
->where
,
3075 &expr
->value
.function
.actual
, 0);
3077 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3079 && sym
->ts
.u
.cl
->length
== NULL
3081 && !sym
->ts
.deferred
3082 && expr
->value
.function
.esym
== NULL
3083 && !sym
->attr
.contained
)
3085 /* Internal procedures are taken care of in resolve_contained_fntype. */
3086 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3087 "be used at %L since it is not a dummy argument",
3088 sym
->name
, &expr
->where
);
3092 /* See if function is already resolved. */
3094 if (expr
->value
.function
.name
!= NULL
)
3096 if (expr
->ts
.type
== BT_UNKNOWN
)
3102 /* Apply the rules of section 14.1.2. */
3104 switch (procedure_kind (sym
))
3107 t
= resolve_generic_f (expr
);
3110 case PTYPE_SPECIFIC
:
3111 t
= resolve_specific_f (expr
);
3115 t
= resolve_unknown_f (expr
);
3119 gfc_internal_error ("resolve_function(): bad function type");
3123 /* If the expression is still a function (it might have simplified),
3124 then we check to see if we are calling an elemental function. */
3126 if (expr
->expr_type
!= EXPR_FUNCTION
)
3129 temp
= need_full_assumed_size
;
3130 need_full_assumed_size
= 0;
3132 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3135 if (omp_workshare_flag
3136 && expr
->value
.function
.esym
3137 && ! gfc_elemental (expr
->value
.function
.esym
))
3139 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3140 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3145 #define GENERIC_ID expr->value.function.isym->id
3146 else if (expr
->value
.function
.actual
!= NULL
3147 && expr
->value
.function
.isym
!= NULL
3148 && GENERIC_ID
!= GFC_ISYM_LBOUND
3149 && GENERIC_ID
!= GFC_ISYM_LEN
3150 && GENERIC_ID
!= GFC_ISYM_LOC
3151 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3153 /* Array intrinsics must also have the last upper bound of an
3154 assumed size array argument. UBOUND and SIZE have to be
3155 excluded from the check if the second argument is anything
3158 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3160 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3161 && arg
->next
!= NULL
&& arg
->next
->expr
)
3163 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3166 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3169 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3174 if (arg
->expr
!= NULL
3175 && arg
->expr
->rank
> 0
3176 && resolve_assumed_size_actual (arg
->expr
))
3182 need_full_assumed_size
= temp
;
3185 if (!pure_function (expr
, &name
) && name
)
3189 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3190 "FORALL %s", name
, &expr
->where
,
3191 forall_flag
== 2 ? "mask" : "block");
3194 else if (do_concurrent_flag
)
3196 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3197 "DO CONCURRENT %s", name
, &expr
->where
,
3198 do_concurrent_flag
== 2 ? "mask" : "block");
3201 else if (gfc_pure (NULL
))
3203 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3204 "procedure within a PURE procedure", name
, &expr
->where
);
3208 if (gfc_implicit_pure (NULL
))
3209 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3212 /* Functions without the RECURSIVE attribution are not allowed to
3213 * call themselves. */
3214 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3217 esym
= expr
->value
.function
.esym
;
3219 if (is_illegal_recursion (esym
, gfc_current_ns
))
3221 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3222 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3223 " function '%s' is not RECURSIVE",
3224 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3226 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3227 " is not RECURSIVE", esym
->name
, &expr
->where
);
3233 /* Character lengths of use associated functions may contains references to
3234 symbols not referenced from the current program unit otherwise. Make sure
3235 those symbols are marked as referenced. */
3237 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3238 && expr
->value
.function
.esym
->attr
.use_assoc
)
3240 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3243 /* Make sure that the expression has a typespec that works. */
3244 if (expr
->ts
.type
== BT_UNKNOWN
)
3246 if (expr
->symtree
->n
.sym
->result
3247 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3248 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3249 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3256 /************* Subroutine resolution *************/
3259 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3265 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3266 sym
->name
, &c
->loc
);
3267 else if (do_concurrent_flag
)
3268 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3269 "PURE", sym
->name
, &c
->loc
);
3270 else if (gfc_pure (NULL
))
3271 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3274 if (gfc_implicit_pure (NULL
))
3275 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3280 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3284 if (sym
->attr
.generic
)
3286 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3289 c
->resolved_sym
= s
;
3290 pure_subroutine (c
, s
);
3294 /* TODO: Need to search for elemental references in generic interface. */
3297 if (sym
->attr
.intrinsic
)
3298 return gfc_intrinsic_sub_interface (c
, 0);
3305 resolve_generic_s (gfc_code
*c
)
3310 sym
= c
->symtree
->n
.sym
;
3314 m
= resolve_generic_s0 (c
, sym
);
3317 else if (m
== MATCH_ERROR
)
3321 if (sym
->ns
->parent
== NULL
)
3323 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3327 if (!generic_sym (sym
))
3331 /* Last ditch attempt. See if the reference is to an intrinsic
3332 that possesses a matching interface. 14.1.2.4 */
3333 sym
= c
->symtree
->n
.sym
;
3335 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3337 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3338 sym
->name
, &c
->loc
);
3342 m
= gfc_intrinsic_sub_interface (c
, 0);
3346 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3347 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3353 /* Set the name and binding label of the subroutine symbol in the call
3354 expression represented by 'c' to include the type and kind of the
3355 second parameter. This function is for resolving the appropriate
3356 version of c_f_pointer() and c_f_procpointer(). For example, a
3357 call to c_f_pointer() for a default integer pointer could have a
3358 name of c_f_pointer_i4. If no second arg exists, which is an error
3359 for these two functions, it defaults to the generic symbol's name
3360 and binding label. */
3363 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3364 char *name
, const char **binding_label
)
3366 gfc_expr
*arg
= NULL
;
3370 /* The second arg of c_f_pointer and c_f_procpointer determines
3371 the type and kind for the procedure name. */
3372 arg
= c
->ext
.actual
->next
->expr
;
3376 /* Set up the name to have the given symbol's name,
3377 plus the type and kind. */
3378 /* a derived type is marked with the type letter 'u' */
3379 if (arg
->ts
.type
== BT_DERIVED
)
3382 kind
= 0; /* set the kind as 0 for now */
3386 type
= gfc_type_letter (arg
->ts
.type
);
3387 kind
= arg
->ts
.kind
;
3390 if (arg
->ts
.type
== BT_CHARACTER
)
3391 /* Kind info for character strings not needed. */
3394 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3395 /* Set up the binding label as the given symbol's label plus
3396 the type and kind. */
3397 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3402 /* If the second arg is missing, set the name and label as
3403 was, cause it should at least be found, and the missing
3404 arg error will be caught by compare_parameters(). */
3405 sprintf (name
, "%s", sym
->name
);
3406 *binding_label
= sym
->binding_label
;
3413 /* Resolve a generic version of the iso_c_binding procedure given
3414 (sym) to the specific one based on the type and kind of the
3415 argument(s). Currently, this function resolves c_f_pointer() and
3416 c_f_procpointer based on the type and kind of the second argument
3417 (FPTR). Other iso_c_binding procedures aren't specially handled.
3418 Upon successfully exiting, c->resolved_sym will hold the resolved
3419 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3423 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3425 gfc_symbol
*new_sym
;
3426 /* this is fine, since we know the names won't use the max */
3427 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3428 const char* binding_label
;
3429 /* default to success; will override if find error */
3430 match m
= MATCH_YES
;
3432 /* Make sure the actual arguments are in the necessary order (based on the
3433 formal args) before resolving. */
3434 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3436 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3437 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3439 set_name_and_label (c
, sym
, name
, &binding_label
);
3441 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3443 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3445 /* Make sure we got a third arg if the second arg has non-zero
3446 rank. We must also check that the type and rank are
3447 correct since we short-circuit this check in
3448 gfc_procedure_use() (called above to sort actual args). */
3449 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3451 if(c
->ext
.actual
->next
->next
== NULL
3452 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3455 gfc_error ("Missing SHAPE parameter for call to %s "
3456 "at %L", sym
->name
, &(c
->loc
));
3458 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3460 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3463 gfc_error ("SHAPE parameter for call to %s at %L must "
3464 "be a rank 1 INTEGER array", sym
->name
,
3471 if (m
!= MATCH_ERROR
)
3473 /* the 1 means to add the optional arg to formal list */
3474 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3476 /* for error reporting, say it's declared where the original was */
3477 new_sym
->declared_at
= sym
->declared_at
;
3482 /* no differences for c_loc or c_funloc */
3486 /* set the resolved symbol */
3487 if (m
!= MATCH_ERROR
)
3488 c
->resolved_sym
= new_sym
;
3490 c
->resolved_sym
= sym
;
3496 /* Resolve a subroutine call known to be specific. */
3499 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3503 if(sym
->attr
.is_iso_c
)
3505 m
= gfc_iso_c_sub_interface (c
,sym
);
3509 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3511 if (sym
->attr
.dummy
)
3513 sym
->attr
.proc
= PROC_DUMMY
;
3517 sym
->attr
.proc
= PROC_EXTERNAL
;
3521 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3524 if (sym
->attr
.intrinsic
)
3526 m
= gfc_intrinsic_sub_interface (c
, 1);
3530 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3531 "with an intrinsic", sym
->name
, &c
->loc
);
3539 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3541 c
->resolved_sym
= sym
;
3542 pure_subroutine (c
, sym
);
3549 resolve_specific_s (gfc_code
*c
)
3554 sym
= c
->symtree
->n
.sym
;
3558 m
= resolve_specific_s0 (c
, sym
);
3561 if (m
== MATCH_ERROR
)
3564 if (sym
->ns
->parent
== NULL
)
3567 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3573 sym
= c
->symtree
->n
.sym
;
3574 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3575 sym
->name
, &c
->loc
);
3581 /* Resolve a subroutine call not known to be generic nor specific. */
3584 resolve_unknown_s (gfc_code
*c
)
3588 sym
= c
->symtree
->n
.sym
;
3590 if (sym
->attr
.dummy
)
3592 sym
->attr
.proc
= PROC_DUMMY
;
3596 /* See if we have an intrinsic function reference. */
3598 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3600 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3605 /* The reference is to an external name. */
3608 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3610 c
->resolved_sym
= sym
;
3612 pure_subroutine (c
, sym
);
3618 /* Resolve a subroutine call. Although it was tempting to use the same code
3619 for functions, subroutines and functions are stored differently and this
3620 makes things awkward. */
3623 resolve_call (gfc_code
*c
)
3626 procedure_type ptype
= PROC_INTRINSIC
;
3627 gfc_symbol
*csym
, *sym
;
3628 bool no_formal_args
;
3630 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3632 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3634 gfc_error ("'%s' at %L has a type, which is not consistent with "
3635 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3639 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3642 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3643 sym
= st
? st
->n
.sym
: NULL
;
3644 if (sym
&& csym
!= sym
3645 && sym
->ns
== gfc_current_ns
3646 && sym
->attr
.flavor
== FL_PROCEDURE
3647 && sym
->attr
.contained
)
3650 if (csym
->attr
.generic
)
3651 c
->symtree
->n
.sym
= sym
;
3654 csym
= c
->symtree
->n
.sym
;
3658 /* If this ia a deferred TBP with an abstract interface
3659 (which may of course be referenced), c->expr1 will be set. */
3660 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3662 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3663 csym
->name
, &c
->loc
);
3667 /* Subroutines without the RECURSIVE attribution are not allowed to
3668 * call themselves. */
3669 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3671 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3672 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3673 " subroutine '%s' is not RECURSIVE",
3674 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3676 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3677 " is not RECURSIVE", csym
->name
, &c
->loc
);
3682 /* Switch off assumed size checking and do this again for certain kinds
3683 of procedure, once the procedure itself is resolved. */
3684 need_full_assumed_size
++;
3687 ptype
= csym
->attr
.proc
;
3689 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3690 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3691 no_formal_args
) == FAILURE
)
3694 /* Resume assumed_size checking. */
3695 need_full_assumed_size
--;
3697 /* If external, check for usage. */
3698 if (csym
&& is_external_proc (csym
))
3699 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3702 if (c
->resolved_sym
== NULL
)
3704 c
->resolved_isym
= NULL
;
3705 switch (procedure_kind (csym
))
3708 t
= resolve_generic_s (c
);
3711 case PTYPE_SPECIFIC
:
3712 t
= resolve_specific_s (c
);
3716 t
= resolve_unknown_s (c
);
3720 gfc_internal_error ("resolve_subroutine(): bad function type");
3724 /* Some checks of elemental subroutine actual arguments. */
3725 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3732 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3733 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3734 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3735 if their shapes do not match. If either op1->shape or op2->shape is
3736 NULL, return SUCCESS. */
3739 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3746 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3748 for (i
= 0; i
< op1
->rank
; i
++)
3750 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3752 gfc_error ("Shapes for operands at %L and %L are not conformable",
3753 &op1
->where
, &op2
->where
);
3764 /* Resolve an operator expression node. This can involve replacing the
3765 operation with a user defined function call. */
3768 resolve_operator (gfc_expr
*e
)
3770 gfc_expr
*op1
, *op2
;
3772 bool dual_locus_error
;
3775 /* Resolve all subnodes-- give them types. */
3777 switch (e
->value
.op
.op
)
3780 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3783 /* Fall through... */
3786 case INTRINSIC_UPLUS
:
3787 case INTRINSIC_UMINUS
:
3788 case INTRINSIC_PARENTHESES
:
3789 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3794 /* Typecheck the new node. */
3796 op1
= e
->value
.op
.op1
;
3797 op2
= e
->value
.op
.op2
;
3798 dual_locus_error
= false;
3800 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3801 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3803 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3807 switch (e
->value
.op
.op
)
3809 case INTRINSIC_UPLUS
:
3810 case INTRINSIC_UMINUS
:
3811 if (op1
->ts
.type
== BT_INTEGER
3812 || op1
->ts
.type
== BT_REAL
3813 || op1
->ts
.type
== BT_COMPLEX
)
3819 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3820 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3823 case INTRINSIC_PLUS
:
3824 case INTRINSIC_MINUS
:
3825 case INTRINSIC_TIMES
:
3826 case INTRINSIC_DIVIDE
:
3827 case INTRINSIC_POWER
:
3828 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3830 gfc_type_convert_binary (e
, 1);
3835 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3836 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3837 gfc_typename (&op2
->ts
));
3840 case INTRINSIC_CONCAT
:
3841 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3842 && op1
->ts
.kind
== op2
->ts
.kind
)
3844 e
->ts
.type
= BT_CHARACTER
;
3845 e
->ts
.kind
= op1
->ts
.kind
;
3850 _("Operands of string concatenation operator at %%L are %s/%s"),
3851 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3857 case INTRINSIC_NEQV
:
3858 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3860 e
->ts
.type
= BT_LOGICAL
;
3861 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3862 if (op1
->ts
.kind
< e
->ts
.kind
)
3863 gfc_convert_type (op1
, &e
->ts
, 2);
3864 else if (op2
->ts
.kind
< e
->ts
.kind
)
3865 gfc_convert_type (op2
, &e
->ts
, 2);
3869 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3870 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3871 gfc_typename (&op2
->ts
));
3876 if (op1
->ts
.type
== BT_LOGICAL
)
3878 e
->ts
.type
= BT_LOGICAL
;
3879 e
->ts
.kind
= op1
->ts
.kind
;
3883 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3884 gfc_typename (&op1
->ts
));
3888 case INTRINSIC_GT_OS
:
3890 case INTRINSIC_GE_OS
:
3892 case INTRINSIC_LT_OS
:
3894 case INTRINSIC_LE_OS
:
3895 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3897 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3901 /* Fall through... */
3904 case INTRINSIC_EQ_OS
:
3906 case INTRINSIC_NE_OS
:
3907 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3908 && op1
->ts
.kind
== op2
->ts
.kind
)
3910 e
->ts
.type
= BT_LOGICAL
;
3911 e
->ts
.kind
= gfc_default_logical_kind
;
3915 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3917 gfc_type_convert_binary (e
, 1);
3919 e
->ts
.type
= BT_LOGICAL
;
3920 e
->ts
.kind
= gfc_default_logical_kind
;
3924 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3926 _("Logicals at %%L must be compared with %s instead of %s"),
3927 (e
->value
.op
.op
== INTRINSIC_EQ
3928 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3929 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3932 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3933 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3934 gfc_typename (&op2
->ts
));
3938 case INTRINSIC_USER
:
3939 if (e
->value
.op
.uop
->op
== NULL
)
3940 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3941 else if (op2
== NULL
)
3942 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3943 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3946 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3947 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3948 gfc_typename (&op2
->ts
));
3949 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3954 case INTRINSIC_PARENTHESES
:
3956 if (e
->ts
.type
== BT_CHARACTER
)
3957 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3961 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3964 /* Deal with arrayness of an operand through an operator. */
3968 switch (e
->value
.op
.op
)
3970 case INTRINSIC_PLUS
:
3971 case INTRINSIC_MINUS
:
3972 case INTRINSIC_TIMES
:
3973 case INTRINSIC_DIVIDE
:
3974 case INTRINSIC_POWER
:
3975 case INTRINSIC_CONCAT
:
3979 case INTRINSIC_NEQV
:
3981 case INTRINSIC_EQ_OS
:
3983 case INTRINSIC_NE_OS
:
3985 case INTRINSIC_GT_OS
:
3987 case INTRINSIC_GE_OS
:
3989 case INTRINSIC_LT_OS
:
3991 case INTRINSIC_LE_OS
:
3993 if (op1
->rank
== 0 && op2
->rank
== 0)
3996 if (op1
->rank
== 0 && op2
->rank
!= 0)
3998 e
->rank
= op2
->rank
;
4000 if (e
->shape
== NULL
)
4001 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4004 if (op1
->rank
!= 0 && op2
->rank
== 0)
4006 e
->rank
= op1
->rank
;
4008 if (e
->shape
== NULL
)
4009 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4012 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4014 if (op1
->rank
== op2
->rank
)
4016 e
->rank
= op1
->rank
;
4017 if (e
->shape
== NULL
)
4019 t
= compare_shapes (op1
, op2
);
4023 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4028 /* Allow higher level expressions to work. */
4031 /* Try user-defined operators, and otherwise throw an error. */
4032 dual_locus_error
= true;
4034 _("Inconsistent ranks for operator at %%L and %%L"));
4041 case INTRINSIC_PARENTHESES
:
4043 case INTRINSIC_UPLUS
:
4044 case INTRINSIC_UMINUS
:
4045 /* Simply copy arrayness attribute */
4046 e
->rank
= op1
->rank
;
4048 if (e
->shape
== NULL
)
4049 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4057 /* Attempt to simplify the expression. */
4060 t
= gfc_simplify_expr (e
, 0);
4061 /* Some calls do not succeed in simplification and return FAILURE
4062 even though there is no error; e.g. variable references to
4063 PARAMETER arrays. */
4064 if (!gfc_is_constant_expr (e
))
4072 match m
= gfc_extend_expr (e
);
4075 if (m
== MATCH_ERROR
)
4079 if (dual_locus_error
)
4080 gfc_error (msg
, &op1
->where
, &op2
->where
);
4082 gfc_error (msg
, &e
->where
);
4088 /************** Array resolution subroutines **************/
4091 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4094 /* Compare two integer expressions. */
4097 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4101 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4102 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4105 /* If either of the types isn't INTEGER, we must have
4106 raised an error earlier. */
4108 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4111 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4121 /* Compare an integer expression with an integer. */
4124 compare_bound_int (gfc_expr
*a
, int b
)
4128 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4131 if (a
->ts
.type
!= BT_INTEGER
)
4132 gfc_internal_error ("compare_bound_int(): Bad expression");
4134 i
= mpz_cmp_si (a
->value
.integer
, b
);
4144 /* Compare an integer expression with a mpz_t. */
4147 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4151 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4154 if (a
->ts
.type
!= BT_INTEGER
)
4155 gfc_internal_error ("compare_bound_int(): Bad expression");
4157 i
= mpz_cmp (a
->value
.integer
, b
);
4167 /* Compute the last value of a sequence given by a triplet.
4168 Return 0 if it wasn't able to compute the last value, or if the
4169 sequence if empty, and 1 otherwise. */
4172 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4173 gfc_expr
*stride
, mpz_t last
)
4177 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4178 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4179 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4182 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4183 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4186 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4188 if (compare_bound (start
, end
) == CMP_GT
)
4190 mpz_set (last
, end
->value
.integer
);
4194 if (compare_bound_int (stride
, 0) == CMP_GT
)
4196 /* Stride is positive */
4197 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4202 /* Stride is negative */
4203 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4208 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4209 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4210 mpz_sub (last
, end
->value
.integer
, rem
);
4217 /* Compare a single dimension of an array reference to the array
4221 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4225 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4227 gcc_assert (ar
->stride
[i
] == NULL
);
4228 /* This implies [*] as [*:] and [*:3] are not possible. */
4229 if (ar
->start
[i
] == NULL
)
4231 gcc_assert (ar
->end
[i
] == NULL
);
4236 /* Given start, end and stride values, calculate the minimum and
4237 maximum referenced indexes. */
4239 switch (ar
->dimen_type
[i
])
4242 case DIMEN_THIS_IMAGE
:
4247 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4250 gfc_warning ("Array reference at %L is out of bounds "
4251 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4252 mpz_get_si (ar
->start
[i
]->value
.integer
),
4253 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4255 gfc_warning ("Array reference at %L is out of bounds "
4256 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4257 mpz_get_si (ar
->start
[i
]->value
.integer
),
4258 mpz_get_si (as
->lower
[i
]->value
.integer
),
4262 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4265 gfc_warning ("Array reference at %L is out of bounds "
4266 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4267 mpz_get_si (ar
->start
[i
]->value
.integer
),
4268 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4270 gfc_warning ("Array reference at %L is out of bounds "
4271 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4272 mpz_get_si (ar
->start
[i
]->value
.integer
),
4273 mpz_get_si (as
->upper
[i
]->value
.integer
),
4282 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4283 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4285 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4287 /* Check for zero stride, which is not allowed. */
4288 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4290 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4294 /* if start == len || (stride > 0 && start < len)
4295 || (stride < 0 && start > len),
4296 then the array section contains at least one element. In this
4297 case, there is an out-of-bounds access if
4298 (start < lower || start > upper). */
4299 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4300 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4301 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4302 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4303 && comp_start_end
== CMP_GT
))
4305 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4307 gfc_warning ("Lower array reference at %L is out of bounds "
4308 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4309 mpz_get_si (AR_START
->value
.integer
),
4310 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4313 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4315 gfc_warning ("Lower array reference at %L is out of bounds "
4316 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4317 mpz_get_si (AR_START
->value
.integer
),
4318 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4323 /* If we can compute the highest index of the array section,
4324 then it also has to be between lower and upper. */
4325 mpz_init (last_value
);
4326 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4329 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4331 gfc_warning ("Upper array reference at %L is out of bounds "
4332 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4333 mpz_get_si (last_value
),
4334 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4335 mpz_clear (last_value
);
4338 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4340 gfc_warning ("Upper array reference at %L is out of bounds "
4341 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4342 mpz_get_si (last_value
),
4343 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4344 mpz_clear (last_value
);
4348 mpz_clear (last_value
);
4356 gfc_internal_error ("check_dimension(): Bad array reference");
4363 /* Compare an array reference with an array specification. */
4366 compare_spec_to_ref (gfc_array_ref
*ar
)
4373 /* TODO: Full array sections are only allowed as actual parameters. */
4374 if (as
->type
== AS_ASSUMED_SIZE
4375 && (/*ar->type == AR_FULL
4376 ||*/ (ar
->type
== AR_SECTION
4377 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4379 gfc_error ("Rightmost upper bound of assumed size array section "
4380 "not specified at %L", &ar
->where
);
4384 if (ar
->type
== AR_FULL
)
4387 if (as
->rank
!= ar
->dimen
)
4389 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4390 &ar
->where
, ar
->dimen
, as
->rank
);
4394 /* ar->codimen == 0 is a local array. */
4395 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4397 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4398 &ar
->where
, ar
->codimen
, as
->corank
);
4402 for (i
= 0; i
< as
->rank
; i
++)
4403 if (check_dimension (i
, ar
, as
) == FAILURE
)
4406 /* Local access has no coarray spec. */
4407 if (ar
->codimen
!= 0)
4408 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4410 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4411 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4413 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4414 i
+ 1 - as
->rank
, &ar
->where
);
4417 if (check_dimension (i
, ar
, as
) == FAILURE
)
4425 /* Resolve one part of an array index. */
4428 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4429 int force_index_integer_kind
)
4436 if (gfc_resolve_expr (index
) == FAILURE
)
4439 if (check_scalar
&& index
->rank
!= 0)
4441 gfc_error ("Array index at %L must be scalar", &index
->where
);
4445 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4447 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4448 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4452 if (index
->ts
.type
== BT_REAL
)
4453 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4454 &index
->where
) == FAILURE
)
4457 if ((index
->ts
.kind
!= gfc_index_integer_kind
4458 && force_index_integer_kind
)
4459 || index
->ts
.type
!= BT_INTEGER
)
4462 ts
.type
= BT_INTEGER
;
4463 ts
.kind
= gfc_index_integer_kind
;
4465 gfc_convert_type_warn (index
, &ts
, 2, 0);
4471 /* Resolve one part of an array index. */
4474 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4476 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4479 /* Resolve a dim argument to an intrinsic function. */
4482 gfc_resolve_dim_arg (gfc_expr
*dim
)
4487 if (gfc_resolve_expr (dim
) == FAILURE
)
4492 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4497 if (dim
->ts
.type
!= BT_INTEGER
)
4499 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4503 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4508 ts
.type
= BT_INTEGER
;
4509 ts
.kind
= gfc_index_integer_kind
;
4511 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4517 /* Given an expression that contains array references, update those array
4518 references to point to the right array specifications. While this is
4519 filled in during matching, this information is difficult to save and load
4520 in a module, so we take care of it here.
4522 The idea here is that the original array reference comes from the
4523 base symbol. We traverse the list of reference structures, setting
4524 the stored reference to references. Component references can
4525 provide an additional array specification. */
4528 find_array_spec (gfc_expr
*e
)
4534 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4535 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4537 as
= e
->symtree
->n
.sym
->as
;
4539 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4544 gfc_internal_error ("find_array_spec(): Missing spec");
4551 c
= ref
->u
.c
.component
;
4552 if (c
->attr
.dimension
)
4555 gfc_internal_error ("find_array_spec(): unused as(1)");
4566 gfc_internal_error ("find_array_spec(): unused as(2)");
4570 /* Resolve an array reference. */
4573 resolve_array_ref (gfc_array_ref
*ar
)
4575 int i
, check_scalar
;
4578 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4580 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4582 /* Do not force gfc_index_integer_kind for the start. We can
4583 do fine with any integer kind. This avoids temporary arrays
4584 created for indexing with a vector. */
4585 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4587 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4589 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4594 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4598 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4602 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4603 if (e
->expr_type
== EXPR_VARIABLE
4604 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4605 ar
->start
[i
] = gfc_get_parentheses (e
);
4609 gfc_error ("Array index at %L is an array of rank %d",
4610 &ar
->c_where
[i
], e
->rank
);
4614 /* Fill in the upper bound, which may be lower than the
4615 specified one for something like a(2:10:5), which is
4616 identical to a(2:7:5). Only relevant for strides not equal
4617 to one. Don't try a division by zero. */
4618 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4619 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4620 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4621 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4625 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4627 if (ar
->end
[i
] == NULL
)
4630 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4632 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4634 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4635 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4637 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4648 if (ar
->type
== AR_FULL
)
4650 if (ar
->as
->rank
== 0)
4651 ar
->type
= AR_ELEMENT
;
4653 /* Make sure array is the same as array(:,:), this way
4654 we don't need to special case all the time. */
4655 ar
->dimen
= ar
->as
->rank
;
4656 for (i
= 0; i
< ar
->dimen
; i
++)
4658 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4660 gcc_assert (ar
->start
[i
] == NULL
);
4661 gcc_assert (ar
->end
[i
] == NULL
);
4662 gcc_assert (ar
->stride
[i
] == NULL
);
4666 /* If the reference type is unknown, figure out what kind it is. */
4668 if (ar
->type
== AR_UNKNOWN
)
4670 ar
->type
= AR_ELEMENT
;
4671 for (i
= 0; i
< ar
->dimen
; i
++)
4672 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4673 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4675 ar
->type
= AR_SECTION
;
4680 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4683 if (ar
->as
->corank
&& ar
->codimen
== 0)
4686 ar
->codimen
= ar
->as
->corank
;
4687 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4688 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4696 resolve_substring (gfc_ref
*ref
)
4698 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4700 if (ref
->u
.ss
.start
!= NULL
)
4702 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4705 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4707 gfc_error ("Substring start index at %L must be of type INTEGER",
4708 &ref
->u
.ss
.start
->where
);
4712 if (ref
->u
.ss
.start
->rank
!= 0)
4714 gfc_error ("Substring start index at %L must be scalar",
4715 &ref
->u
.ss
.start
->where
);
4719 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4720 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4721 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4723 gfc_error ("Substring start index at %L is less than one",
4724 &ref
->u
.ss
.start
->where
);
4729 if (ref
->u
.ss
.end
!= NULL
)
4731 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4734 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4736 gfc_error ("Substring end index at %L must be of type INTEGER",
4737 &ref
->u
.ss
.end
->where
);
4741 if (ref
->u
.ss
.end
->rank
!= 0)
4743 gfc_error ("Substring end index at %L must be scalar",
4744 &ref
->u
.ss
.end
->where
);
4748 if (ref
->u
.ss
.length
!= NULL
4749 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4750 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4751 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4753 gfc_error ("Substring end index at %L exceeds the string length",
4754 &ref
->u
.ss
.start
->where
);
4758 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4759 gfc_integer_kinds
[k
].huge
) == CMP_GT
4760 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4761 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4763 gfc_error ("Substring end index at %L is too large",
4764 &ref
->u
.ss
.end
->where
);
4773 /* This function supplies missing substring charlens. */
4776 gfc_resolve_substring_charlen (gfc_expr
*e
)
4779 gfc_expr
*start
, *end
;
4781 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4782 if (char_ref
->type
== REF_SUBSTRING
)
4788 gcc_assert (char_ref
->next
== NULL
);
4792 if (e
->ts
.u
.cl
->length
)
4793 gfc_free_expr (e
->ts
.u
.cl
->length
);
4794 else if (e
->expr_type
== EXPR_VARIABLE
4795 && e
->symtree
->n
.sym
->attr
.dummy
)
4799 e
->ts
.type
= BT_CHARACTER
;
4800 e
->ts
.kind
= gfc_default_character_kind
;
4803 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4805 if (char_ref
->u
.ss
.start
)
4806 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4808 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4810 if (char_ref
->u
.ss
.end
)
4811 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4812 else if (e
->expr_type
== EXPR_VARIABLE
)
4813 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4820 /* Length = (end - start +1). */
4821 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4822 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4823 gfc_get_int_expr (gfc_default_integer_kind
,
4826 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4827 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4829 /* Make sure that the length is simplified. */
4830 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4831 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4835 /* Resolve subtype references. */
4838 resolve_ref (gfc_expr
*expr
)
4840 int current_part_dimension
, n_components
, seen_part_dimension
;
4843 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4844 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4846 find_array_spec (expr
);
4850 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4854 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4862 if (resolve_substring (ref
) == FAILURE
)
4867 /* Check constraints on part references. */
4869 current_part_dimension
= 0;
4870 seen_part_dimension
= 0;
4873 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4878 switch (ref
->u
.ar
.type
)
4881 /* Coarray scalar. */
4882 if (ref
->u
.ar
.as
->rank
== 0)
4884 current_part_dimension
= 0;
4889 current_part_dimension
= 1;
4893 current_part_dimension
= 0;
4897 gfc_internal_error ("resolve_ref(): Bad array reference");
4903 if (current_part_dimension
|| seen_part_dimension
)
4906 if (ref
->u
.c
.component
->attr
.pointer
4907 || ref
->u
.c
.component
->attr
.proc_pointer
4908 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4909 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4911 gfc_error ("Component to the right of a part reference "
4912 "with nonzero rank must not have the POINTER "
4913 "attribute at %L", &expr
->where
);
4916 else if (ref
->u
.c
.component
->attr
.allocatable
4917 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4918 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4921 gfc_error ("Component to the right of a part reference "
4922 "with nonzero rank must not have the ALLOCATABLE "
4923 "attribute at %L", &expr
->where
);
4935 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4936 || ref
->next
== NULL
)
4937 && current_part_dimension
4938 && seen_part_dimension
)
4940 gfc_error ("Two or more part references with nonzero rank must "
4941 "not be specified at %L", &expr
->where
);
4945 if (ref
->type
== REF_COMPONENT
)
4947 if (current_part_dimension
)
4948 seen_part_dimension
= 1;
4950 /* reset to make sure */
4951 current_part_dimension
= 0;
4959 /* Given an expression, determine its shape. This is easier than it sounds.
4960 Leaves the shape array NULL if it is not possible to determine the shape. */
4963 expression_shape (gfc_expr
*e
)
4965 mpz_t array
[GFC_MAX_DIMENSIONS
];
4968 if (e
->rank
== 0 || e
->shape
!= NULL
)
4971 for (i
= 0; i
< e
->rank
; i
++)
4972 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4975 e
->shape
= gfc_get_shape (e
->rank
);
4977 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4982 for (i
--; i
>= 0; i
--)
4983 mpz_clear (array
[i
]);
4987 /* Given a variable expression node, compute the rank of the expression by
4988 examining the base symbol and any reference structures it may have. */
4991 expression_rank (gfc_expr
*e
)
4996 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4997 could lead to serious confusion... */
4998 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5002 if (e
->expr_type
== EXPR_ARRAY
)
5004 /* Constructors can have a rank different from one via RESHAPE(). */
5006 if (e
->symtree
== NULL
)
5012 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5013 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5019 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5021 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5022 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5023 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5025 if (ref
->type
!= REF_ARRAY
)
5028 if (ref
->u
.ar
.type
== AR_FULL
)
5030 rank
= ref
->u
.ar
.as
->rank
;
5034 if (ref
->u
.ar
.type
== AR_SECTION
)
5036 /* Figure out the rank of the section. */
5038 gfc_internal_error ("expression_rank(): Two array specs");
5040 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5041 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5042 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5052 expression_shape (e
);
5056 /* Resolve a variable expression. */
5059 resolve_variable (gfc_expr
*e
)
5066 if (e
->symtree
== NULL
)
5068 sym
= e
->symtree
->n
.sym
;
5070 /* TS 29113, 407b. */
5071 if (e
->ts
.type
== BT_ASSUMED
&& !assumed_type_expr_allowed
)
5073 gfc_error ("Invalid expression with assumed-type variable %s at %L",
5074 sym
->name
, &e
->where
);
5078 /* TS 29113, 407b. */
5079 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5080 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5081 && e
->ref
->next
== NULL
))
5083 gfc_error ("Assumed-type variable %s with designator at %L",
5084 sym
->name
, &e
->ref
->u
.ar
.where
);
5088 /* If this is an associate-name, it may be parsed with an array reference
5089 in error even though the target is scalar. Fail directly in this case.
5090 TODO Understand why class scalar expressions must be excluded. */
5091 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5093 if (sym
->ts
.type
== BT_CLASS
)
5094 gfc_fix_class_refs (e
);
5095 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5099 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5100 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5102 /* On the other hand, the parser may not have known this is an array;
5103 in this case, we have to add a FULL reference. */
5104 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5106 e
->ref
= gfc_get_ref ();
5107 e
->ref
->type
= REF_ARRAY
;
5108 e
->ref
->u
.ar
.type
= AR_FULL
;
5109 e
->ref
->u
.ar
.dimen
= 0;
5112 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5115 if (sym
->attr
.flavor
== FL_PROCEDURE
5116 && (!sym
->attr
.function
5117 || (sym
->attr
.function
&& sym
->result
5118 && sym
->result
->attr
.proc_pointer
5119 && !sym
->result
->attr
.function
)))
5121 e
->ts
.type
= BT_PROCEDURE
;
5122 goto resolve_procedure
;
5125 if (sym
->ts
.type
!= BT_UNKNOWN
)
5126 gfc_variable_attr (e
, &e
->ts
);
5129 /* Must be a simple variable reference. */
5130 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5135 if (check_assumed_size_reference (sym
, e
))
5138 /* If a PRIVATE variable is used in the specification expression of the
5139 result variable, it might be accessed from outside the module and can
5140 thus not be TREE_PUBLIC() = 0.
5141 TODO: sym->attr.public_used only has to be set for the result variable's
5142 type-parameter expression and not for dummies or automatic variables.
5143 Additionally, it only has to be set if the function is either PUBLIC or
5144 used in a generic interface or TBP; unfortunately,
5145 proc_name->attr.public_used can get set at a later stage. */
5146 if (specification_expr
&& sym
->attr
.access
== ACCESS_PRIVATE
5147 && !sym
->attr
.function
&& !sym
->attr
.use_assoc
5148 && gfc_current_ns
->proc_name
&& gfc_current_ns
->proc_name
->attr
.function
)
5149 sym
->attr
.public_used
= 1;
5151 /* Deal with forward references to entries during resolve_code, to
5152 satisfy, at least partially, 12.5.2.5. */
5153 if (gfc_current_ns
->entries
5154 && current_entry_id
== sym
->entry_id
5157 && cs_base
->current
->op
!= EXEC_ENTRY
)
5159 gfc_entry_list
*entry
;
5160 gfc_formal_arglist
*formal
;
5164 /* If the symbol is a dummy... */
5165 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5167 entry
= gfc_current_ns
->entries
;
5170 /* ...test if the symbol is a parameter of previous entries. */
5171 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5172 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5174 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5178 /* If it has not been seen as a dummy, this is an error. */
5181 if (specification_expr
)
5182 gfc_error ("Variable '%s', used in a specification expression"
5183 ", is referenced at %L before the ENTRY statement "
5184 "in which it is a parameter",
5185 sym
->name
, &cs_base
->current
->loc
);
5187 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5188 "statement in which it is a parameter",
5189 sym
->name
, &cs_base
->current
->loc
);
5194 /* Now do the same check on the specification expressions. */
5195 specification_expr
= 1;
5196 if (sym
->ts
.type
== BT_CHARACTER
5197 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5201 for (n
= 0; n
< sym
->as
->rank
; n
++)
5203 specification_expr
= 1;
5204 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5206 specification_expr
= 1;
5207 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5210 specification_expr
= 0;
5213 /* Update the symbol's entry level. */
5214 sym
->entry_id
= current_entry_id
+ 1;
5217 /* If a symbol has been host_associated mark it. This is used latter,
5218 to identify if aliasing is possible via host association. */
5219 if (sym
->attr
.flavor
== FL_VARIABLE
5220 && gfc_current_ns
->parent
5221 && (gfc_current_ns
->parent
== sym
->ns
5222 || (gfc_current_ns
->parent
->parent
5223 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5224 sym
->attr
.host_assoc
= 1;
5227 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5230 /* F2008, C617 and C1229. */
5231 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5232 && gfc_is_coindexed (e
))
5234 gfc_ref
*ref
, *ref2
= NULL
;
5236 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5238 if (ref
->type
== REF_COMPONENT
)
5240 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5244 for ( ; ref
; ref
= ref
->next
)
5245 if (ref
->type
== REF_COMPONENT
)
5248 /* Expression itself is not coindexed object. */
5249 if (ref
&& e
->ts
.type
== BT_CLASS
)
5251 gfc_error ("Polymorphic subobject of coindexed object at %L",
5256 /* Expression itself is coindexed object. */
5260 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5261 for ( ; c
; c
= c
->next
)
5262 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5264 gfc_error ("Coindexed object with polymorphic allocatable "
5265 "subcomponent at %L", &e
->where
);
5276 /* Checks to see that the correct symbol has been host associated.
5277 The only situation where this arises is that in which a twice
5278 contained function is parsed after the host association is made.
5279 Therefore, on detecting this, change the symbol in the expression
5280 and convert the array reference into an actual arglist if the old
5281 symbol is a variable. */
5283 check_host_association (gfc_expr
*e
)
5285 gfc_symbol
*sym
, *old_sym
;
5289 gfc_actual_arglist
*arg
, *tail
= NULL
;
5290 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5292 /* If the expression is the result of substitution in
5293 interface.c(gfc_extend_expr) because there is no way in
5294 which the host association can be wrong. */
5295 if (e
->symtree
== NULL
5296 || e
->symtree
->n
.sym
== NULL
5297 || e
->user_operator
)
5300 old_sym
= e
->symtree
->n
.sym
;
5302 if (gfc_current_ns
->parent
5303 && old_sym
->ns
!= gfc_current_ns
)
5305 /* Use the 'USE' name so that renamed module symbols are
5306 correctly handled. */
5307 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5309 if (sym
&& old_sym
!= sym
5310 && sym
->ts
.type
== old_sym
->ts
.type
5311 && sym
->attr
.flavor
== FL_PROCEDURE
5312 && sym
->attr
.contained
)
5314 /* Clear the shape, since it might not be valid. */
5315 gfc_free_shape (&e
->shape
, e
->rank
);
5317 /* Give the expression the right symtree! */
5318 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5319 gcc_assert (st
!= NULL
);
5321 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5322 || e
->expr_type
== EXPR_FUNCTION
)
5324 /* Original was function so point to the new symbol, since
5325 the actual argument list is already attached to the
5327 e
->value
.function
.esym
= NULL
;
5332 /* Original was variable so convert array references into
5333 an actual arglist. This does not need any checking now
5334 since resolve_function will take care of it. */
5335 e
->value
.function
.actual
= NULL
;
5336 e
->expr_type
= EXPR_FUNCTION
;
5339 /* Ambiguity will not arise if the array reference is not
5340 the last reference. */
5341 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5342 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5345 gcc_assert (ref
->type
== REF_ARRAY
);
5347 /* Grab the start expressions from the array ref and
5348 copy them into actual arguments. */
5349 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5351 arg
= gfc_get_actual_arglist ();
5352 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5353 if (e
->value
.function
.actual
== NULL
)
5354 tail
= e
->value
.function
.actual
= arg
;
5362 /* Dump the reference list and set the rank. */
5363 gfc_free_ref_list (e
->ref
);
5365 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5368 gfc_resolve_expr (e
);
5372 /* This might have changed! */
5373 return e
->expr_type
== EXPR_FUNCTION
;
5378 gfc_resolve_character_operator (gfc_expr
*e
)
5380 gfc_expr
*op1
= e
->value
.op
.op1
;
5381 gfc_expr
*op2
= e
->value
.op
.op2
;
5382 gfc_expr
*e1
= NULL
;
5383 gfc_expr
*e2
= NULL
;
5385 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5387 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5388 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5389 else if (op1
->expr_type
== EXPR_CONSTANT
)
5390 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5391 op1
->value
.character
.length
);
5393 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5394 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5395 else if (op2
->expr_type
== EXPR_CONSTANT
)
5396 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5397 op2
->value
.character
.length
);
5399 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5404 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5405 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5406 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5407 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5408 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5414 /* Ensure that an character expression has a charlen and, if possible, a
5415 length expression. */
5418 fixup_charlen (gfc_expr
*e
)
5420 /* The cases fall through so that changes in expression type and the need
5421 for multiple fixes are picked up. In all circumstances, a charlen should
5422 be available for the middle end to hang a backend_decl on. */
5423 switch (e
->expr_type
)
5426 gfc_resolve_character_operator (e
);
5429 if (e
->expr_type
== EXPR_ARRAY
)
5430 gfc_resolve_character_array_constructor (e
);
5432 case EXPR_SUBSTRING
:
5433 if (!e
->ts
.u
.cl
&& e
->ref
)
5434 gfc_resolve_substring_charlen (e
);
5438 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5445 /* Update an actual argument to include the passed-object for type-bound
5446 procedures at the right position. */
5448 static gfc_actual_arglist
*
5449 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5452 gcc_assert (argpos
> 0);
5456 gfc_actual_arglist
* result
;
5458 result
= gfc_get_actual_arglist ();
5462 result
->name
= name
;
5468 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5470 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5475 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5478 extract_compcall_passed_object (gfc_expr
* e
)
5482 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5484 if (e
->value
.compcall
.base_object
)
5485 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5488 po
= gfc_get_expr ();
5489 po
->expr_type
= EXPR_VARIABLE
;
5490 po
->symtree
= e
->symtree
;
5491 po
->ref
= gfc_copy_ref (e
->ref
);
5492 po
->where
= e
->where
;
5495 if (gfc_resolve_expr (po
) == FAILURE
)
5502 /* Update the arglist of an EXPR_COMPCALL expression to include the
5506 update_compcall_arglist (gfc_expr
* e
)
5509 gfc_typebound_proc
* tbp
;
5511 tbp
= e
->value
.compcall
.tbp
;
5516 po
= extract_compcall_passed_object (e
);
5520 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5526 gcc_assert (tbp
->pass_arg_num
> 0);
5527 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5535 /* Extract the passed object from a PPC call (a copy of it). */
5538 extract_ppc_passed_object (gfc_expr
*e
)
5543 po
= gfc_get_expr ();
5544 po
->expr_type
= EXPR_VARIABLE
;
5545 po
->symtree
= e
->symtree
;
5546 po
->ref
= gfc_copy_ref (e
->ref
);
5547 po
->where
= e
->where
;
5549 /* Remove PPC reference. */
5551 while ((*ref
)->next
)
5552 ref
= &(*ref
)->next
;
5553 gfc_free_ref_list (*ref
);
5556 if (gfc_resolve_expr (po
) == FAILURE
)
5563 /* Update the actual arglist of a procedure pointer component to include the
5567 update_ppc_arglist (gfc_expr
* e
)
5571 gfc_typebound_proc
* tb
;
5573 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5580 else if (tb
->nopass
)
5583 po
= extract_ppc_passed_object (e
);
5590 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5595 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5597 gfc_error ("Base object for procedure-pointer component call at %L is of"
5598 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5602 gcc_assert (tb
->pass_arg_num
> 0);
5603 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5611 /* Check that the object a TBP is called on is valid, i.e. it must not be
5612 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5615 check_typebound_baseobject (gfc_expr
* e
)
5618 gfc_try return_value
= FAILURE
;
5620 base
= extract_compcall_passed_object (e
);
5624 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5627 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5629 gfc_error ("Base object for type-bound procedure call at %L is of"
5630 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5634 /* F08:C1230. If the procedure called is NOPASS,
5635 the base object must be scalar. */
5636 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5638 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5639 " be scalar", &e
->where
);
5643 return_value
= SUCCESS
;
5646 gfc_free_expr (base
);
5647 return return_value
;
5651 /* Resolve a call to a type-bound procedure, either function or subroutine,
5652 statically from the data in an EXPR_COMPCALL expression. The adapted
5653 arglist and the target-procedure symtree are returned. */
5656 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5657 gfc_actual_arglist
** actual
)
5659 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5660 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5662 /* Update the actual arglist for PASS. */
5663 if (update_compcall_arglist (e
) == FAILURE
)
5666 *actual
= e
->value
.compcall
.actual
;
5667 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5669 gfc_free_ref_list (e
->ref
);
5671 e
->value
.compcall
.actual
= NULL
;
5673 /* If we find a deferred typebound procedure, check for derived types
5674 that an over-riding typebound procedure has not been missed. */
5675 if (e
->value
.compcall
.tbp
->deferred
5676 && e
->value
.compcall
.name
5677 && !e
->value
.compcall
.tbp
->non_overridable
5678 && e
->value
.compcall
.base_object
5679 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5682 gfc_symbol
*derived
;
5684 /* Use the derived type of the base_object. */
5685 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5688 /* If necessary, go throught the inheritance chain. */
5689 while (!st
&& derived
)
5691 /* Look for the typebound procedure 'name'. */
5692 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5693 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5694 e
->value
.compcall
.name
);
5696 derived
= gfc_get_derived_super_type (derived
);
5699 /* Now find the specific name in the derived type namespace. */
5700 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5701 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5702 derived
->ns
, 1, &st
);
5710 /* Get the ultimate declared type from an expression. In addition,
5711 return the last class/derived type reference and the copy of the
5712 reference list. If check_types is set true, derived types are
5713 identified as well as class references. */
5715 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5716 gfc_expr
*e
, bool check_types
)
5718 gfc_symbol
*declared
;
5725 *new_ref
= gfc_copy_ref (e
->ref
);
5727 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5729 if (ref
->type
!= REF_COMPONENT
)
5732 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5733 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5734 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5736 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5742 if (declared
== NULL
)
5743 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5749 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5750 which of the specific bindings (if any) matches the arglist and transform
5751 the expression into a call of that binding. */
5754 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5756 gfc_typebound_proc
* genproc
;
5757 const char* genname
;
5759 gfc_symbol
*derived
;
5761 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5762 genname
= e
->value
.compcall
.name
;
5763 genproc
= e
->value
.compcall
.tbp
;
5765 if (!genproc
->is_generic
)
5768 /* Try the bindings on this type and in the inheritance hierarchy. */
5769 for (; genproc
; genproc
= genproc
->overridden
)
5773 gcc_assert (genproc
->is_generic
);
5774 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5777 gfc_actual_arglist
* args
;
5780 gcc_assert (g
->specific
);
5782 if (g
->specific
->error
)
5785 target
= g
->specific
->u
.specific
->n
.sym
;
5787 /* Get the right arglist by handling PASS/NOPASS. */
5788 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5789 if (!g
->specific
->nopass
)
5792 po
= extract_compcall_passed_object (e
);
5796 gcc_assert (g
->specific
->pass_arg_num
> 0);
5797 gcc_assert (!g
->specific
->error
);
5798 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5799 g
->specific
->pass_arg
);
5801 resolve_actual_arglist (args
, target
->attr
.proc
,
5802 is_external_proc (target
) && !target
->formal
);
5804 /* Check if this arglist matches the formal. */
5805 matches
= gfc_arglist_matches_symbol (&args
, target
);
5807 /* Clean up and break out of the loop if we've found it. */
5808 gfc_free_actual_arglist (args
);
5811 e
->value
.compcall
.tbp
= g
->specific
;
5812 genname
= g
->specific_st
->name
;
5813 /* Pass along the name for CLASS methods, where the vtab
5814 procedure pointer component has to be referenced. */
5822 /* Nothing matching found! */
5823 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5824 " '%s' at %L", genname
, &e
->where
);
5828 /* Make sure that we have the right specific instance for the name. */
5829 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5831 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5833 e
->value
.compcall
.tbp
= st
->n
.tb
;
5839 /* Resolve a call to a type-bound subroutine. */
5842 resolve_typebound_call (gfc_code
* c
, const char **name
)
5844 gfc_actual_arglist
* newactual
;
5845 gfc_symtree
* target
;
5847 /* Check that's really a SUBROUTINE. */
5848 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5850 gfc_error ("'%s' at %L should be a SUBROUTINE",
5851 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5855 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5858 /* Pass along the name for CLASS methods, where the vtab
5859 procedure pointer component has to be referenced. */
5861 *name
= c
->expr1
->value
.compcall
.name
;
5863 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5866 /* Transform into an ordinary EXEC_CALL for now. */
5868 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5871 c
->ext
.actual
= newactual
;
5872 c
->symtree
= target
;
5873 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5875 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5877 gfc_free_expr (c
->expr1
);
5878 c
->expr1
= gfc_get_expr ();
5879 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5880 c
->expr1
->symtree
= target
;
5881 c
->expr1
->where
= c
->loc
;
5883 return resolve_call (c
);
5887 /* Resolve a component-call expression. */
5889 resolve_compcall (gfc_expr
* e
, const char **name
)
5891 gfc_actual_arglist
* newactual
;
5892 gfc_symtree
* target
;
5894 /* Check that's really a FUNCTION. */
5895 if (!e
->value
.compcall
.tbp
->function
)
5897 gfc_error ("'%s' at %L should be a FUNCTION",
5898 e
->value
.compcall
.name
, &e
->where
);
5902 /* These must not be assign-calls! */
5903 gcc_assert (!e
->value
.compcall
.assign
);
5905 if (check_typebound_baseobject (e
) == FAILURE
)
5908 /* Pass along the name for CLASS methods, where the vtab
5909 procedure pointer component has to be referenced. */
5911 *name
= e
->value
.compcall
.name
;
5913 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5915 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5917 /* Take the rank from the function's symbol. */
5918 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5919 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5921 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5922 arglist to the TBP's binding target. */
5924 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5927 e
->value
.function
.actual
= newactual
;
5928 e
->value
.function
.name
= NULL
;
5929 e
->value
.function
.esym
= target
->n
.sym
;
5930 e
->value
.function
.isym
= NULL
;
5931 e
->symtree
= target
;
5932 e
->ts
= target
->n
.sym
->ts
;
5933 e
->expr_type
= EXPR_FUNCTION
;
5935 /* Resolution is not necessary if this is a class subroutine; this
5936 function only has to identify the specific proc. Resolution of
5937 the call will be done next in resolve_typebound_call. */
5938 return gfc_resolve_expr (e
);
5943 /* Resolve a typebound function, or 'method'. First separate all
5944 the non-CLASS references by calling resolve_compcall directly. */
5947 resolve_typebound_function (gfc_expr
* e
)
5949 gfc_symbol
*declared
;
5961 /* Deal with typebound operators for CLASS objects. */
5962 expr
= e
->value
.compcall
.base_object
;
5963 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5964 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5966 /* If the base_object is not a variable, the corresponding actual
5967 argument expression must be stored in e->base_expression so
5968 that the corresponding tree temporary can be used as the base
5969 object in gfc_conv_procedure_call. */
5970 if (expr
->expr_type
!= EXPR_VARIABLE
)
5972 gfc_actual_arglist
*args
;
5974 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5976 if (expr
== args
->expr
)
5981 /* Since the typebound operators are generic, we have to ensure
5982 that any delays in resolution are corrected and that the vtab
5985 declared
= ts
.u
.derived
;
5986 c
= gfc_find_component (declared
, "_vptr", true, true);
5987 if (c
->ts
.u
.derived
== NULL
)
5988 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5990 if (resolve_compcall (e
, &name
) == FAILURE
)
5993 /* Use the generic name if it is there. */
5994 name
= name
? name
: e
->value
.function
.esym
->name
;
5995 e
->symtree
= expr
->symtree
;
5996 e
->ref
= gfc_copy_ref (expr
->ref
);
5997 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5999 /* Trim away the extraneous references that emerge from nested
6000 use of interface.c (extend_expr). */
6001 if (class_ref
&& class_ref
->next
)
6003 gfc_free_ref_list (class_ref
->next
);
6004 class_ref
->next
= NULL
;
6006 else if (e
->ref
&& !class_ref
)
6008 gfc_free_ref_list (e
->ref
);
6012 gfc_add_vptr_component (e
);
6013 gfc_add_component_ref (e
, name
);
6014 e
->value
.function
.esym
= NULL
;
6015 if (expr
->expr_type
!= EXPR_VARIABLE
)
6016 e
->base_expr
= expr
;
6021 return resolve_compcall (e
, NULL
);
6023 if (resolve_ref (e
) == FAILURE
)
6026 /* Get the CLASS declared type. */
6027 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6029 /* Weed out cases of the ultimate component being a derived type. */
6030 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6031 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6033 gfc_free_ref_list (new_ref
);
6034 return resolve_compcall (e
, NULL
);
6037 c
= gfc_find_component (declared
, "_data", true, true);
6038 declared
= c
->ts
.u
.derived
;
6040 /* Treat the call as if it is a typebound procedure, in order to roll
6041 out the correct name for the specific function. */
6042 if (resolve_compcall (e
, &name
) == FAILURE
)
6048 /* Convert the expression to a procedure pointer component call. */
6049 e
->value
.function
.esym
= NULL
;
6055 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6056 gfc_add_vptr_component (e
);
6057 gfc_add_component_ref (e
, name
);
6059 /* Recover the typespec for the expression. This is really only
6060 necessary for generic procedures, where the additional call
6061 to gfc_add_component_ref seems to throw the collection of the
6062 correct typespec. */
6069 /* Resolve a typebound subroutine, or 'method'. First separate all
6070 the non-CLASS references by calling resolve_typebound_call
6074 resolve_typebound_subroutine (gfc_code
*code
)
6076 gfc_symbol
*declared
;
6086 st
= code
->expr1
->symtree
;
6088 /* Deal with typebound operators for CLASS objects. */
6089 expr
= code
->expr1
->value
.compcall
.base_object
;
6090 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6091 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6093 /* If the base_object is not a variable, the corresponding actual
6094 argument expression must be stored in e->base_expression so
6095 that the corresponding tree temporary can be used as the base
6096 object in gfc_conv_procedure_call. */
6097 if (expr
->expr_type
!= EXPR_VARIABLE
)
6099 gfc_actual_arglist
*args
;
6101 args
= code
->expr1
->value
.function
.actual
;
6102 for (; args
; args
= args
->next
)
6103 if (expr
== args
->expr
)
6107 /* Since the typebound operators are generic, we have to ensure
6108 that any delays in resolution are corrected and that the vtab
6110 declared
= expr
->ts
.u
.derived
;
6111 c
= gfc_find_component (declared
, "_vptr", true, true);
6112 if (c
->ts
.u
.derived
== NULL
)
6113 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6115 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6118 /* Use the generic name if it is there. */
6119 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6120 code
->expr1
->symtree
= expr
->symtree
;
6121 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6123 /* Trim away the extraneous references that emerge from nested
6124 use of interface.c (extend_expr). */
6125 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6126 if (class_ref
&& class_ref
->next
)
6128 gfc_free_ref_list (class_ref
->next
);
6129 class_ref
->next
= NULL
;
6131 else if (code
->expr1
->ref
&& !class_ref
)
6133 gfc_free_ref_list (code
->expr1
->ref
);
6134 code
->expr1
->ref
= NULL
;
6137 /* Now use the procedure in the vtable. */
6138 gfc_add_vptr_component (code
->expr1
);
6139 gfc_add_component_ref (code
->expr1
, name
);
6140 code
->expr1
->value
.function
.esym
= NULL
;
6141 if (expr
->expr_type
!= EXPR_VARIABLE
)
6142 code
->expr1
->base_expr
= expr
;
6147 return resolve_typebound_call (code
, NULL
);
6149 if (resolve_ref (code
->expr1
) == FAILURE
)
6152 /* Get the CLASS declared type. */
6153 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6155 /* Weed out cases of the ultimate component being a derived type. */
6156 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6157 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6159 gfc_free_ref_list (new_ref
);
6160 return resolve_typebound_call (code
, NULL
);
6163 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6165 ts
= code
->expr1
->ts
;
6169 /* Convert the expression to a procedure pointer component call. */
6170 code
->expr1
->value
.function
.esym
= NULL
;
6171 code
->expr1
->symtree
= st
;
6174 code
->expr1
->ref
= new_ref
;
6176 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6177 gfc_add_vptr_component (code
->expr1
);
6178 gfc_add_component_ref (code
->expr1
, name
);
6180 /* Recover the typespec for the expression. This is really only
6181 necessary for generic procedures, where the additional call
6182 to gfc_add_component_ref seems to throw the collection of the
6183 correct typespec. */
6184 code
->expr1
->ts
= ts
;
6191 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6194 resolve_ppc_call (gfc_code
* c
)
6196 gfc_component
*comp
;
6199 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6202 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6203 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6205 if (!comp
->attr
.subroutine
)
6206 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6208 if (resolve_ref (c
->expr1
) == FAILURE
)
6211 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6214 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6216 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6217 comp
->formal
== NULL
) == FAILURE
)
6220 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6226 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6229 resolve_expr_ppc (gfc_expr
* e
)
6231 gfc_component
*comp
;
6234 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6237 /* Convert to EXPR_FUNCTION. */
6238 e
->expr_type
= EXPR_FUNCTION
;
6239 e
->value
.function
.isym
= NULL
;
6240 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6242 if (comp
->as
!= NULL
)
6243 e
->rank
= comp
->as
->rank
;
6245 if (!comp
->attr
.function
)
6246 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6248 if (resolve_ref (e
) == FAILURE
)
6251 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6252 comp
->formal
== NULL
) == FAILURE
)
6255 if (update_ppc_arglist (e
) == FAILURE
)
6258 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6265 gfc_is_expandable_expr (gfc_expr
*e
)
6267 gfc_constructor
*con
;
6269 if (e
->expr_type
== EXPR_ARRAY
)
6271 /* Traverse the constructor looking for variables that are flavor
6272 parameter. Parameters must be expanded since they are fully used at
6274 con
= gfc_constructor_first (e
->value
.constructor
);
6275 for (; con
; con
= gfc_constructor_next (con
))
6277 if (con
->expr
->expr_type
== EXPR_VARIABLE
6278 && con
->expr
->symtree
6279 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6280 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6282 if (con
->expr
->expr_type
== EXPR_ARRAY
6283 && gfc_is_expandable_expr (con
->expr
))
6291 /* Resolve an expression. That is, make sure that types of operands agree
6292 with their operators, intrinsic operators are converted to function calls
6293 for overloaded types and unresolved function references are resolved. */
6296 gfc_resolve_expr (gfc_expr
*e
)
6304 /* inquiry_argument only applies to variables. */
6305 inquiry_save
= inquiry_argument
;
6306 if (e
->expr_type
!= EXPR_VARIABLE
)
6307 inquiry_argument
= false;
6309 switch (e
->expr_type
)
6312 t
= resolve_operator (e
);
6318 if (check_host_association (e
))
6319 t
= resolve_function (e
);
6322 t
= resolve_variable (e
);
6324 expression_rank (e
);
6327 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6328 && e
->ref
->type
!= REF_SUBSTRING
)
6329 gfc_resolve_substring_charlen (e
);
6334 t
= resolve_typebound_function (e
);
6337 case EXPR_SUBSTRING
:
6338 t
= resolve_ref (e
);
6347 t
= resolve_expr_ppc (e
);
6352 if (resolve_ref (e
) == FAILURE
)
6355 t
= gfc_resolve_array_constructor (e
);
6356 /* Also try to expand a constructor. */
6359 expression_rank (e
);
6360 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6361 gfc_expand_constructor (e
, false);
6364 /* This provides the opportunity for the length of constructors with
6365 character valued function elements to propagate the string length
6366 to the expression. */
6367 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6369 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6370 here rather then add a duplicate test for it above. */
6371 gfc_expand_constructor (e
, false);
6372 t
= gfc_resolve_character_array_constructor (e
);
6377 case EXPR_STRUCTURE
:
6378 t
= resolve_ref (e
);
6382 t
= resolve_structure_cons (e
, 0);
6386 t
= gfc_simplify_expr (e
, 0);
6390 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6393 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6396 inquiry_argument
= inquiry_save
;
6402 /* Resolve an expression from an iterator. They must be scalar and have
6403 INTEGER or (optionally) REAL type. */
6406 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6407 const char *name_msgid
)
6409 if (gfc_resolve_expr (expr
) == FAILURE
)
6412 if (expr
->rank
!= 0)
6414 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6418 if (expr
->ts
.type
!= BT_INTEGER
)
6420 if (expr
->ts
.type
== BT_REAL
)
6423 return gfc_notify_std (GFC_STD_F95_DEL
,
6424 "Deleted feature: %s at %L must be integer",
6425 _(name_msgid
), &expr
->where
);
6428 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6435 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6443 /* Resolve the expressions in an iterator structure. If REAL_OK is
6444 false allow only INTEGER type iterators, otherwise allow REAL types. */
6447 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6449 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6453 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6457 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6458 "Start expression in DO loop") == FAILURE
)
6461 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6462 "End expression in DO loop") == FAILURE
)
6465 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6466 "Step expression in DO loop") == FAILURE
)
6469 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6471 if ((iter
->step
->ts
.type
== BT_INTEGER
6472 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6473 || (iter
->step
->ts
.type
== BT_REAL
6474 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6476 gfc_error ("Step expression in DO loop at %L cannot be zero",
6477 &iter
->step
->where
);
6482 /* Convert start, end, and step to the same type as var. */
6483 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6484 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6485 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6487 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6488 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6489 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6491 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6492 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6493 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6495 if (iter
->start
->expr_type
== EXPR_CONSTANT
6496 && iter
->end
->expr_type
== EXPR_CONSTANT
6497 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6500 if (iter
->start
->ts
.type
== BT_INTEGER
)
6502 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6503 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6507 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6508 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6510 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6511 gfc_warning ("DO loop at %L will be executed zero times",
6512 &iter
->step
->where
);
6519 /* Traversal function for find_forall_index. f == 2 signals that
6520 that variable itself is not to be checked - only the references. */
6523 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6525 if (expr
->expr_type
!= EXPR_VARIABLE
)
6528 /* A scalar assignment */
6529 if (!expr
->ref
|| *f
== 1)
6531 if (expr
->symtree
->n
.sym
== sym
)
6543 /* Check whether the FORALL index appears in the expression or not.
6544 Returns SUCCESS if SYM is found in EXPR. */
6547 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6549 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6556 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6557 to be a scalar INTEGER variable. The subscripts and stride are scalar
6558 INTEGERs, and if stride is a constant it must be nonzero.
6559 Furthermore "A subscript or stride in a forall-triplet-spec shall
6560 not contain a reference to any index-name in the
6561 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6564 resolve_forall_iterators (gfc_forall_iterator
*it
)
6566 gfc_forall_iterator
*iter
, *iter2
;
6568 for (iter
= it
; iter
; iter
= iter
->next
)
6570 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6571 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6572 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6575 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6576 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6577 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6578 &iter
->start
->where
);
6579 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6580 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6582 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6583 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6584 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6586 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6587 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6589 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6591 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6592 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6593 &iter
->stride
->where
, "INTEGER");
6595 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6596 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6597 gfc_error ("FORALL stride expression at %L cannot be zero",
6598 &iter
->stride
->where
);
6600 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6601 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6604 for (iter
= it
; iter
; iter
= iter
->next
)
6605 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6607 if (find_forall_index (iter2
->start
,
6608 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6609 || find_forall_index (iter2
->end
,
6610 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6611 || find_forall_index (iter2
->stride
,
6612 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6613 gfc_error ("FORALL index '%s' may not appear in triplet "
6614 "specification at %L", iter
->var
->symtree
->name
,
6615 &iter2
->start
->where
);
6620 /* Given a pointer to a symbol that is a derived type, see if it's
6621 inaccessible, i.e. if it's defined in another module and the components are
6622 PRIVATE. The search is recursive if necessary. Returns zero if no
6623 inaccessible components are found, nonzero otherwise. */
6626 derived_inaccessible (gfc_symbol
*sym
)
6630 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6633 for (c
= sym
->components
; c
; c
= c
->next
)
6635 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6643 /* Resolve the argument of a deallocate expression. The expression must be
6644 a pointer or a full array. */
6647 resolve_deallocate_expr (gfc_expr
*e
)
6649 symbol_attribute attr
;
6650 int allocatable
, pointer
;
6655 if (gfc_resolve_expr (e
) == FAILURE
)
6658 if (e
->expr_type
!= EXPR_VARIABLE
)
6661 sym
= e
->symtree
->n
.sym
;
6663 if (sym
->ts
.type
== BT_CLASS
)
6665 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6666 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6670 allocatable
= sym
->attr
.allocatable
;
6671 pointer
= sym
->attr
.pointer
;
6673 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6678 if (ref
->u
.ar
.type
!= AR_FULL
6679 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6680 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6685 c
= ref
->u
.c
.component
;
6686 if (c
->ts
.type
== BT_CLASS
)
6688 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6689 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6693 allocatable
= c
->attr
.allocatable
;
6694 pointer
= c
->attr
.pointer
;
6704 attr
= gfc_expr_attr (e
);
6706 if (allocatable
== 0 && attr
.pointer
== 0)
6709 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6715 if (gfc_is_coindexed (e
))
6717 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6722 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6725 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6733 /* Returns true if the expression e contains a reference to the symbol sym. */
6735 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6737 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6744 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6746 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6750 /* Given the expression node e for an allocatable/pointer of derived type to be
6751 allocated, get the expression node to be initialized afterwards (needed for
6752 derived types with default initializers, and derived types with allocatable
6753 components that need nullification.) */
6756 gfc_expr_to_initialize (gfc_expr
*e
)
6762 result
= gfc_copy_expr (e
);
6764 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6765 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6766 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6768 ref
->u
.ar
.type
= AR_FULL
;
6770 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6771 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6776 gfc_free_shape (&result
->shape
, result
->rank
);
6778 /* Recalculate rank, shape, etc. */
6779 gfc_resolve_expr (result
);
6784 /* If the last ref of an expression is an array ref, return a copy of the
6785 expression with that one removed. Otherwise, a copy of the original
6786 expression. This is used for allocate-expressions and pointer assignment
6787 LHS, where there may be an array specification that needs to be stripped
6788 off when using gfc_check_vardef_context. */
6791 remove_last_array_ref (gfc_expr
* e
)
6796 e2
= gfc_copy_expr (e
);
6797 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6798 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6800 gfc_free_ref_list (*r
);
6809 /* Used in resolve_allocate_expr to check that a allocation-object and
6810 a source-expr are conformable. This does not catch all possible
6811 cases; in particular a runtime checking is needed. */
6814 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6817 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6819 /* First compare rank. */
6820 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6822 gfc_error ("Source-expr at %L must be scalar or have the "
6823 "same rank as the allocate-object at %L",
6824 &e1
->where
, &e2
->where
);
6835 for (i
= 0; i
< e1
->rank
; i
++)
6837 if (tail
->u
.ar
.end
[i
])
6839 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6840 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6841 mpz_add_ui (s
, s
, 1);
6845 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6848 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6850 gfc_error ("Source-expr at %L and allocate-object at %L must "
6851 "have the same shape", &e1
->where
, &e2
->where
);
6864 /* Resolve the expression in an ALLOCATE statement, doing the additional
6865 checks to see whether the expression is OK or not. The expression must
6866 have a trailing array reference that gives the size of the array. */
6869 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6871 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6874 symbol_attribute attr
;
6875 gfc_ref
*ref
, *ref2
;
6878 gfc_symbol
*sym
= NULL
;
6883 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6884 checking of coarrays. */
6885 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6886 if (ref
->next
== NULL
)
6889 if (ref
&& ref
->type
== REF_ARRAY
)
6890 ref
->u
.ar
.in_allocate
= true;
6892 if (gfc_resolve_expr (e
) == FAILURE
)
6895 /* Make sure the expression is allocatable or a pointer. If it is
6896 pointer, the next-to-last reference must be a pointer. */
6900 sym
= e
->symtree
->n
.sym
;
6902 /* Check whether ultimate component is abstract and CLASS. */
6905 if (e
->expr_type
!= EXPR_VARIABLE
)
6908 attr
= gfc_expr_attr (e
);
6909 pointer
= attr
.pointer
;
6910 dimension
= attr
.dimension
;
6911 codimension
= attr
.codimension
;
6915 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6917 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6918 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6919 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6920 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6921 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6925 allocatable
= sym
->attr
.allocatable
;
6926 pointer
= sym
->attr
.pointer
;
6927 dimension
= sym
->attr
.dimension
;
6928 codimension
= sym
->attr
.codimension
;
6933 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6938 if (ref
->u
.ar
.codimen
> 0)
6941 for (n
= ref
->u
.ar
.dimen
;
6942 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6943 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6950 if (ref
->next
!= NULL
)
6958 gfc_error ("Coindexed allocatable object at %L",
6963 c
= ref
->u
.c
.component
;
6964 if (c
->ts
.type
== BT_CLASS
)
6966 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6967 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6968 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6969 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6970 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6974 allocatable
= c
->attr
.allocatable
;
6975 pointer
= c
->attr
.pointer
;
6976 dimension
= c
->attr
.dimension
;
6977 codimension
= c
->attr
.codimension
;
6978 is_abstract
= c
->attr
.abstract
;
6990 if (allocatable
== 0 && pointer
== 0)
6992 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6997 /* Some checks for the SOURCE tag. */
7000 /* Check F03:C631. */
7001 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7003 gfc_error ("Type of entity at %L is type incompatible with "
7004 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7008 /* Check F03:C632 and restriction following Note 6.18. */
7009 if (code
->expr3
->rank
> 0
7010 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
7013 /* Check F03:C633. */
7014 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
7016 gfc_error ("The allocate-object at %L and the source-expr at %L "
7017 "shall have the same kind type parameter",
7018 &e
->where
, &code
->expr3
->where
);
7022 /* Check F2008, C642. */
7023 if (code
->expr3
->ts
.type
== BT_DERIVED
7024 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7025 || (code
->expr3
->ts
.u
.derived
->from_intmod
7026 == INTMOD_ISO_FORTRAN_ENV
7027 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7028 == ISOFORTRAN_LOCK_TYPE
)))
7030 gfc_error ("The source-expr at %L shall neither be of type "
7031 "LOCK_TYPE nor have a LOCK_TYPE component if "
7032 "allocate-object at %L is a coarray",
7033 &code
->expr3
->where
, &e
->where
);
7038 /* Check F08:C629. */
7039 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7042 gcc_assert (e
->ts
.type
== BT_CLASS
);
7043 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7044 "type-spec or source-expr", sym
->name
, &e
->where
);
7048 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7050 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7051 code
->ext
.alloc
.ts
.u
.cl
->length
);
7052 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7054 gfc_error ("Allocating %s at %L with type-spec requires the same "
7055 "character-length parameter as in the declaration",
7056 sym
->name
, &e
->where
);
7061 /* In the variable definition context checks, gfc_expr_attr is used
7062 on the expression. This is fooled by the array specification
7063 present in e, thus we have to eliminate that one temporarily. */
7064 e2
= remove_last_array_ref (e
);
7066 if (t
== SUCCESS
&& pointer
)
7067 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
7069 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
7074 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7075 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7077 /* For class arrays, the initialization with SOURCE is done
7078 using _copy and trans_call. It is convenient to exploit that
7079 when the allocated type is different from the declared type but
7080 no SOURCE exists by setting expr3. */
7081 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7083 else if (!code
->expr3
)
7085 /* Set up default initializer if needed. */
7089 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7090 ts
= code
->ext
.alloc
.ts
;
7094 if (ts
.type
== BT_CLASS
)
7095 ts
= ts
.u
.derived
->components
->ts
;
7097 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7099 gfc_code
*init_st
= gfc_get_code ();
7100 init_st
->loc
= code
->loc
;
7101 init_st
->op
= EXEC_INIT_ASSIGN
;
7102 init_st
->expr1
= gfc_expr_to_initialize (e
);
7103 init_st
->expr2
= init_e
;
7104 init_st
->next
= code
->next
;
7105 code
->next
= init_st
;
7108 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7110 /* Default initialization via MOLD (non-polymorphic). */
7111 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7112 gfc_resolve_expr (rhs
);
7113 gfc_free_expr (code
->expr3
);
7117 if (e
->ts
.type
== BT_CLASS
)
7119 /* Make sure the vtab symbol is present when
7120 the module variables are generated. */
7121 gfc_typespec ts
= e
->ts
;
7123 ts
= code
->expr3
->ts
;
7124 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7125 ts
= code
->ext
.alloc
.ts
;
7126 gfc_find_derived_vtab (ts
.u
.derived
);
7128 e
= gfc_expr_to_initialize (e
);
7131 if (dimension
== 0 && codimension
== 0)
7134 /* Make sure the last reference node is an array specifiction. */
7136 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7137 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7139 gfc_error ("Array specification required in ALLOCATE statement "
7140 "at %L", &e
->where
);
7144 /* Make sure that the array section reference makes sense in the
7145 context of an ALLOCATE specification. */
7150 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7151 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7153 gfc_error ("Coarray specification required in ALLOCATE statement "
7154 "at %L", &e
->where
);
7158 for (i
= 0; i
< ar
->dimen
; i
++)
7160 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7163 switch (ar
->dimen_type
[i
])
7169 if (ar
->start
[i
] != NULL
7170 && ar
->end
[i
] != NULL
7171 && ar
->stride
[i
] == NULL
)
7174 /* Fall Through... */
7179 case DIMEN_THIS_IMAGE
:
7180 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7186 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7188 sym
= a
->expr
->symtree
->n
.sym
;
7190 /* TODO - check derived type components. */
7191 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7194 if ((ar
->start
[i
] != NULL
7195 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7196 || (ar
->end
[i
] != NULL
7197 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7199 gfc_error ("'%s' must not appear in the array specification at "
7200 "%L in the same ALLOCATE statement where it is "
7201 "itself allocated", sym
->name
, &ar
->where
);
7207 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7209 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7210 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7212 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7214 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7215 "statement at %L", &e
->where
);
7221 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7222 && ar
->stride
[i
] == NULL
)
7225 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7238 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7240 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7241 gfc_alloc
*a
, *p
, *q
;
7244 errmsg
= code
->expr2
;
7246 /* Check the stat variable. */
7249 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7251 if ((stat
->ts
.type
!= BT_INTEGER
7252 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7253 || stat
->ref
->type
== REF_COMPONENT
)))
7255 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7256 "variable", &stat
->where
);
7258 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7259 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7261 gfc_ref
*ref1
, *ref2
;
7264 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7265 ref1
= ref1
->next
, ref2
= ref2
->next
)
7267 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7269 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7278 gfc_error ("Stat-variable at %L shall not be %sd within "
7279 "the same %s statement", &stat
->where
, fcn
, fcn
);
7285 /* Check the errmsg variable. */
7289 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7292 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7294 if ((errmsg
->ts
.type
!= BT_CHARACTER
7296 && (errmsg
->ref
->type
== REF_ARRAY
7297 || errmsg
->ref
->type
== REF_COMPONENT
)))
7298 || errmsg
->rank
> 0 )
7299 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7300 "variable", &errmsg
->where
);
7302 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7303 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7305 gfc_ref
*ref1
, *ref2
;
7308 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7309 ref1
= ref1
->next
, ref2
= ref2
->next
)
7311 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7313 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7322 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7323 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7329 /* Check that an allocate-object appears only once in the statement.
7330 FIXME: Checking derived types is disabled. */
7331 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7334 for (q
= p
->next
; q
; q
= q
->next
)
7337 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7339 /* This is a potential collision. */
7340 gfc_ref
*pr
= pe
->ref
;
7341 gfc_ref
*qr
= qe
->ref
;
7343 /* Follow the references until
7344 a) They start to differ, in which case there is no error;
7345 you can deallocate a%b and a%c in a single statement
7346 b) Both of them stop, which is an error
7347 c) One of them stops, which is also an error. */
7350 if (pr
== NULL
&& qr
== NULL
)
7352 gfc_error ("Allocate-object at %L also appears at %L",
7353 &pe
->where
, &qe
->where
);
7356 else if (pr
!= NULL
&& qr
== NULL
)
7358 gfc_error ("Allocate-object at %L is subobject of"
7359 " object at %L", &pe
->where
, &qe
->where
);
7362 else if (pr
== NULL
&& qr
!= NULL
)
7364 gfc_error ("Allocate-object at %L is subobject of"
7365 " object at %L", &qe
->where
, &pe
->where
);
7368 /* Here, pr != NULL && qr != NULL */
7369 gcc_assert(pr
->type
== qr
->type
);
7370 if (pr
->type
== REF_ARRAY
)
7372 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7374 gcc_assert (qr
->type
== REF_ARRAY
);
7376 if (pr
->next
&& qr
->next
)
7378 gfc_array_ref
*par
= &(pr
->u
.ar
);
7379 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7380 if (gfc_dep_compare_expr (par
->start
[0],
7381 qar
->start
[0]) != 0)
7387 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7398 if (strcmp (fcn
, "ALLOCATE") == 0)
7400 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7401 resolve_allocate_expr (a
->expr
, code
);
7405 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7406 resolve_deallocate_expr (a
->expr
);
7411 /************ SELECT CASE resolution subroutines ************/
7413 /* Callback function for our mergesort variant. Determines interval
7414 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7415 op1 > op2. Assumes we're not dealing with the default case.
7416 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7417 There are nine situations to check. */
7420 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7424 if (op1
->low
== NULL
) /* op1 = (:L) */
7426 /* op2 = (:N), so overlap. */
7428 /* op2 = (M:) or (M:N), L < M */
7429 if (op2
->low
!= NULL
7430 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7433 else if (op1
->high
== NULL
) /* op1 = (K:) */
7435 /* op2 = (M:), so overlap. */
7437 /* op2 = (:N) or (M:N), K > N */
7438 if (op2
->high
!= NULL
7439 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7442 else /* op1 = (K:L) */
7444 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7445 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7447 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7448 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7450 else /* op2 = (M:N) */
7454 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7457 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7466 /* Merge-sort a double linked case list, detecting overlap in the
7467 process. LIST is the head of the double linked case list before it
7468 is sorted. Returns the head of the sorted list if we don't see any
7469 overlap, or NULL otherwise. */
7472 check_case_overlap (gfc_case
*list
)
7474 gfc_case
*p
, *q
, *e
, *tail
;
7475 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7477 /* If the passed list was empty, return immediately. */
7484 /* Loop unconditionally. The only exit from this loop is a return
7485 statement, when we've finished sorting the case list. */
7492 /* Count the number of merges we do in this pass. */
7495 /* Loop while there exists a merge to be done. */
7500 /* Count this merge. */
7503 /* Cut the list in two pieces by stepping INSIZE places
7504 forward in the list, starting from P. */
7507 for (i
= 0; i
< insize
; i
++)
7516 /* Now we have two lists. Merge them! */
7517 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7519 /* See from which the next case to merge comes from. */
7522 /* P is empty so the next case must come from Q. */
7527 else if (qsize
== 0 || q
== NULL
)
7536 cmp
= compare_cases (p
, q
);
7539 /* The whole case range for P is less than the
7547 /* The whole case range for Q is greater than
7548 the case range for P. */
7555 /* The cases overlap, or they are the same
7556 element in the list. Either way, we must
7557 issue an error and get the next case from P. */
7558 /* FIXME: Sort P and Q by line number. */
7559 gfc_error ("CASE label at %L overlaps with CASE "
7560 "label at %L", &p
->where
, &q
->where
);
7568 /* Add the next element to the merged list. */
7577 /* P has now stepped INSIZE places along, and so has Q. So
7578 they're the same. */
7583 /* If we have done only one merge or none at all, we've
7584 finished sorting the cases. */
7593 /* Otherwise repeat, merging lists twice the size. */
7599 /* Check to see if an expression is suitable for use in a CASE statement.
7600 Makes sure that all case expressions are scalar constants of the same
7601 type. Return FAILURE if anything is wrong. */
7604 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7606 if (e
== NULL
) return SUCCESS
;
7608 if (e
->ts
.type
!= case_expr
->ts
.type
)
7610 gfc_error ("Expression in CASE statement at %L must be of type %s",
7611 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7615 /* C805 (R808) For a given case-construct, each case-value shall be of
7616 the same type as case-expr. For character type, length differences
7617 are allowed, but the kind type parameters shall be the same. */
7619 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7621 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7622 &e
->where
, case_expr
->ts
.kind
);
7626 /* Convert the case value kind to that of case expression kind,
7629 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7630 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7634 gfc_error ("Expression in CASE statement at %L must be scalar",
7643 /* Given a completely parsed select statement, we:
7645 - Validate all expressions and code within the SELECT.
7646 - Make sure that the selection expression is not of the wrong type.
7647 - Make sure that no case ranges overlap.
7648 - Eliminate unreachable cases and unreachable code resulting from
7649 removing case labels.
7651 The standard does allow unreachable cases, e.g. CASE (5:3). But
7652 they are a hassle for code generation, and to prevent that, we just
7653 cut them out here. This is not necessary for overlapping cases
7654 because they are illegal and we never even try to generate code.
7656 We have the additional caveat that a SELECT construct could have
7657 been a computed GOTO in the source code. Fortunately we can fairly
7658 easily work around that here: The case_expr for a "real" SELECT CASE
7659 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7660 we have to do is make sure that the case_expr is a scalar integer
7664 resolve_select (gfc_code
*code
)
7667 gfc_expr
*case_expr
;
7668 gfc_case
*cp
, *default_case
, *tail
, *head
;
7669 int seen_unreachable
;
7675 if (code
->expr1
== NULL
)
7677 /* This was actually a computed GOTO statement. */
7678 case_expr
= code
->expr2
;
7679 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7680 gfc_error ("Selection expression in computed GOTO statement "
7681 "at %L must be a scalar integer expression",
7684 /* Further checking is not necessary because this SELECT was built
7685 by the compiler, so it should always be OK. Just move the
7686 case_expr from expr2 to expr so that we can handle computed
7687 GOTOs as normal SELECTs from here on. */
7688 code
->expr1
= code
->expr2
;
7693 case_expr
= code
->expr1
;
7695 type
= case_expr
->ts
.type
;
7696 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7698 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7699 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7701 /* Punt. Going on here just produce more garbage error messages. */
7705 /* Raise a warning if an INTEGER case value exceeds the range of
7706 the case-expr. Later, all expressions will be promoted to the
7707 largest kind of all case-labels. */
7709 if (type
== BT_INTEGER
)
7710 for (body
= code
->block
; body
; body
= body
->block
)
7711 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7714 && gfc_check_integer_range (cp
->low
->value
.integer
,
7715 case_expr
->ts
.kind
) != ARITH_OK
)
7716 gfc_warning ("Expression in CASE statement at %L is "
7717 "not in the range of %s", &cp
->low
->where
,
7718 gfc_typename (&case_expr
->ts
));
7721 && cp
->low
!= cp
->high
7722 && gfc_check_integer_range (cp
->high
->value
.integer
,
7723 case_expr
->ts
.kind
) != ARITH_OK
)
7724 gfc_warning ("Expression in CASE statement at %L is "
7725 "not in the range of %s", &cp
->high
->where
,
7726 gfc_typename (&case_expr
->ts
));
7729 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7730 of the SELECT CASE expression and its CASE values. Walk the lists
7731 of case values, and if we find a mismatch, promote case_expr to
7732 the appropriate kind. */
7734 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7736 for (body
= code
->block
; body
; body
= body
->block
)
7738 /* Walk the case label list. */
7739 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7741 /* Intercept the DEFAULT case. It does not have a kind. */
7742 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7745 /* Unreachable case ranges are discarded, so ignore. */
7746 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7747 && cp
->low
!= cp
->high
7748 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7752 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7753 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7755 if (cp
->high
!= NULL
7756 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7757 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7762 /* Assume there is no DEFAULT case. */
7763 default_case
= NULL
;
7768 for (body
= code
->block
; body
; body
= body
->block
)
7770 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7772 seen_unreachable
= 0;
7774 /* Walk the case label list, making sure that all case labels
7776 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7778 /* Count the number of cases in the whole construct. */
7781 /* Intercept the DEFAULT case. */
7782 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7784 if (default_case
!= NULL
)
7786 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7787 "by a second DEFAULT CASE at %L",
7788 &default_case
->where
, &cp
->where
);
7799 /* Deal with single value cases and case ranges. Errors are
7800 issued from the validation function. */
7801 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7802 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7808 if (type
== BT_LOGICAL
7809 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7810 || cp
->low
!= cp
->high
))
7812 gfc_error ("Logical range in CASE statement at %L is not "
7813 "allowed", &cp
->low
->where
);
7818 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7821 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7822 if (value
& seen_logical
)
7824 gfc_error ("Constant logical value in CASE statement "
7825 "is repeated at %L",
7830 seen_logical
|= value
;
7833 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7834 && cp
->low
!= cp
->high
7835 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7837 if (gfc_option
.warn_surprising
)
7838 gfc_warning ("Range specification at %L can never "
7839 "be matched", &cp
->where
);
7841 cp
->unreachable
= 1;
7842 seen_unreachable
= 1;
7846 /* If the case range can be matched, it can also overlap with
7847 other cases. To make sure it does not, we put it in a
7848 double linked list here. We sort that with a merge sort
7849 later on to detect any overlapping cases. */
7853 head
->right
= head
->left
= NULL
;
7858 tail
->right
->left
= tail
;
7865 /* It there was a failure in the previous case label, give up
7866 for this case label list. Continue with the next block. */
7870 /* See if any case labels that are unreachable have been seen.
7871 If so, we eliminate them. This is a bit of a kludge because
7872 the case lists for a single case statement (label) is a
7873 single forward linked lists. */
7874 if (seen_unreachable
)
7876 /* Advance until the first case in the list is reachable. */
7877 while (body
->ext
.block
.case_list
!= NULL
7878 && body
->ext
.block
.case_list
->unreachable
)
7880 gfc_case
*n
= body
->ext
.block
.case_list
;
7881 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7883 gfc_free_case_list (n
);
7886 /* Strip all other unreachable cases. */
7887 if (body
->ext
.block
.case_list
)
7889 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7891 if (cp
->next
->unreachable
)
7893 gfc_case
*n
= cp
->next
;
7894 cp
->next
= cp
->next
->next
;
7896 gfc_free_case_list (n
);
7903 /* See if there were overlapping cases. If the check returns NULL,
7904 there was overlap. In that case we don't do anything. If head
7905 is non-NULL, we prepend the DEFAULT case. The sorted list can
7906 then used during code generation for SELECT CASE constructs with
7907 a case expression of a CHARACTER type. */
7910 head
= check_case_overlap (head
);
7912 /* Prepend the default_case if it is there. */
7913 if (head
!= NULL
&& default_case
)
7915 default_case
->left
= NULL
;
7916 default_case
->right
= head
;
7917 head
->left
= default_case
;
7921 /* Eliminate dead blocks that may be the result if we've seen
7922 unreachable case labels for a block. */
7923 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7925 if (body
->block
->ext
.block
.case_list
== NULL
)
7927 /* Cut the unreachable block from the code chain. */
7928 gfc_code
*c
= body
->block
;
7929 body
->block
= c
->block
;
7931 /* Kill the dead block, but not the blocks below it. */
7933 gfc_free_statements (c
);
7937 /* More than two cases is legal but insane for logical selects.
7938 Issue a warning for it. */
7939 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7941 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7946 /* Check if a derived type is extensible. */
7949 gfc_type_is_extensible (gfc_symbol
*sym
)
7951 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7955 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7956 correct as well as possibly the array-spec. */
7959 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7963 gcc_assert (sym
->assoc
);
7964 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7966 /* If this is for SELECT TYPE, the target may not yet be set. In that
7967 case, return. Resolution will be called later manually again when
7969 target
= sym
->assoc
->target
;
7972 gcc_assert (!sym
->assoc
->dangling
);
7974 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7977 /* For variable targets, we get some attributes from the target. */
7978 if (target
->expr_type
== EXPR_VARIABLE
)
7982 gcc_assert (target
->symtree
);
7983 tsym
= target
->symtree
->n
.sym
;
7985 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7986 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7988 sym
->attr
.target
= tsym
->attr
.target
7989 || gfc_expr_attr (target
).pointer
;
7992 /* Get type if this was not already set. Note that it can be
7993 some other type than the target in case this is a SELECT TYPE
7994 selector! So we must not update when the type is already there. */
7995 if (sym
->ts
.type
== BT_UNKNOWN
)
7996 sym
->ts
= target
->ts
;
7997 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7999 /* See if this is a valid association-to-variable. */
8000 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8001 && !gfc_has_vector_subscript (target
));
8003 /* Finally resolve if this is an array or not. */
8004 if (sym
->attr
.dimension
&& target
->rank
== 0)
8006 gfc_error ("Associate-name '%s' at %L is used as array",
8007 sym
->name
, &sym
->declared_at
);
8008 sym
->attr
.dimension
= 0;
8012 /* We cannot deal with class selectors that need temporaries. */
8013 if (target
->ts
.type
== BT_CLASS
8014 && gfc_ref_needs_temporary_p (target
->ref
))
8016 gfc_error ("CLASS selector at %L needs a temporary which is not "
8017 "yet implemented", &target
->where
);
8021 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8022 sym
->attr
.dimension
= 1;
8023 else if (target
->ts
.type
== BT_CLASS
)
8024 gfc_fix_class_refs (target
);
8026 /* The associate-name will have a correct type by now. Make absolutely
8027 sure that it has not picked up a dimension attribute. */
8028 if (sym
->ts
.type
== BT_CLASS
)
8029 sym
->attr
.dimension
= 0;
8031 if (sym
->attr
.dimension
)
8033 sym
->as
= gfc_get_array_spec ();
8034 sym
->as
->rank
= target
->rank
;
8035 sym
->as
->type
= AS_DEFERRED
;
8037 /* Target must not be coindexed, thus the associate-variable
8039 sym
->as
->corank
= 0;
8044 /* Resolve a SELECT TYPE statement. */
8047 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8049 gfc_symbol
*selector_type
;
8050 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8051 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8054 char name
[GFC_MAX_SYMBOL_LEN
];
8058 ns
= code
->ext
.block
.ns
;
8061 /* Check for F03:C813. */
8062 if (code
->expr1
->ts
.type
!= BT_CLASS
8063 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8065 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8066 "at %L", &code
->loc
);
8070 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8075 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8076 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8077 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8080 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8082 /* Loop over TYPE IS / CLASS IS cases. */
8083 for (body
= code
->block
; body
; body
= body
->block
)
8085 c
= body
->ext
.block
.case_list
;
8087 /* Check F03:C815. */
8088 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8089 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8091 gfc_error ("Derived type '%s' at %L must be extensible",
8092 c
->ts
.u
.derived
->name
, &c
->where
);
8097 /* Check F03:C816. */
8098 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8099 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8101 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8102 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8107 /* Intercept the DEFAULT case. */
8108 if (c
->ts
.type
== BT_UNKNOWN
)
8110 /* Check F03:C818. */
8113 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8114 "by a second DEFAULT CASE at %L",
8115 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8120 default_case
= body
;
8127 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8128 target if present. If there are any EXIT statements referring to the
8129 SELECT TYPE construct, this is no problem because the gfc_code
8130 reference stays the same and EXIT is equally possible from the BLOCK
8131 it is changed to. */
8132 code
->op
= EXEC_BLOCK
;
8135 gfc_association_list
* assoc
;
8137 assoc
= gfc_get_association_list ();
8138 assoc
->st
= code
->expr1
->symtree
;
8139 assoc
->target
= gfc_copy_expr (code
->expr2
);
8140 assoc
->target
->where
= code
->expr2
->where
;
8141 /* assoc->variable will be set by resolve_assoc_var. */
8143 code
->ext
.block
.assoc
= assoc
;
8144 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8146 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8149 code
->ext
.block
.assoc
= NULL
;
8151 /* Add EXEC_SELECT to switch on type. */
8152 new_st
= gfc_get_code ();
8153 new_st
->op
= code
->op
;
8154 new_st
->expr1
= code
->expr1
;
8155 new_st
->expr2
= code
->expr2
;
8156 new_st
->block
= code
->block
;
8157 code
->expr1
= code
->expr2
= NULL
;
8162 ns
->code
->next
= new_st
;
8164 code
->op
= EXEC_SELECT
;
8165 gfc_add_vptr_component (code
->expr1
);
8166 gfc_add_hash_component (code
->expr1
);
8168 /* Loop over TYPE IS / CLASS IS cases. */
8169 for (body
= code
->block
; body
; body
= body
->block
)
8171 c
= body
->ext
.block
.case_list
;
8173 if (c
->ts
.type
== BT_DERIVED
)
8174 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8175 c
->ts
.u
.derived
->hash_value
);
8177 else if (c
->ts
.type
== BT_UNKNOWN
)
8180 /* Associate temporary to selector. This should only be done
8181 when this case is actually true, so build a new ASSOCIATE
8182 that does precisely this here (instead of using the
8185 if (c
->ts
.type
== BT_CLASS
)
8186 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8188 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8189 st
= gfc_find_symtree (ns
->sym_root
, name
);
8190 gcc_assert (st
->n
.sym
->assoc
);
8191 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8192 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8193 if (c
->ts
.type
== BT_DERIVED
)
8194 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8196 new_st
= gfc_get_code ();
8197 new_st
->op
= EXEC_BLOCK
;
8198 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8199 new_st
->ext
.block
.ns
->code
= body
->next
;
8200 body
->next
= new_st
;
8202 /* Chain in the new list only if it is marked as dangling. Otherwise
8203 there is a CASE label overlap and this is already used. Just ignore,
8204 the error is diagonsed elsewhere. */
8205 if (st
->n
.sym
->assoc
->dangling
)
8207 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8208 st
->n
.sym
->assoc
->dangling
= 0;
8211 resolve_assoc_var (st
->n
.sym
, false);
8214 /* Take out CLASS IS cases for separate treatment. */
8216 while (body
&& body
->block
)
8218 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8220 /* Add to class_is list. */
8221 if (class_is
== NULL
)
8223 class_is
= body
->block
;
8228 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8229 tail
->block
= body
->block
;
8232 /* Remove from EXEC_SELECT list. */
8233 body
->block
= body
->block
->block
;
8246 /* Add a default case to hold the CLASS IS cases. */
8247 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8248 tail
->block
= gfc_get_code ();
8250 tail
->op
= EXEC_SELECT_TYPE
;
8251 tail
->ext
.block
.case_list
= gfc_get_case ();
8252 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8254 default_case
= tail
;
8257 /* More than one CLASS IS block? */
8258 if (class_is
->block
)
8262 /* Sort CLASS IS blocks by extension level. */
8266 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8269 /* F03:C817 (check for doubles). */
8270 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8271 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8273 gfc_error ("Double CLASS IS block in SELECT TYPE "
8275 &c2
->ext
.block
.case_list
->where
);
8278 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8279 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8282 (*c1
)->block
= c2
->block
;
8292 /* Generate IF chain. */
8293 if_st
= gfc_get_code ();
8294 if_st
->op
= EXEC_IF
;
8296 for (body
= class_is
; body
; body
= body
->block
)
8298 new_st
->block
= gfc_get_code ();
8299 new_st
= new_st
->block
;
8300 new_st
->op
= EXEC_IF
;
8301 /* Set up IF condition: Call _gfortran_is_extension_of. */
8302 new_st
->expr1
= gfc_get_expr ();
8303 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8304 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8305 new_st
->expr1
->ts
.kind
= 4;
8306 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8307 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8308 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8309 /* Set up arguments. */
8310 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8311 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8312 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8313 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8314 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8315 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8316 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8317 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8318 new_st
->next
= body
->next
;
8320 if (default_case
->next
)
8322 new_st
->block
= gfc_get_code ();
8323 new_st
= new_st
->block
;
8324 new_st
->op
= EXEC_IF
;
8325 new_st
->next
= default_case
->next
;
8328 /* Replace CLASS DEFAULT code by the IF chain. */
8329 default_case
->next
= if_st
;
8332 /* Resolve the internal code. This can not be done earlier because
8333 it requires that the sym->assoc of selectors is set already. */
8334 gfc_current_ns
= ns
;
8335 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8336 gfc_current_ns
= old_ns
;
8338 resolve_select (code
);
8342 /* Resolve a transfer statement. This is making sure that:
8343 -- a derived type being transferred has only non-pointer components
8344 -- a derived type being transferred doesn't have private components, unless
8345 it's being transferred from the module where the type was defined
8346 -- we're not trying to transfer a whole assumed size array. */
8349 resolve_transfer (gfc_code
*code
)
8358 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8359 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8360 exp
= exp
->value
.op
.op1
;
8362 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8364 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8365 "MOLD=", &exp
->where
);
8369 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8370 && exp
->expr_type
!= EXPR_FUNCTION
))
8373 /* If we are reading, the variable will be changed. Note that
8374 code->ext.dt may be NULL if the TRANSFER is related to
8375 an INQUIRE statement -- but in this case, we are not reading, either. */
8376 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8377 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8381 sym
= exp
->symtree
->n
.sym
;
8384 /* Go to actual component transferred. */
8385 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8386 if (ref
->type
== REF_COMPONENT
)
8387 ts
= &ref
->u
.c
.component
->ts
;
8389 if (ts
->type
== BT_CLASS
)
8391 /* FIXME: Test for defined input/output. */
8392 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8393 "it is processed by a defined input/output procedure",
8398 if (ts
->type
== BT_DERIVED
)
8400 /* Check that transferred derived type doesn't contain POINTER
8402 if (ts
->u
.derived
->attr
.pointer_comp
)
8404 gfc_error ("Data transfer element at %L cannot have POINTER "
8405 "components unless it is processed by a defined "
8406 "input/output procedure", &code
->loc
);
8411 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8413 gfc_error ("Data transfer element at %L cannot have "
8414 "procedure pointer components", &code
->loc
);
8418 if (ts
->u
.derived
->attr
.alloc_comp
)
8420 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8421 "components unless it is processed by a defined "
8422 "input/output procedure", &code
->loc
);
8426 if (derived_inaccessible (ts
->u
.derived
))
8428 gfc_error ("Data transfer element at %L cannot have "
8429 "PRIVATE components",&code
->loc
);
8434 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8435 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8437 gfc_error ("Data transfer element at %L cannot be a full reference to "
8438 "an assumed-size array", &code
->loc
);
8444 /*********** Toplevel code resolution subroutines ***********/
8446 /* Find the set of labels that are reachable from this block. We also
8447 record the last statement in each block. */
8450 find_reachable_labels (gfc_code
*block
)
8457 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8459 /* Collect labels in this block. We don't keep those corresponding
8460 to END {IF|SELECT}, these are checked in resolve_branch by going
8461 up through the code_stack. */
8462 for (c
= block
; c
; c
= c
->next
)
8464 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8465 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8468 /* Merge with labels from parent block. */
8471 gcc_assert (cs_base
->prev
->reachable_labels
);
8472 bitmap_ior_into (cs_base
->reachable_labels
,
8473 cs_base
->prev
->reachable_labels
);
8479 resolve_lock_unlock (gfc_code
*code
)
8481 if (code
->expr1
->ts
.type
!= BT_DERIVED
8482 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8483 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8484 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8485 || code
->expr1
->rank
!= 0
8486 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8487 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8488 &code
->expr1
->where
);
8492 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8493 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8494 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8495 &code
->expr2
->where
);
8498 && gfc_check_vardef_context (code
->expr2
, false, false,
8499 _("STAT variable")) == FAILURE
)
8504 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8505 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8506 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8507 &code
->expr3
->where
);
8510 && gfc_check_vardef_context (code
->expr3
, false, false,
8511 _("ERRMSG variable")) == FAILURE
)
8514 /* Check ACQUIRED_LOCK. */
8516 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8517 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8518 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8519 "variable", &code
->expr4
->where
);
8522 && gfc_check_vardef_context (code
->expr4
, false, false,
8523 _("ACQUIRED_LOCK variable")) == FAILURE
)
8529 resolve_sync (gfc_code
*code
)
8531 /* Check imageset. The * case matches expr1 == NULL. */
8534 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8535 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8536 "INTEGER expression", &code
->expr1
->where
);
8537 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8538 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8539 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8540 &code
->expr1
->where
);
8541 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8542 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8544 gfc_constructor
*cons
;
8545 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8546 for (; cons
; cons
= gfc_constructor_next (cons
))
8547 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8548 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8549 gfc_error ("Imageset argument at %L must between 1 and "
8550 "num_images()", &cons
->expr
->where
);
8556 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8557 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8558 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8559 &code
->expr2
->where
);
8563 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8564 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8565 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8566 &code
->expr3
->where
);
8570 /* Given a branch to a label, see if the branch is conforming.
8571 The code node describes where the branch is located. */
8574 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8581 /* Step one: is this a valid branching target? */
8583 if (label
->defined
== ST_LABEL_UNKNOWN
)
8585 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8590 if (label
->defined
!= ST_LABEL_TARGET
)
8592 gfc_error ("Statement at %L is not a valid branch target statement "
8593 "for the branch statement at %L", &label
->where
, &code
->loc
);
8597 /* Step two: make sure this branch is not a branch to itself ;-) */
8599 if (code
->here
== label
)
8601 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8605 /* Step three: See if the label is in the same block as the
8606 branching statement. The hard work has been done by setting up
8607 the bitmap reachable_labels. */
8609 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8611 /* Check now whether there is a CRITICAL construct; if so, check
8612 whether the label is still visible outside of the CRITICAL block,
8613 which is invalid. */
8614 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8616 if (stack
->current
->op
== EXEC_CRITICAL
8617 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8618 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8619 "label at %L", &code
->loc
, &label
->where
);
8620 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8621 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8622 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8623 "for label at %L", &code
->loc
, &label
->where
);
8629 /* Step four: If we haven't found the label in the bitmap, it may
8630 still be the label of the END of the enclosing block, in which
8631 case we find it by going up the code_stack. */
8633 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8635 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8637 if (stack
->current
->op
== EXEC_CRITICAL
)
8639 /* Note: A label at END CRITICAL does not leave the CRITICAL
8640 construct as END CRITICAL is still part of it. */
8641 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8642 " at %L", &code
->loc
, &label
->where
);
8645 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8647 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8648 "label at %L", &code
->loc
, &label
->where
);
8655 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8659 /* The label is not in an enclosing block, so illegal. This was
8660 allowed in Fortran 66, so we allow it as extension. No
8661 further checks are necessary in this case. */
8662 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8663 "as the GOTO statement at %L", &label
->where
,
8669 /* Check whether EXPR1 has the same shape as EXPR2. */
8672 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8674 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8675 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8676 gfc_try result
= FAILURE
;
8679 /* Compare the rank. */
8680 if (expr1
->rank
!= expr2
->rank
)
8683 /* Compare the size of each dimension. */
8684 for (i
=0; i
<expr1
->rank
; i
++)
8686 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8689 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8692 if (mpz_cmp (shape
[i
], shape2
[i
]))
8696 /* When either of the two expression is an assumed size array, we
8697 ignore the comparison of dimension sizes. */
8702 gfc_clear_shape (shape
, i
);
8703 gfc_clear_shape (shape2
, i
);
8708 /* Check whether a WHERE assignment target or a WHERE mask expression
8709 has the same shape as the outmost WHERE mask expression. */
8712 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8718 cblock
= code
->block
;
8720 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8721 In case of nested WHERE, only the outmost one is stored. */
8722 if (mask
== NULL
) /* outmost WHERE */
8724 else /* inner WHERE */
8731 /* Check if the mask-expr has a consistent shape with the
8732 outmost WHERE mask-expr. */
8733 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8734 gfc_error ("WHERE mask at %L has inconsistent shape",
8735 &cblock
->expr1
->where
);
8738 /* the assignment statement of a WHERE statement, or the first
8739 statement in where-body-construct of a WHERE construct */
8740 cnext
= cblock
->next
;
8745 /* WHERE assignment statement */
8748 /* Check shape consistent for WHERE assignment target. */
8749 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8750 gfc_error ("WHERE assignment target at %L has "
8751 "inconsistent shape", &cnext
->expr1
->where
);
8755 case EXEC_ASSIGN_CALL
:
8756 resolve_call (cnext
);
8757 if (!cnext
->resolved_sym
->attr
.elemental
)
8758 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8759 &cnext
->ext
.actual
->expr
->where
);
8762 /* WHERE or WHERE construct is part of a where-body-construct */
8764 resolve_where (cnext
, e
);
8768 gfc_error ("Unsupported statement inside WHERE at %L",
8771 /* the next statement within the same where-body-construct */
8772 cnext
= cnext
->next
;
8774 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8775 cblock
= cblock
->block
;
8780 /* Resolve assignment in FORALL construct.
8781 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8782 FORALL index variables. */
8785 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8789 for (n
= 0; n
< nvar
; n
++)
8791 gfc_symbol
*forall_index
;
8793 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8795 /* Check whether the assignment target is one of the FORALL index
8797 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8798 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8799 gfc_error ("Assignment to a FORALL index variable at %L",
8800 &code
->expr1
->where
);
8803 /* If one of the FORALL index variables doesn't appear in the
8804 assignment variable, then there could be a many-to-one
8805 assignment. Emit a warning rather than an error because the
8806 mask could be resolving this problem. */
8807 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8808 gfc_warning ("The FORALL with index '%s' is not used on the "
8809 "left side of the assignment at %L and so might "
8810 "cause multiple assignment to this object",
8811 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8817 /* Resolve WHERE statement in FORALL construct. */
8820 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8821 gfc_expr
**var_expr
)
8826 cblock
= code
->block
;
8829 /* the assignment statement of a WHERE statement, or the first
8830 statement in where-body-construct of a WHERE construct */
8831 cnext
= cblock
->next
;
8836 /* WHERE assignment statement */
8838 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8841 /* WHERE operator assignment statement */
8842 case EXEC_ASSIGN_CALL
:
8843 resolve_call (cnext
);
8844 if (!cnext
->resolved_sym
->attr
.elemental
)
8845 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8846 &cnext
->ext
.actual
->expr
->where
);
8849 /* WHERE or WHERE construct is part of a where-body-construct */
8851 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8855 gfc_error ("Unsupported statement inside WHERE at %L",
8858 /* the next statement within the same where-body-construct */
8859 cnext
= cnext
->next
;
8861 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8862 cblock
= cblock
->block
;
8867 /* Traverse the FORALL body to check whether the following errors exist:
8868 1. For assignment, check if a many-to-one assignment happens.
8869 2. For WHERE statement, check the WHERE body to see if there is any
8870 many-to-one assignment. */
8873 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8877 c
= code
->block
->next
;
8883 case EXEC_POINTER_ASSIGN
:
8884 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8887 case EXEC_ASSIGN_CALL
:
8891 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8892 there is no need to handle it here. */
8896 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8901 /* The next statement in the FORALL body. */
8907 /* Counts the number of iterators needed inside a forall construct, including
8908 nested forall constructs. This is used to allocate the needed memory
8909 in gfc_resolve_forall. */
8912 gfc_count_forall_iterators (gfc_code
*code
)
8914 int max_iters
, sub_iters
, current_iters
;
8915 gfc_forall_iterator
*fa
;
8917 gcc_assert(code
->op
== EXEC_FORALL
);
8921 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8924 code
= code
->block
->next
;
8928 if (code
->op
== EXEC_FORALL
)
8930 sub_iters
= gfc_count_forall_iterators (code
);
8931 if (sub_iters
> max_iters
)
8932 max_iters
= sub_iters
;
8937 return current_iters
+ max_iters
;
8941 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8942 gfc_resolve_forall_body to resolve the FORALL body. */
8945 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8947 static gfc_expr
**var_expr
;
8948 static int total_var
= 0;
8949 static int nvar
= 0;
8951 gfc_forall_iterator
*fa
;
8956 /* Start to resolve a FORALL construct */
8957 if (forall_save
== 0)
8959 /* Count the total number of FORALL index in the nested FORALL
8960 construct in order to allocate the VAR_EXPR with proper size. */
8961 total_var
= gfc_count_forall_iterators (code
);
8963 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8964 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8967 /* The information about FORALL iterator, including FORALL index start, end
8968 and stride. The FORALL index can not appear in start, end or stride. */
8969 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8971 /* Check if any outer FORALL index name is the same as the current
8973 for (i
= 0; i
< nvar
; i
++)
8975 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8977 gfc_error ("An outer FORALL construct already has an index "
8978 "with this name %L", &fa
->var
->where
);
8982 /* Record the current FORALL index. */
8983 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8987 /* No memory leak. */
8988 gcc_assert (nvar
<= total_var
);
8991 /* Resolve the FORALL body. */
8992 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8994 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8995 gfc_resolve_blocks (code
->block
, ns
);
8999 /* Free only the VAR_EXPRs allocated in this frame. */
9000 for (i
= nvar
; i
< tmp
; i
++)
9001 gfc_free_expr (var_expr
[i
]);
9005 /* We are in the outermost FORALL construct. */
9006 gcc_assert (forall_save
== 0);
9008 /* VAR_EXPR is not needed any more. */
9015 /* Resolve a BLOCK construct statement. */
9018 resolve_block_construct (gfc_code
* code
)
9020 /* Resolve the BLOCK's namespace. */
9021 gfc_resolve (code
->ext
.block
.ns
);
9023 /* For an ASSOCIATE block, the associations (and their targets) are already
9024 resolved during resolve_symbol. */
9028 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9031 static void resolve_code (gfc_code
*, gfc_namespace
*);
9034 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9038 for (; b
; b
= b
->block
)
9040 t
= gfc_resolve_expr (b
->expr1
);
9041 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9047 if (t
== SUCCESS
&& b
->expr1
!= NULL
9048 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9049 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9056 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9057 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9062 resolve_branch (b
->label1
, b
);
9066 resolve_block_construct (b
);
9070 case EXEC_SELECT_TYPE
:
9074 case EXEC_DO_CONCURRENT
:
9082 case EXEC_OMP_ATOMIC
:
9083 case EXEC_OMP_CRITICAL
:
9085 case EXEC_OMP_MASTER
:
9086 case EXEC_OMP_ORDERED
:
9087 case EXEC_OMP_PARALLEL
:
9088 case EXEC_OMP_PARALLEL_DO
:
9089 case EXEC_OMP_PARALLEL_SECTIONS
:
9090 case EXEC_OMP_PARALLEL_WORKSHARE
:
9091 case EXEC_OMP_SECTIONS
:
9092 case EXEC_OMP_SINGLE
:
9094 case EXEC_OMP_TASKWAIT
:
9095 case EXEC_OMP_TASKYIELD
:
9096 case EXEC_OMP_WORKSHARE
:
9100 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9103 resolve_code (b
->next
, ns
);
9108 /* Does everything to resolve an ordinary assignment. Returns true
9109 if this is an interface assignment. */
9111 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9121 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9125 if (code
->op
== EXEC_ASSIGN_CALL
)
9127 lhs
= code
->ext
.actual
->expr
;
9128 rhsptr
= &code
->ext
.actual
->next
->expr
;
9132 gfc_actual_arglist
* args
;
9133 gfc_typebound_proc
* tbp
;
9135 gcc_assert (code
->op
== EXEC_COMPCALL
);
9137 args
= code
->expr1
->value
.compcall
.actual
;
9139 rhsptr
= &args
->next
->expr
;
9141 tbp
= code
->expr1
->value
.compcall
.tbp
;
9142 gcc_assert (!tbp
->is_generic
);
9145 /* Make a temporary rhs when there is a default initializer
9146 and rhs is the same symbol as the lhs. */
9147 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9148 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9149 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9150 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9151 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9160 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
9161 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9162 &code
->loc
) == FAILURE
)
9165 /* Handle the case of a BOZ literal on the RHS. */
9166 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9169 if (gfc_option
.warn_surprising
)
9170 gfc_warning ("BOZ literal at %L is bitwise transferred "
9171 "non-integer symbol '%s'", &code
->loc
,
9172 lhs
->symtree
->n
.sym
->name
);
9174 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9176 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9178 if (rc
== ARITH_UNDERFLOW
)
9179 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9180 ". This check can be disabled with the option "
9181 "-fno-range-check", &rhs
->where
);
9182 else if (rc
== ARITH_OVERFLOW
)
9183 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9184 ". This check can be disabled with the option "
9185 "-fno-range-check", &rhs
->where
);
9186 else if (rc
== ARITH_NAN
)
9187 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9188 ". This check can be disabled with the option "
9189 "-fno-range-check", &rhs
->where
);
9194 if (lhs
->ts
.type
== BT_CHARACTER
9195 && gfc_option
.warn_character_truncation
)
9197 if (lhs
->ts
.u
.cl
!= NULL
9198 && lhs
->ts
.u
.cl
->length
!= NULL
9199 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9200 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9202 if (rhs
->expr_type
== EXPR_CONSTANT
)
9203 rlen
= rhs
->value
.character
.length
;
9205 else if (rhs
->ts
.u
.cl
!= NULL
9206 && rhs
->ts
.u
.cl
->length
!= NULL
9207 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9208 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9210 if (rlen
&& llen
&& rlen
> llen
)
9211 gfc_warning_now ("CHARACTER expression will be truncated "
9212 "in assignment (%d/%d) at %L",
9213 llen
, rlen
, &code
->loc
);
9216 /* Ensure that a vector index expression for the lvalue is evaluated
9217 to a temporary if the lvalue symbol is referenced in it. */
9220 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9221 if (ref
->type
== REF_ARRAY
)
9223 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9224 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9225 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9226 ref
->u
.ar
.start
[n
]))
9228 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9232 if (gfc_pure (NULL
))
9234 if (lhs
->ts
.type
== BT_DERIVED
9235 && lhs
->expr_type
== EXPR_VARIABLE
9236 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9237 && rhs
->expr_type
== EXPR_VARIABLE
9238 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9239 || gfc_is_coindexed (rhs
)))
9242 if (gfc_is_coindexed (rhs
))
9243 gfc_error ("Coindexed expression at %L is assigned to "
9244 "a derived type variable with a POINTER "
9245 "component in a PURE procedure",
9248 gfc_error ("The impure variable at %L is assigned to "
9249 "a derived type variable with a POINTER "
9250 "component in a PURE procedure (12.6)",
9255 /* Fortran 2008, C1283. */
9256 if (gfc_is_coindexed (lhs
))
9258 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9259 "procedure", &rhs
->where
);
9264 if (gfc_implicit_pure (NULL
))
9266 if (lhs
->expr_type
== EXPR_VARIABLE
9267 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9268 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9269 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9271 if (lhs
->ts
.type
== BT_DERIVED
9272 && lhs
->expr_type
== EXPR_VARIABLE
9273 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9274 && rhs
->expr_type
== EXPR_VARIABLE
9275 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9276 || gfc_is_coindexed (rhs
)))
9277 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9279 /* Fortran 2008, C1283. */
9280 if (gfc_is_coindexed (lhs
))
9281 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9285 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9286 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9287 if (lhs
->ts
.type
== BT_CLASS
)
9289 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9290 "%L - check that there is a matching specific subroutine "
9291 "for '=' operator", &lhs
->where
);
9295 /* F2008, Section 7.2.1.2. */
9296 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9298 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9299 "component in assignment at %L", &lhs
->where
);
9303 gfc_check_assign (lhs
, rhs
, 1);
9308 /* Given a block of code, recursively resolve everything pointed to by this
9312 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9314 int omp_workshare_save
;
9315 int forall_save
, do_concurrent_save
;
9319 frame
.prev
= cs_base
;
9323 find_reachable_labels (code
);
9325 for (; code
; code
= code
->next
)
9327 frame
.current
= code
;
9328 forall_save
= forall_flag
;
9329 do_concurrent_save
= do_concurrent_flag
;
9331 if (code
->op
== EXEC_FORALL
)
9334 gfc_resolve_forall (code
, ns
, forall_save
);
9337 else if (code
->block
)
9339 omp_workshare_save
= -1;
9342 case EXEC_OMP_PARALLEL_WORKSHARE
:
9343 omp_workshare_save
= omp_workshare_flag
;
9344 omp_workshare_flag
= 1;
9345 gfc_resolve_omp_parallel_blocks (code
, ns
);
9347 case EXEC_OMP_PARALLEL
:
9348 case EXEC_OMP_PARALLEL_DO
:
9349 case EXEC_OMP_PARALLEL_SECTIONS
:
9351 omp_workshare_save
= omp_workshare_flag
;
9352 omp_workshare_flag
= 0;
9353 gfc_resolve_omp_parallel_blocks (code
, ns
);
9356 gfc_resolve_omp_do_blocks (code
, ns
);
9358 case EXEC_SELECT_TYPE
:
9359 /* Blocks are handled in resolve_select_type because we have
9360 to transform the SELECT TYPE into ASSOCIATE first. */
9362 case EXEC_DO_CONCURRENT
:
9363 do_concurrent_flag
= 1;
9364 gfc_resolve_blocks (code
->block
, ns
);
9365 do_concurrent_flag
= 2;
9367 case EXEC_OMP_WORKSHARE
:
9368 omp_workshare_save
= omp_workshare_flag
;
9369 omp_workshare_flag
= 1;
9372 gfc_resolve_blocks (code
->block
, ns
);
9376 if (omp_workshare_save
!= -1)
9377 omp_workshare_flag
= omp_workshare_save
;
9381 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9382 t
= gfc_resolve_expr (code
->expr1
);
9383 forall_flag
= forall_save
;
9384 do_concurrent_flag
= do_concurrent_save
;
9386 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9389 if (code
->op
== EXEC_ALLOCATE
9390 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9396 case EXEC_END_BLOCK
:
9397 case EXEC_END_NESTED_BLOCK
:
9401 case EXEC_ERROR_STOP
:
9405 case EXEC_ASSIGN_CALL
:
9410 case EXEC_SYNC_IMAGES
:
9411 case EXEC_SYNC_MEMORY
:
9412 resolve_sync (code
);
9417 resolve_lock_unlock (code
);
9421 /* Keep track of which entry we are up to. */
9422 current_entry_id
= code
->ext
.entry
->id
;
9426 resolve_where (code
, NULL
);
9430 if (code
->expr1
!= NULL
)
9432 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9433 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9434 "INTEGER variable", &code
->expr1
->where
);
9435 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9436 gfc_error ("Variable '%s' has not been assigned a target "
9437 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9438 &code
->expr1
->where
);
9441 resolve_branch (code
->label1
, code
);
9445 if (code
->expr1
!= NULL
9446 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9447 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9448 "INTEGER return specifier", &code
->expr1
->where
);
9451 case EXEC_INIT_ASSIGN
:
9452 case EXEC_END_PROCEDURE
:
9459 if (gfc_check_vardef_context (code
->expr1
, false, false,
9460 _("assignment")) == FAILURE
)
9463 if (resolve_ordinary_assign (code
, ns
))
9465 if (code
->op
== EXEC_COMPCALL
)
9472 case EXEC_LABEL_ASSIGN
:
9473 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9474 gfc_error ("Label %d referenced at %L is never defined",
9475 code
->label1
->value
, &code
->label1
->where
);
9477 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9478 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9479 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9480 != gfc_default_integer_kind
9481 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9482 gfc_error ("ASSIGN statement at %L requires a scalar "
9483 "default INTEGER variable", &code
->expr1
->where
);
9486 case EXEC_POINTER_ASSIGN
:
9493 /* This is both a variable definition and pointer assignment
9494 context, so check both of them. For rank remapping, a final
9495 array ref may be present on the LHS and fool gfc_expr_attr
9496 used in gfc_check_vardef_context. Remove it. */
9497 e
= remove_last_array_ref (code
->expr1
);
9498 t
= gfc_check_vardef_context (e
, true, false,
9499 _("pointer assignment"));
9501 t
= gfc_check_vardef_context (e
, false, false,
9502 _("pointer assignment"));
9507 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9511 case EXEC_ARITHMETIC_IF
:
9513 && code
->expr1
->ts
.type
!= BT_INTEGER
9514 && code
->expr1
->ts
.type
!= BT_REAL
)
9515 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9516 "expression", &code
->expr1
->where
);
9518 resolve_branch (code
->label1
, code
);
9519 resolve_branch (code
->label2
, code
);
9520 resolve_branch (code
->label3
, code
);
9524 if (t
== SUCCESS
&& code
->expr1
!= NULL
9525 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9526 || code
->expr1
->rank
!= 0))
9527 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9528 &code
->expr1
->where
);
9533 resolve_call (code
);
9538 resolve_typebound_subroutine (code
);
9542 resolve_ppc_call (code
);
9546 /* Select is complicated. Also, a SELECT construct could be
9547 a transformed computed GOTO. */
9548 resolve_select (code
);
9551 case EXEC_SELECT_TYPE
:
9552 resolve_select_type (code
, ns
);
9556 resolve_block_construct (code
);
9560 if (code
->ext
.iterator
!= NULL
)
9562 gfc_iterator
*iter
= code
->ext
.iterator
;
9563 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9564 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9569 if (code
->expr1
== NULL
)
9570 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9572 && (code
->expr1
->rank
!= 0
9573 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9574 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9575 "a scalar LOGICAL expression", &code
->expr1
->where
);
9580 resolve_allocate_deallocate (code
, "ALLOCATE");
9584 case EXEC_DEALLOCATE
:
9586 resolve_allocate_deallocate (code
, "DEALLOCATE");
9591 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9594 resolve_branch (code
->ext
.open
->err
, code
);
9598 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9601 resolve_branch (code
->ext
.close
->err
, code
);
9604 case EXEC_BACKSPACE
:
9608 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9611 resolve_branch (code
->ext
.filepos
->err
, code
);
9615 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9618 resolve_branch (code
->ext
.inquire
->err
, code
);
9622 gcc_assert (code
->ext
.inquire
!= NULL
);
9623 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9626 resolve_branch (code
->ext
.inquire
->err
, code
);
9630 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9633 resolve_branch (code
->ext
.wait
->err
, code
);
9634 resolve_branch (code
->ext
.wait
->end
, code
);
9635 resolve_branch (code
->ext
.wait
->eor
, code
);
9640 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9643 resolve_branch (code
->ext
.dt
->err
, code
);
9644 resolve_branch (code
->ext
.dt
->end
, code
);
9645 resolve_branch (code
->ext
.dt
->eor
, code
);
9649 resolve_transfer (code
);
9652 case EXEC_DO_CONCURRENT
:
9654 resolve_forall_iterators (code
->ext
.forall_iterator
);
9656 if (code
->expr1
!= NULL
9657 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9658 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9659 "expression", &code
->expr1
->where
);
9662 case EXEC_OMP_ATOMIC
:
9663 case EXEC_OMP_BARRIER
:
9664 case EXEC_OMP_CRITICAL
:
9665 case EXEC_OMP_FLUSH
:
9667 case EXEC_OMP_MASTER
:
9668 case EXEC_OMP_ORDERED
:
9669 case EXEC_OMP_SECTIONS
:
9670 case EXEC_OMP_SINGLE
:
9671 case EXEC_OMP_TASKWAIT
:
9672 case EXEC_OMP_TASKYIELD
:
9673 case EXEC_OMP_WORKSHARE
:
9674 gfc_resolve_omp_directive (code
, ns
);
9677 case EXEC_OMP_PARALLEL
:
9678 case EXEC_OMP_PARALLEL_DO
:
9679 case EXEC_OMP_PARALLEL_SECTIONS
:
9680 case EXEC_OMP_PARALLEL_WORKSHARE
:
9682 omp_workshare_save
= omp_workshare_flag
;
9683 omp_workshare_flag
= 0;
9684 gfc_resolve_omp_directive (code
, ns
);
9685 omp_workshare_flag
= omp_workshare_save
;
9689 gfc_internal_error ("resolve_code(): Bad statement code");
9693 cs_base
= frame
.prev
;
9697 /* Resolve initial values and make sure they are compatible with
9701 resolve_values (gfc_symbol
*sym
)
9705 if (sym
->value
== NULL
)
9708 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9709 t
= resolve_structure_cons (sym
->value
, 1);
9711 t
= gfc_resolve_expr (sym
->value
);
9716 gfc_check_assign_symbol (sym
, sym
->value
);
9720 /* Verify the binding labels for common blocks that are BIND(C). The label
9721 for a BIND(C) common block must be identical in all scoping units in which
9722 the common block is declared. Further, the binding label can not collide
9723 with any other global entity in the program. */
9726 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9728 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9730 gfc_gsymbol
*binding_label_gsym
;
9731 gfc_gsymbol
*comm_name_gsym
;
9732 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
9733 ? comm_block_tree
->n
.common
->binding_label
: "";
9735 /* See if a global symbol exists by the common block's name. It may
9736 be NULL if the common block is use-associated. */
9737 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9738 comm_block_tree
->n
.common
->name
);
9739 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9740 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9741 "with the global entity '%s' at %L",
9743 comm_block_tree
->n
.common
->name
,
9744 &(comm_block_tree
->n
.common
->where
),
9745 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9746 else if (comm_name_gsym
!= NULL
9747 && strcmp (comm_name_gsym
->name
,
9748 comm_block_tree
->n
.common
->name
) == 0)
9750 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9752 if (comm_name_gsym
->binding_label
== NULL
)
9753 /* No binding label for common block stored yet; save this one. */
9754 comm_name_gsym
->binding_label
= bind_label
;
9755 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
9757 /* Common block names match but binding labels do not. */
9758 gfc_error ("Binding label '%s' for common block '%s' at %L "
9759 "does not match the binding label '%s' for common "
9762 comm_block_tree
->n
.common
->name
,
9763 &(comm_block_tree
->n
.common
->where
),
9764 comm_name_gsym
->binding_label
,
9765 comm_name_gsym
->name
,
9766 &(comm_name_gsym
->where
));
9771 /* There is no binding label (NAME="") so we have nothing further to
9772 check and nothing to add as a global symbol for the label. */
9773 if (!comm_block_tree
->n
.common
->binding_label
)
9776 binding_label_gsym
=
9777 gfc_find_gsymbol (gfc_gsym_root
,
9778 comm_block_tree
->n
.common
->binding_label
);
9779 if (binding_label_gsym
== NULL
)
9781 /* Need to make a global symbol for the binding label to prevent
9782 it from colliding with another. */
9783 binding_label_gsym
=
9784 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9785 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9786 binding_label_gsym
->type
= GSYM_COMMON
;
9790 /* If comm_name_gsym is NULL, the name common block is use
9791 associated and the name could be colliding. */
9792 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9793 gfc_error ("Binding label '%s' for common block '%s' at %L "
9794 "collides with the global entity '%s' at %L",
9795 comm_block_tree
->n
.common
->binding_label
,
9796 comm_block_tree
->n
.common
->name
,
9797 &(comm_block_tree
->n
.common
->where
),
9798 binding_label_gsym
->name
,
9799 &(binding_label_gsym
->where
));
9800 else if (comm_name_gsym
!= NULL
9801 && (strcmp (binding_label_gsym
->name
,
9802 comm_name_gsym
->binding_label
) != 0)
9803 && (strcmp (binding_label_gsym
->sym_name
,
9804 comm_name_gsym
->name
) != 0))
9805 gfc_error ("Binding label '%s' for common block '%s' at %L "
9806 "collides with global entity '%s' at %L",
9807 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9808 &(comm_block_tree
->n
.common
->where
),
9809 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9817 /* Verify any BIND(C) derived types in the namespace so we can report errors
9818 for them once, rather than for each variable declared of that type. */
9821 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9823 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9824 && derived_sym
->attr
.is_bind_c
== 1)
9825 verify_bind_c_derived_type (derived_sym
);
9831 /* Verify that any binding labels used in a given namespace do not collide
9832 with the names or binding labels of any global symbols. */
9835 gfc_verify_binding_labels (gfc_symbol
*sym
)
9839 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9840 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
9842 gfc_gsymbol
*bind_c_sym
;
9844 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9845 if (bind_c_sym
!= NULL
9846 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9848 if (sym
->attr
.if_source
== IFSRC_DECL
9849 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9850 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9851 && ((sym
->attr
.contained
== 1
9852 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9853 || (sym
->attr
.use_assoc
== 1
9854 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9856 /* Make sure global procedures don't collide with anything. */
9857 gfc_error ("Binding label '%s' at %L collides with the global "
9858 "entity '%s' at %L", sym
->binding_label
,
9859 &(sym
->declared_at
), bind_c_sym
->name
,
9860 &(bind_c_sym
->where
));
9863 else if (sym
->attr
.contained
== 0
9864 && (sym
->attr
.if_source
== IFSRC_IFBODY
9865 && sym
->attr
.flavor
== FL_PROCEDURE
)
9866 && (bind_c_sym
->sym_name
!= NULL
9867 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9869 /* Make sure procedures in interface bodies don't collide. */
9870 gfc_error ("Binding label '%s' in interface body at %L collides "
9871 "with the global entity '%s' at %L",
9873 &(sym
->declared_at
), bind_c_sym
->name
,
9874 &(bind_c_sym
->where
));
9877 else if (sym
->attr
.contained
== 0
9878 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9879 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9880 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9881 || sym
->attr
.use_assoc
== 0)
9883 gfc_error ("Binding label '%s' at %L collides with global "
9884 "entity '%s' at %L", sym
->binding_label
,
9885 &(sym
->declared_at
), bind_c_sym
->name
,
9886 &(bind_c_sym
->where
));
9891 /* Clear the binding label to prevent checking multiple times. */
9892 sym
->binding_label
= NULL
;
9894 else if (bind_c_sym
== NULL
)
9896 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9897 bind_c_sym
->where
= sym
->declared_at
;
9898 bind_c_sym
->sym_name
= sym
->name
;
9900 if (sym
->attr
.use_assoc
== 1)
9901 bind_c_sym
->mod_name
= sym
->module
;
9903 if (sym
->ns
->proc_name
!= NULL
)
9904 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9906 if (sym
->attr
.contained
== 0)
9908 if (sym
->attr
.subroutine
)
9909 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9910 else if (sym
->attr
.function
)
9911 bind_c_sym
->type
= GSYM_FUNCTION
;
9919 /* Resolve an index expression. */
9922 resolve_index_expr (gfc_expr
*e
)
9924 if (gfc_resolve_expr (e
) == FAILURE
)
9927 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9930 if (gfc_specification_expr (e
) == FAILURE
)
9937 /* Resolve a charlen structure. */
9940 resolve_charlen (gfc_charlen
*cl
)
9949 specification_expr
= 1;
9951 if (resolve_index_expr (cl
->length
) == FAILURE
)
9953 specification_expr
= 0;
9957 /* "If the character length parameter value evaluates to a negative
9958 value, the length of character entities declared is zero." */
9959 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9961 if (gfc_option
.warn_surprising
)
9962 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9963 " the length has been set to zero",
9964 &cl
->length
->where
, i
);
9965 gfc_replace_expr (cl
->length
,
9966 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9969 /* Check that the character length is not too large. */
9970 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9971 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9972 && cl
->length
->ts
.type
== BT_INTEGER
9973 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9975 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9983 /* Test for non-constant shape arrays. */
9986 is_non_constant_shape_array (gfc_symbol
*sym
)
9992 not_constant
= false;
9993 if (sym
->as
!= NULL
)
9995 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9996 has not been simplified; parameter array references. Do the
9997 simplification now. */
9998 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10000 e
= sym
->as
->lower
[i
];
10001 if (e
&& (resolve_index_expr (e
) == FAILURE
10002 || !gfc_is_constant_expr (e
)))
10003 not_constant
= true;
10004 e
= sym
->as
->upper
[i
];
10005 if (e
&& (resolve_index_expr (e
) == FAILURE
10006 || !gfc_is_constant_expr (e
)))
10007 not_constant
= true;
10010 return not_constant
;
10013 /* Given a symbol and an initialization expression, add code to initialize
10014 the symbol to the function entry. */
10016 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10020 gfc_namespace
*ns
= sym
->ns
;
10022 /* Search for the function namespace if this is a contained
10023 function without an explicit result. */
10024 if (sym
->attr
.function
&& sym
== sym
->result
10025 && sym
->name
!= sym
->ns
->proc_name
->name
)
10027 ns
= ns
->contained
;
10028 for (;ns
; ns
= ns
->sibling
)
10029 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10035 gfc_free_expr (init
);
10039 /* Build an l-value expression for the result. */
10040 lval
= gfc_lval_expr_from_sym (sym
);
10042 /* Add the code at scope entry. */
10043 init_st
= gfc_get_code ();
10044 init_st
->next
= ns
->code
;
10045 ns
->code
= init_st
;
10047 /* Assign the default initializer to the l-value. */
10048 init_st
->loc
= sym
->declared_at
;
10049 init_st
->op
= EXEC_INIT_ASSIGN
;
10050 init_st
->expr1
= lval
;
10051 init_st
->expr2
= init
;
10054 /* Assign the default initializer to a derived type variable or result. */
10057 apply_default_init (gfc_symbol
*sym
)
10059 gfc_expr
*init
= NULL
;
10061 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10064 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10065 init
= gfc_default_initializer (&sym
->ts
);
10067 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10070 build_init_assign (sym
, init
);
10071 sym
->attr
.referenced
= 1;
10074 /* Build an initializer for a local integer, real, complex, logical, or
10075 character variable, based on the command line flags finit-local-zero,
10076 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10077 null if the symbol should not have a default initialization. */
10079 build_default_init_expr (gfc_symbol
*sym
)
10082 gfc_expr
*init_expr
;
10085 /* These symbols should never have a default initialization. */
10086 if (sym
->attr
.allocatable
10087 || sym
->attr
.external
10089 || sym
->attr
.pointer
10090 || sym
->attr
.in_equivalence
10091 || sym
->attr
.in_common
10094 || sym
->attr
.cray_pointee
10095 || sym
->attr
.cray_pointer
)
10098 /* Now we'll try to build an initializer expression. */
10099 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10100 &sym
->declared_at
);
10102 /* We will only initialize integers, reals, complex, logicals, and
10103 characters, and only if the corresponding command-line flags
10104 were set. Otherwise, we free init_expr and return null. */
10105 switch (sym
->ts
.type
)
10108 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10109 mpz_set_si (init_expr
->value
.integer
,
10110 gfc_option
.flag_init_integer_value
);
10113 gfc_free_expr (init_expr
);
10119 switch (gfc_option
.flag_init_real
)
10121 case GFC_INIT_REAL_SNAN
:
10122 init_expr
->is_snan
= 1;
10123 /* Fall through. */
10124 case GFC_INIT_REAL_NAN
:
10125 mpfr_set_nan (init_expr
->value
.real
);
10128 case GFC_INIT_REAL_INF
:
10129 mpfr_set_inf (init_expr
->value
.real
, 1);
10132 case GFC_INIT_REAL_NEG_INF
:
10133 mpfr_set_inf (init_expr
->value
.real
, -1);
10136 case GFC_INIT_REAL_ZERO
:
10137 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10141 gfc_free_expr (init_expr
);
10148 switch (gfc_option
.flag_init_real
)
10150 case GFC_INIT_REAL_SNAN
:
10151 init_expr
->is_snan
= 1;
10152 /* Fall through. */
10153 case GFC_INIT_REAL_NAN
:
10154 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10155 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10158 case GFC_INIT_REAL_INF
:
10159 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10160 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10163 case GFC_INIT_REAL_NEG_INF
:
10164 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10165 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10168 case GFC_INIT_REAL_ZERO
:
10169 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10173 gfc_free_expr (init_expr
);
10180 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10181 init_expr
->value
.logical
= 0;
10182 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10183 init_expr
->value
.logical
= 1;
10186 gfc_free_expr (init_expr
);
10192 /* For characters, the length must be constant in order to
10193 create a default initializer. */
10194 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10195 && sym
->ts
.u
.cl
->length
10196 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10198 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10199 init_expr
->value
.character
.length
= char_len
;
10200 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10201 for (i
= 0; i
< char_len
; i
++)
10202 init_expr
->value
.character
.string
[i
]
10203 = (unsigned char) gfc_option
.flag_init_character_value
;
10207 gfc_free_expr (init_expr
);
10210 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10211 && sym
->ts
.u
.cl
->length
)
10213 gfc_actual_arglist
*arg
;
10214 init_expr
= gfc_get_expr ();
10215 init_expr
->where
= sym
->declared_at
;
10216 init_expr
->ts
= sym
->ts
;
10217 init_expr
->expr_type
= EXPR_FUNCTION
;
10218 init_expr
->value
.function
.isym
=
10219 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10220 init_expr
->value
.function
.name
= "repeat";
10221 arg
= gfc_get_actual_arglist ();
10222 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10224 arg
->expr
->value
.character
.string
[0]
10225 = gfc_option
.flag_init_character_value
;
10226 arg
->next
= gfc_get_actual_arglist ();
10227 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10228 init_expr
->value
.function
.actual
= arg
;
10233 gfc_free_expr (init_expr
);
10239 /* Add an initialization expression to a local variable. */
10241 apply_default_init_local (gfc_symbol
*sym
)
10243 gfc_expr
*init
= NULL
;
10245 /* The symbol should be a variable or a function return value. */
10246 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10247 || (sym
->attr
.function
&& sym
->result
!= sym
))
10250 /* Try to build the initializer expression. If we can't initialize
10251 this symbol, then init will be NULL. */
10252 init
= build_default_init_expr (sym
);
10256 /* For saved variables, we don't want to add an initializer at function
10257 entry, so we just add a static initializer. Note that automatic variables
10258 are stack allocated even with -fno-automatic. */
10259 if (sym
->attr
.save
|| sym
->ns
->save_all
10260 || (gfc_option
.flag_max_stack_var_size
== 0
10261 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10263 /* Don't clobber an existing initializer! */
10264 gcc_assert (sym
->value
== NULL
);
10269 build_init_assign (sym
, init
);
10273 /* Resolution of common features of flavors variable and procedure. */
10276 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10278 gfc_array_spec
*as
;
10280 /* Avoid double diagnostics for function result symbols. */
10281 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10282 && (sym
->ns
!= gfc_current_ns
))
10285 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10286 as
= CLASS_DATA (sym
)->as
;
10290 /* Constraints on deferred shape variable. */
10291 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10293 bool pointer
, allocatable
, dimension
;
10295 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10297 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10298 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10299 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10303 pointer
= sym
->attr
.pointer
;
10304 allocatable
= sym
->attr
.allocatable
;
10305 dimension
= sym
->attr
.dimension
;
10312 gfc_error ("Allocatable array '%s' at %L must have "
10313 "a deferred shape", sym
->name
, &sym
->declared_at
);
10316 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
10317 "may not be ALLOCATABLE", sym
->name
,
10318 &sym
->declared_at
) == FAILURE
)
10322 if (pointer
&& dimension
)
10324 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10325 sym
->name
, &sym
->declared_at
);
10331 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10332 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10334 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10335 sym
->name
, &sym
->declared_at
);
10340 /* Constraints on polymorphic variables. */
10341 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10344 if (sym
->attr
.class_ok
10345 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10347 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10348 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10349 &sym
->declared_at
);
10354 /* Assume that use associated symbols were checked in the module ns.
10355 Class-variables that are associate-names are also something special
10356 and excepted from the test. */
10357 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10359 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10360 "or pointer", sym
->name
, &sym
->declared_at
);
10369 /* Additional checks for symbols with flavor variable and derived
10370 type. To be called from resolve_fl_variable. */
10373 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10375 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10377 /* Check to see if a derived type is blocked from being host
10378 associated by the presence of another class I symbol in the same
10379 namespace. 14.6.1.3 of the standard and the discussion on
10380 comp.lang.fortran. */
10381 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10382 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10385 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10386 if (s
&& s
->attr
.generic
)
10387 s
= gfc_find_dt_in_generic (s
);
10388 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10390 gfc_error ("The type '%s' cannot be host associated at %L "
10391 "because it is blocked by an incompatible object "
10392 "of the same name declared at %L",
10393 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10399 /* 4th constraint in section 11.3: "If an object of a type for which
10400 component-initialization is specified (R429) appears in the
10401 specification-part of a module and does not have the ALLOCATABLE
10402 or POINTER attribute, the object shall have the SAVE attribute."
10404 The check for initializers is performed with
10405 gfc_has_default_initializer because gfc_default_initializer generates
10406 a hidden default for allocatable components. */
10407 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10408 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10409 && !sym
->ns
->save_all
&& !sym
->attr
.save
10410 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10411 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10412 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
10413 "module variable '%s' at %L, needed due to "
10414 "the default initialization", sym
->name
,
10415 &sym
->declared_at
) == FAILURE
)
10418 /* Assign default initializer. */
10419 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10420 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10422 sym
->value
= gfc_default_initializer (&sym
->ts
);
10429 /* Resolve symbols with flavor variable. */
10432 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10434 int no_init_flag
, automatic_flag
;
10436 const char *auto_save_msg
;
10438 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10441 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10444 /* Set this flag to check that variables are parameters of all entries.
10445 This check is effected by the call to gfc_resolve_expr through
10446 is_non_constant_shape_array. */
10447 specification_expr
= 1;
10449 if (sym
->ns
->proc_name
10450 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10451 || sym
->ns
->proc_name
->attr
.is_main_program
)
10452 && !sym
->attr
.use_assoc
10453 && !sym
->attr
.allocatable
10454 && !sym
->attr
.pointer
10455 && is_non_constant_shape_array (sym
))
10457 /* The shape of a main program or module array needs to be
10459 gfc_error ("The module or main program array '%s' at %L must "
10460 "have constant shape", sym
->name
, &sym
->declared_at
);
10461 specification_expr
= 0;
10465 /* Constraints on deferred type parameter. */
10466 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10468 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10469 "requires either the pointer or allocatable attribute",
10470 sym
->name
, &sym
->declared_at
);
10474 if (sym
->ts
.type
== BT_CHARACTER
)
10476 /* Make sure that character string variables with assumed length are
10477 dummy arguments. */
10478 e
= sym
->ts
.u
.cl
->length
;
10479 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10480 && !sym
->ts
.deferred
)
10482 gfc_error ("Entity with assumed character length at %L must be a "
10483 "dummy argument or a PARAMETER", &sym
->declared_at
);
10487 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10489 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10493 if (!gfc_is_constant_expr (e
)
10494 && !(e
->expr_type
== EXPR_VARIABLE
10495 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10497 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10498 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10499 || sym
->ns
->proc_name
->attr
.is_main_program
))
10501 gfc_error ("'%s' at %L must have constant character length "
10502 "in this context", sym
->name
, &sym
->declared_at
);
10505 if (sym
->attr
.in_common
)
10507 gfc_error ("COMMON variable '%s' at %L must have constant "
10508 "character length", sym
->name
, &sym
->declared_at
);
10514 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10515 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10517 /* Determine if the symbol may not have an initializer. */
10518 no_init_flag
= automatic_flag
= 0;
10519 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10520 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10522 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10523 && is_non_constant_shape_array (sym
))
10525 no_init_flag
= automatic_flag
= 1;
10527 /* Also, they must not have the SAVE attribute.
10528 SAVE_IMPLICIT is checked below. */
10529 if (sym
->as
&& sym
->attr
.codimension
)
10531 int corank
= sym
->as
->corank
;
10532 sym
->as
->corank
= 0;
10533 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10534 sym
->as
->corank
= corank
;
10536 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10538 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10543 /* Ensure that any initializer is simplified. */
10545 gfc_simplify_expr (sym
->value
, 1);
10547 /* Reject illegal initializers. */
10548 if (!sym
->mark
&& sym
->value
)
10550 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10551 && CLASS_DATA (sym
)->attr
.allocatable
))
10552 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10553 sym
->name
, &sym
->declared_at
);
10554 else if (sym
->attr
.external
)
10555 gfc_error ("External '%s' at %L cannot have an initializer",
10556 sym
->name
, &sym
->declared_at
);
10557 else if (sym
->attr
.dummy
10558 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10559 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10560 sym
->name
, &sym
->declared_at
);
10561 else if (sym
->attr
.intrinsic
)
10562 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10563 sym
->name
, &sym
->declared_at
);
10564 else if (sym
->attr
.result
)
10565 gfc_error ("Function result '%s' at %L cannot have an initializer",
10566 sym
->name
, &sym
->declared_at
);
10567 else if (automatic_flag
)
10568 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10569 sym
->name
, &sym
->declared_at
);
10571 goto no_init_error
;
10576 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10577 return resolve_fl_variable_derived (sym
, no_init_flag
);
10583 /* Resolve a procedure. */
10586 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10588 gfc_formal_arglist
*arg
;
10590 if (sym
->attr
.function
10591 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10594 if (sym
->ts
.type
== BT_CHARACTER
)
10596 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10598 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10599 && resolve_charlen (cl
) == FAILURE
)
10602 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10603 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10605 gfc_error ("Character-valued statement function '%s' at %L must "
10606 "have constant length", sym
->name
, &sym
->declared_at
);
10611 /* Ensure that derived type for are not of a private type. Internal
10612 module procedures are excluded by 2.2.3.3 - i.e., they are not
10613 externally accessible and can access all the objects accessible in
10615 if (!(sym
->ns
->parent
10616 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10617 && gfc_check_symbol_access (sym
))
10619 gfc_interface
*iface
;
10621 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10624 && arg
->sym
->ts
.type
== BT_DERIVED
10625 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10626 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10627 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10628 "PRIVATE type and cannot be a dummy argument"
10629 " of '%s', which is PUBLIC at %L",
10630 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10633 /* Stop this message from recurring. */
10634 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10639 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10640 PRIVATE to the containing module. */
10641 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10643 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10646 && arg
->sym
->ts
.type
== BT_DERIVED
10647 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10648 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10649 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10650 "'%s' in PUBLIC interface '%s' at %L "
10651 "takes dummy arguments of '%s' which is "
10652 "PRIVATE", iface
->sym
->name
, sym
->name
,
10653 &iface
->sym
->declared_at
,
10654 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10656 /* Stop this message from recurring. */
10657 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10663 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10664 PRIVATE to the containing module. */
10665 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10667 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10670 && arg
->sym
->ts
.type
== BT_DERIVED
10671 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10672 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10673 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10674 "'%s' in PUBLIC interface '%s' at %L "
10675 "takes dummy arguments of '%s' which is "
10676 "PRIVATE", iface
->sym
->name
, sym
->name
,
10677 &iface
->sym
->declared_at
,
10678 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10680 /* Stop this message from recurring. */
10681 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10688 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10689 && !sym
->attr
.proc_pointer
)
10691 gfc_error ("Function '%s' at %L cannot have an initializer",
10692 sym
->name
, &sym
->declared_at
);
10696 /* An external symbol may not have an initializer because it is taken to be
10697 a procedure. Exception: Procedure Pointers. */
10698 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10700 gfc_error ("External object '%s' at %L may not have an initializer",
10701 sym
->name
, &sym
->declared_at
);
10705 /* An elemental function is required to return a scalar 12.7.1 */
10706 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10708 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10709 "result", sym
->name
, &sym
->declared_at
);
10710 /* Reset so that the error only occurs once. */
10711 sym
->attr
.elemental
= 0;
10715 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10716 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10718 gfc_error ("Statement function '%s' at %L may not have pointer or "
10719 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10723 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10724 char-len-param shall not be array-valued, pointer-valued, recursive
10725 or pure. ....snip... A character value of * may only be used in the
10726 following ways: (i) Dummy arg of procedure - dummy associates with
10727 actual length; (ii) To declare a named constant; or (iii) External
10728 function - but length must be declared in calling scoping unit. */
10729 if (sym
->attr
.function
10730 && sym
->ts
.type
== BT_CHARACTER
10731 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10733 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10734 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10736 if (sym
->as
&& sym
->as
->rank
)
10737 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10738 "array-valued", sym
->name
, &sym
->declared_at
);
10740 if (sym
->attr
.pointer
)
10741 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10742 "pointer-valued", sym
->name
, &sym
->declared_at
);
10744 if (sym
->attr
.pure
)
10745 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10746 "pure", sym
->name
, &sym
->declared_at
);
10748 if (sym
->attr
.recursive
)
10749 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10750 "recursive", sym
->name
, &sym
->declared_at
);
10755 /* Appendix B.2 of the standard. Contained functions give an
10756 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10757 character length is an F2003 feature. */
10758 if (!sym
->attr
.contained
10759 && gfc_current_form
!= FORM_FIXED
10760 && !sym
->ts
.deferred
)
10761 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10762 "CHARACTER(*) function '%s' at %L",
10763 sym
->name
, &sym
->declared_at
);
10766 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10768 gfc_formal_arglist
*curr_arg
;
10769 int has_non_interop_arg
= 0;
10771 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10772 sym
->common_block
) == FAILURE
)
10774 /* Clear these to prevent looking at them again if there was an
10776 sym
->attr
.is_bind_c
= 0;
10777 sym
->attr
.is_c_interop
= 0;
10778 sym
->ts
.is_c_interop
= 0;
10782 /* So far, no errors have been found. */
10783 sym
->attr
.is_c_interop
= 1;
10784 sym
->ts
.is_c_interop
= 1;
10787 curr_arg
= sym
->formal
;
10788 while (curr_arg
!= NULL
)
10790 /* Skip implicitly typed dummy args here. */
10791 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10792 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10793 /* If something is found to fail, record the fact so we
10794 can mark the symbol for the procedure as not being
10795 BIND(C) to try and prevent multiple errors being
10797 has_non_interop_arg
= 1;
10799 curr_arg
= curr_arg
->next
;
10802 /* See if any of the arguments were not interoperable and if so, clear
10803 the procedure symbol to prevent duplicate error messages. */
10804 if (has_non_interop_arg
!= 0)
10806 sym
->attr
.is_c_interop
= 0;
10807 sym
->ts
.is_c_interop
= 0;
10808 sym
->attr
.is_bind_c
= 0;
10812 if (!sym
->attr
.proc_pointer
)
10814 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10816 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10817 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10820 if (sym
->attr
.intent
)
10822 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10823 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10826 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10828 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10829 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10832 if (sym
->attr
.external
&& sym
->attr
.function
10833 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10834 || sym
->attr
.contained
))
10836 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10837 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10840 if (strcmp ("ppr@", sym
->name
) == 0)
10842 gfc_error ("Procedure pointer result '%s' at %L "
10843 "is missing the pointer attribute",
10844 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10853 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10854 been defined and we now know their defined arguments, check that they fulfill
10855 the requirements of the standard for procedures used as finalizers. */
10858 gfc_resolve_finalizers (gfc_symbol
* derived
)
10860 gfc_finalizer
* list
;
10861 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10862 gfc_try result
= SUCCESS
;
10863 bool seen_scalar
= false;
10865 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10868 /* Walk over the list of finalizer-procedures, check them, and if any one
10869 does not fit in with the standard's definition, print an error and remove
10870 it from the list. */
10871 prev_link
= &derived
->f2k_derived
->finalizers
;
10872 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10878 /* Skip this finalizer if we already resolved it. */
10879 if (list
->proc_tree
)
10881 prev_link
= &(list
->next
);
10885 /* Check this exists and is a SUBROUTINE. */
10886 if (!list
->proc_sym
->attr
.subroutine
)
10888 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10889 list
->proc_sym
->name
, &list
->where
);
10893 /* We should have exactly one argument. */
10894 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10896 gfc_error ("FINAL procedure at %L must have exactly one argument",
10900 arg
= list
->proc_sym
->formal
->sym
;
10902 /* This argument must be of our type. */
10903 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10905 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10906 &arg
->declared_at
, derived
->name
);
10910 /* It must neither be a pointer nor allocatable nor optional. */
10911 if (arg
->attr
.pointer
)
10913 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10914 &arg
->declared_at
);
10917 if (arg
->attr
.allocatable
)
10919 gfc_error ("Argument of FINAL procedure at %L must not be"
10920 " ALLOCATABLE", &arg
->declared_at
);
10923 if (arg
->attr
.optional
)
10925 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10926 &arg
->declared_at
);
10930 /* It must not be INTENT(OUT). */
10931 if (arg
->attr
.intent
== INTENT_OUT
)
10933 gfc_error ("Argument of FINAL procedure at %L must not be"
10934 " INTENT(OUT)", &arg
->declared_at
);
10938 /* Warn if the procedure is non-scalar and not assumed shape. */
10939 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10940 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10941 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10942 " shape argument", &arg
->declared_at
);
10944 /* Check that it does not match in kind and rank with a FINAL procedure
10945 defined earlier. To really loop over the *earlier* declarations,
10946 we need to walk the tail of the list as new ones were pushed at the
10948 /* TODO: Handle kind parameters once they are implemented. */
10949 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10950 for (i
= list
->next
; i
; i
= i
->next
)
10952 /* Argument list might be empty; that is an error signalled earlier,
10953 but we nevertheless continued resolving. */
10954 if (i
->proc_sym
->formal
)
10956 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10957 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10958 if (i_rank
== my_rank
)
10960 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10961 " rank (%d) as '%s'",
10962 list
->proc_sym
->name
, &list
->where
, my_rank
,
10963 i
->proc_sym
->name
);
10969 /* Is this the/a scalar finalizer procedure? */
10970 if (!arg
->as
|| arg
->as
->rank
== 0)
10971 seen_scalar
= true;
10973 /* Find the symtree for this procedure. */
10974 gcc_assert (!list
->proc_tree
);
10975 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10977 prev_link
= &list
->next
;
10980 /* Remove wrong nodes immediately from the list so we don't risk any
10981 troubles in the future when they might fail later expectations. */
10985 *prev_link
= list
->next
;
10986 gfc_free_finalizer (i
);
10989 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10990 were nodes in the list, must have been for arrays. It is surely a good
10991 idea to have a scalar version there if there's something to finalize. */
10992 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10993 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10994 " defined at %L, suggest also scalar one",
10995 derived
->name
, &derived
->declared_at
);
10997 /* TODO: Remove this error when finalization is finished. */
10998 gfc_error ("Finalization at %L is not yet implemented",
10999 &derived
->declared_at
);
11005 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11008 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11009 const char* generic_name
, locus where
)
11014 gcc_assert (t1
->specific
&& t2
->specific
);
11015 gcc_assert (!t1
->specific
->is_generic
);
11016 gcc_assert (!t2
->specific
->is_generic
);
11017 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11019 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11020 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11025 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11026 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11027 || sym1
->attr
.function
!= sym2
->attr
.function
)
11029 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11030 " GENERIC '%s' at %L",
11031 sym1
->name
, sym2
->name
, generic_name
, &where
);
11035 /* Compare the interfaces. */
11036 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11039 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11040 sym1
->name
, sym2
->name
, generic_name
, &where
);
11048 /* Worker function for resolving a generic procedure binding; this is used to
11049 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11051 The difference between those cases is finding possible inherited bindings
11052 that are overridden, as one has to look for them in tb_sym_root,
11053 tb_uop_root or tb_op, respectively. Thus the caller must already find
11054 the super-type and set p->overridden correctly. */
11057 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11058 gfc_typebound_proc
* p
, const char* name
)
11060 gfc_tbp_generic
* target
;
11061 gfc_symtree
* first_target
;
11062 gfc_symtree
* inherited
;
11064 gcc_assert (p
&& p
->is_generic
);
11066 /* Try to find the specific bindings for the symtrees in our target-list. */
11067 gcc_assert (p
->u
.generic
);
11068 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11069 if (!target
->specific
)
11071 gfc_typebound_proc
* overridden_tbp
;
11072 gfc_tbp_generic
* g
;
11073 const char* target_name
;
11075 target_name
= target
->specific_st
->name
;
11077 /* Defined for this type directly. */
11078 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11080 target
->specific
= target
->specific_st
->n
.tb
;
11081 goto specific_found
;
11084 /* Look for an inherited specific binding. */
11087 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11092 gcc_assert (inherited
->n
.tb
);
11093 target
->specific
= inherited
->n
.tb
;
11094 goto specific_found
;
11098 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11099 " at %L", target_name
, name
, &p
->where
);
11102 /* Once we've found the specific binding, check it is not ambiguous with
11103 other specifics already found or inherited for the same GENERIC. */
11105 gcc_assert (target
->specific
);
11107 /* This must really be a specific binding! */
11108 if (target
->specific
->is_generic
)
11110 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11111 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11115 /* Check those already resolved on this type directly. */
11116 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11117 if (g
!= target
&& g
->specific
11118 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11122 /* Check for ambiguity with inherited specific targets. */
11123 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11124 overridden_tbp
= overridden_tbp
->overridden
)
11125 if (overridden_tbp
->is_generic
)
11127 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11129 gcc_assert (g
->specific
);
11130 if (check_generic_tbp_ambiguity (target
, g
,
11131 name
, p
->where
) == FAILURE
)
11137 /* If we attempt to "overwrite" a specific binding, this is an error. */
11138 if (p
->overridden
&& !p
->overridden
->is_generic
)
11140 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11141 " the same name", name
, &p
->where
);
11145 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11146 all must have the same attributes here. */
11147 first_target
= p
->u
.generic
->specific
->u
.specific
;
11148 gcc_assert (first_target
);
11149 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11150 p
->function
= first_target
->n
.sym
->attr
.function
;
11156 /* Resolve a GENERIC procedure binding for a derived type. */
11159 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11161 gfc_symbol
* super_type
;
11163 /* Find the overridden binding if any. */
11164 st
->n
.tb
->overridden
= NULL
;
11165 super_type
= gfc_get_derived_super_type (derived
);
11168 gfc_symtree
* overridden
;
11169 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11172 if (overridden
&& overridden
->n
.tb
)
11173 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11176 /* Resolve using worker function. */
11177 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11181 /* Retrieve the target-procedure of an operator binding and do some checks in
11182 common for intrinsic and user-defined type-bound operators. */
11185 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11187 gfc_symbol
* target_proc
;
11189 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11190 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11191 gcc_assert (target_proc
);
11193 /* All operator bindings must have a passed-object dummy argument. */
11194 if (target
->specific
->nopass
)
11196 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11200 return target_proc
;
11204 /* Resolve a type-bound intrinsic operator. */
11207 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11208 gfc_typebound_proc
* p
)
11210 gfc_symbol
* super_type
;
11211 gfc_tbp_generic
* target
;
11213 /* If there's already an error here, do nothing (but don't fail again). */
11217 /* Operators should always be GENERIC bindings. */
11218 gcc_assert (p
->is_generic
);
11220 /* Look for an overridden binding. */
11221 super_type
= gfc_get_derived_super_type (derived
);
11222 if (super_type
&& super_type
->f2k_derived
)
11223 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11226 p
->overridden
= NULL
;
11228 /* Resolve general GENERIC properties using worker function. */
11229 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11232 /* Check the targets to be procedures of correct interface. */
11233 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11235 gfc_symbol
* target_proc
;
11237 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11241 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11253 /* Resolve a type-bound user operator (tree-walker callback). */
11255 static gfc_symbol
* resolve_bindings_derived
;
11256 static gfc_try resolve_bindings_result
;
11258 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11261 resolve_typebound_user_op (gfc_symtree
* stree
)
11263 gfc_symbol
* super_type
;
11264 gfc_tbp_generic
* target
;
11266 gcc_assert (stree
&& stree
->n
.tb
);
11268 if (stree
->n
.tb
->error
)
11271 /* Operators should always be GENERIC bindings. */
11272 gcc_assert (stree
->n
.tb
->is_generic
);
11274 /* Find overridden procedure, if any. */
11275 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11276 if (super_type
&& super_type
->f2k_derived
)
11278 gfc_symtree
* overridden
;
11279 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11280 stree
->name
, true, NULL
);
11282 if (overridden
&& overridden
->n
.tb
)
11283 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11286 stree
->n
.tb
->overridden
= NULL
;
11288 /* Resolve basically using worker function. */
11289 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11293 /* Check the targets to be functions of correct interface. */
11294 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11296 gfc_symbol
* target_proc
;
11298 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11302 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11309 resolve_bindings_result
= FAILURE
;
11310 stree
->n
.tb
->error
= 1;
11314 /* Resolve the type-bound procedures for a derived type. */
11317 resolve_typebound_procedure (gfc_symtree
* stree
)
11321 gfc_symbol
* me_arg
;
11322 gfc_symbol
* super_type
;
11323 gfc_component
* comp
;
11325 gcc_assert (stree
);
11327 /* Undefined specific symbol from GENERIC target definition. */
11331 if (stree
->n
.tb
->error
)
11334 /* If this is a GENERIC binding, use that routine. */
11335 if (stree
->n
.tb
->is_generic
)
11337 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11343 /* Get the target-procedure to check it. */
11344 gcc_assert (!stree
->n
.tb
->is_generic
);
11345 gcc_assert (stree
->n
.tb
->u
.specific
);
11346 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11347 where
= stree
->n
.tb
->where
;
11348 proc
->attr
.public_used
= 1;
11350 /* Default access should already be resolved from the parser. */
11351 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11353 /* It should be a module procedure or an external procedure with explicit
11354 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11355 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11356 || (proc
->attr
.proc
!= PROC_MODULE
11357 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11358 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11360 gfc_error ("'%s' must be a module procedure or an external procedure with"
11361 " an explicit interface at %L", proc
->name
, &where
);
11364 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11365 stree
->n
.tb
->function
= proc
->attr
.function
;
11367 /* Find the super-type of the current derived type. We could do this once and
11368 store in a global if speed is needed, but as long as not I believe this is
11369 more readable and clearer. */
11370 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11372 /* If PASS, resolve and check arguments if not already resolved / loaded
11373 from a .mod file. */
11374 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11376 if (stree
->n
.tb
->pass_arg
)
11378 gfc_formal_arglist
* i
;
11380 /* If an explicit passing argument name is given, walk the arg-list
11381 and look for it. */
11384 stree
->n
.tb
->pass_arg_num
= 1;
11385 for (i
= proc
->formal
; i
; i
= i
->next
)
11387 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11392 ++stree
->n
.tb
->pass_arg_num
;
11397 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11399 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11400 stree
->n
.tb
->pass_arg
);
11406 /* Otherwise, take the first one; there should in fact be at least
11408 stree
->n
.tb
->pass_arg_num
= 1;
11411 gfc_error ("Procedure '%s' with PASS at %L must have at"
11412 " least one argument", proc
->name
, &where
);
11415 me_arg
= proc
->formal
->sym
;
11418 /* Now check that the argument-type matches and the passed-object
11419 dummy argument is generally fine. */
11421 gcc_assert (me_arg
);
11423 if (me_arg
->ts
.type
!= BT_CLASS
)
11425 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11426 " at %L", proc
->name
, &where
);
11430 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11431 != resolve_bindings_derived
)
11433 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11434 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11435 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11439 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11440 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11442 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11443 " scalar", proc
->name
, &where
);
11446 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11448 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11449 " be ALLOCATABLE", proc
->name
, &where
);
11452 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11454 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11455 " be POINTER", proc
->name
, &where
);
11460 /* If we are extending some type, check that we don't override a procedure
11461 flagged NON_OVERRIDABLE. */
11462 stree
->n
.tb
->overridden
= NULL
;
11465 gfc_symtree
* overridden
;
11466 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11467 stree
->name
, true, NULL
);
11471 if (overridden
->n
.tb
)
11472 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11474 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11479 /* See if there's a name collision with a component directly in this type. */
11480 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11481 if (!strcmp (comp
->name
, stree
->name
))
11483 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11485 stree
->name
, &where
, resolve_bindings_derived
->name
);
11489 /* Try to find a name collision with an inherited component. */
11490 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11492 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11493 " component of '%s'",
11494 stree
->name
, &where
, resolve_bindings_derived
->name
);
11498 stree
->n
.tb
->error
= 0;
11502 resolve_bindings_result
= FAILURE
;
11503 stree
->n
.tb
->error
= 1;
11508 resolve_typebound_procedures (gfc_symbol
* derived
)
11511 gfc_symbol
* super_type
;
11513 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11516 super_type
= gfc_get_derived_super_type (derived
);
11518 resolve_typebound_procedures (super_type
);
11520 resolve_bindings_derived
= derived
;
11521 resolve_bindings_result
= SUCCESS
;
11523 /* Make sure the vtab has been generated. */
11524 gfc_find_derived_vtab (derived
);
11526 if (derived
->f2k_derived
->tb_sym_root
)
11527 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11528 &resolve_typebound_procedure
);
11530 if (derived
->f2k_derived
->tb_uop_root
)
11531 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11532 &resolve_typebound_user_op
);
11534 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11536 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11537 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11539 resolve_bindings_result
= FAILURE
;
11542 return resolve_bindings_result
;
11546 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11547 to give all identical derived types the same backend_decl. */
11549 add_dt_to_dt_list (gfc_symbol
*derived
)
11551 gfc_dt_list
*dt_list
;
11553 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11554 if (derived
== dt_list
->derived
)
11557 dt_list
= gfc_get_dt_list ();
11558 dt_list
->next
= gfc_derived_types
;
11559 dt_list
->derived
= derived
;
11560 gfc_derived_types
= dt_list
;
11564 /* Ensure that a derived-type is really not abstract, meaning that every
11565 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11568 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11573 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11575 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11578 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11580 gfc_symtree
* overriding
;
11581 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11584 gcc_assert (overriding
->n
.tb
);
11585 if (overriding
->n
.tb
->deferred
)
11587 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11588 " '%s' is DEFERRED and not overridden",
11589 sub
->name
, &sub
->declared_at
, st
->name
);
11598 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11600 /* The algorithm used here is to recursively travel up the ancestry of sub
11601 and for each ancestor-type, check all bindings. If any of them is
11602 DEFERRED, look it up starting from sub and see if the found (overriding)
11603 binding is not DEFERRED.
11604 This is not the most efficient way to do this, but it should be ok and is
11605 clearer than something sophisticated. */
11607 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11609 if (!ancestor
->attr
.abstract
)
11612 /* Walk bindings of this ancestor. */
11613 if (ancestor
->f2k_derived
)
11616 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11621 /* Find next ancestor type and recurse on it. */
11622 ancestor
= gfc_get_derived_super_type (ancestor
);
11624 return ensure_not_abstract (sub
, ancestor
);
11630 /* Resolve the components of a derived type. This does not have to wait until
11631 resolution stage, but can be done as soon as the dt declaration has been
11635 resolve_fl_derived0 (gfc_symbol
*sym
)
11637 gfc_symbol
* super_type
;
11640 super_type
= gfc_get_derived_super_type (sym
);
11643 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11645 gfc_error ("As extending type '%s' at %L has a coarray component, "
11646 "parent type '%s' shall also have one", sym
->name
,
11647 &sym
->declared_at
, super_type
->name
);
11651 /* Ensure the extended type gets resolved before we do. */
11652 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11655 /* An ABSTRACT type must be extensible. */
11656 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11658 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11659 sym
->name
, &sym
->declared_at
);
11663 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11666 for ( ; c
!= NULL
; c
= c
->next
)
11668 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11669 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
)
11671 gfc_error ("Deferred-length character component '%s' at %L is not "
11672 "yet supported", c
->name
, &c
->loc
);
11677 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11678 && c
->attr
.codimension
11679 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11681 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11682 "deferred shape", c
->name
, &c
->loc
);
11687 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11688 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11690 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11691 "shall not be a coarray", c
->name
, &c
->loc
);
11696 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11697 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11698 || c
->attr
.allocatable
))
11700 gfc_error ("Component '%s' at %L with coarray component "
11701 "shall be a nonpointer, nonallocatable scalar",
11707 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11709 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11710 "is not an array pointer", c
->name
, &c
->loc
);
11714 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11716 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11717 gfc_error ("Interface '%s', used by procedure pointer component "
11718 "'%s' at %L, is declared in a later PROCEDURE statement",
11719 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11721 /* Get the attributes from the interface (now resolved). */
11722 if (c
->ts
.interface
->attr
.if_source
11723 || c
->ts
.interface
->attr
.intrinsic
)
11725 gfc_symbol
*ifc
= c
->ts
.interface
;
11727 if (ifc
->formal
&& !ifc
->formal_ns
)
11728 resolve_symbol (ifc
);
11730 if (ifc
->attr
.intrinsic
)
11731 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11735 c
->ts
= ifc
->result
->ts
;
11736 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11737 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11738 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11739 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11744 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11745 c
->attr
.pointer
= ifc
->attr
.pointer
;
11746 c
->attr
.dimension
= ifc
->attr
.dimension
;
11747 c
->as
= gfc_copy_array_spec (ifc
->as
);
11749 c
->ts
.interface
= ifc
;
11750 c
->attr
.function
= ifc
->attr
.function
;
11751 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11752 gfc_copy_formal_args_ppc (c
, ifc
);
11754 c
->attr
.pure
= ifc
->attr
.pure
;
11755 c
->attr
.elemental
= ifc
->attr
.elemental
;
11756 c
->attr
.recursive
= ifc
->attr
.recursive
;
11757 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11758 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11759 /* Replace symbols in array spec. */
11763 for (i
= 0; i
< c
->as
->rank
; i
++)
11765 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11766 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11769 /* Copy char length. */
11770 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11772 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11773 gfc_expr_replace_comp (cl
->length
, c
);
11774 if (cl
->length
&& !cl
->resolved
11775 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11780 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11782 gfc_error ("Interface '%s' of procedure pointer component "
11783 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11788 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11790 /* Since PPCs are not implicitly typed, a PPC without an explicit
11791 interface must be a subroutine. */
11792 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11795 /* Procedure pointer components: Check PASS arg. */
11796 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11797 && !sym
->attr
.vtype
)
11799 gfc_symbol
* me_arg
;
11801 if (c
->tb
->pass_arg
)
11803 gfc_formal_arglist
* i
;
11805 /* If an explicit passing argument name is given, walk the arg-list
11806 and look for it. */
11809 c
->tb
->pass_arg_num
= 1;
11810 for (i
= c
->formal
; i
; i
= i
->next
)
11812 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11817 c
->tb
->pass_arg_num
++;
11822 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11823 "at %L has no argument '%s'", c
->name
,
11824 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11831 /* Otherwise, take the first one; there should in fact be at least
11833 c
->tb
->pass_arg_num
= 1;
11836 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11837 "must have at least one argument",
11842 me_arg
= c
->formal
->sym
;
11845 /* Now check that the argument-type matches. */
11846 gcc_assert (me_arg
);
11847 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11848 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11849 || (me_arg
->ts
.type
== BT_CLASS
11850 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11852 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11853 " the derived type '%s'", me_arg
->name
, c
->name
,
11854 me_arg
->name
, &c
->loc
, sym
->name
);
11859 /* Check for C453. */
11860 if (me_arg
->attr
.dimension
)
11862 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11863 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11869 if (me_arg
->attr
.pointer
)
11871 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11872 "may not have the POINTER attribute", me_arg
->name
,
11873 c
->name
, me_arg
->name
, &c
->loc
);
11878 if (me_arg
->attr
.allocatable
)
11880 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11881 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11882 me_arg
->name
, &c
->loc
);
11887 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11888 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11889 " at %L", c
->name
, &c
->loc
);
11893 /* Check type-spec if this is not the parent-type component. */
11894 if (((sym
->attr
.is_class
11895 && (!sym
->components
->ts
.u
.derived
->attr
.extension
11896 || c
!= sym
->components
->ts
.u
.derived
->components
))
11897 || (!sym
->attr
.is_class
11898 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
11899 && !sym
->attr
.vtype
11900 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11903 /* If this type is an extension, set the accessibility of the parent
11906 && ((sym
->attr
.is_class
11907 && c
== sym
->components
->ts
.u
.derived
->components
)
11908 || (!sym
->attr
.is_class
&& c
== sym
->components
))
11909 && strcmp (super_type
->name
, c
->name
) == 0)
11910 c
->attr
.access
= super_type
->attr
.access
;
11912 /* If this type is an extension, see if this component has the same name
11913 as an inherited type-bound procedure. */
11914 if (super_type
&& !sym
->attr
.is_class
11915 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11917 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11918 " inherited type-bound procedure",
11919 c
->name
, sym
->name
, &c
->loc
);
11923 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11924 && !c
->ts
.deferred
)
11926 if (c
->ts
.u
.cl
->length
== NULL
11927 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11928 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11930 gfc_error ("Character length of component '%s' needs to "
11931 "be a constant specification expression at %L",
11933 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11938 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11939 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11941 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11942 "length must be a POINTER or ALLOCATABLE",
11943 c
->name
, sym
->name
, &c
->loc
);
11947 if (c
->ts
.type
== BT_DERIVED
11948 && sym
->component_access
!= ACCESS_PRIVATE
11949 && gfc_check_symbol_access (sym
)
11950 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11951 && !c
->ts
.u
.derived
->attr
.use_assoc
11952 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
11953 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11954 "is a PRIVATE type and cannot be a component of "
11955 "'%s', which is PUBLIC at %L", c
->name
,
11956 sym
->name
, &sym
->declared_at
) == FAILURE
)
11959 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11961 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11962 "type %s", c
->name
, &c
->loc
, sym
->name
);
11966 if (sym
->attr
.sequence
)
11968 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11970 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11971 "not have the SEQUENCE attribute",
11972 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11977 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
11978 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
11979 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11980 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
11981 CLASS_DATA (c
)->ts
.u
.derived
11982 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
11984 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11985 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11986 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11988 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11989 "that has not been declared", c
->name
, sym
->name
,
11994 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11995 && CLASS_DATA (c
)->attr
.class_pointer
11996 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11997 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11999 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12000 "that has not been declared", c
->name
, sym
->name
,
12006 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12007 && (!c
->attr
.class_ok
12008 || !(CLASS_DATA (c
)->attr
.class_pointer
12009 || CLASS_DATA (c
)->attr
.allocatable
)))
12011 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12012 "or pointer", c
->name
, &c
->loc
);
12016 /* Ensure that all the derived type components are put on the
12017 derived type list; even in formal namespaces, where derived type
12018 pointer components might not have been declared. */
12019 if (c
->ts
.type
== BT_DERIVED
12021 && c
->ts
.u
.derived
->components
12023 && sym
!= c
->ts
.u
.derived
)
12024 add_dt_to_dt_list (c
->ts
.u
.derived
);
12026 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
12027 || c
->attr
.proc_pointer
12028 || c
->attr
.allocatable
)) == FAILURE
)
12032 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12033 all DEFERRED bindings are overridden. */
12034 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12035 && !sym
->attr
.is_class
12036 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
12039 /* Add derived type to the derived type list. */
12040 add_dt_to_dt_list (sym
);
12046 /* The following procedure does the full resolution of a derived type,
12047 including resolution of all type-bound procedures (if present). In contrast
12048 to 'resolve_fl_derived0' this can only be done after the module has been
12049 parsed completely. */
12052 resolve_fl_derived (gfc_symbol
*sym
)
12054 gfc_symbol
*gen_dt
= NULL
;
12056 if (!sym
->attr
.is_class
)
12057 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12058 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12059 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12060 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12061 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Generic name '%s' of "
12062 "function '%s' at %L being the same name as derived "
12063 "type at %L", sym
->name
,
12064 gen_dt
->generic
->sym
== sym
12065 ? gen_dt
->generic
->next
->sym
->name
12066 : gen_dt
->generic
->sym
->name
,
12067 gen_dt
->generic
->sym
== sym
12068 ? &gen_dt
->generic
->next
->sym
->declared_at
12069 : &gen_dt
->generic
->sym
->declared_at
,
12070 &sym
->declared_at
) == FAILURE
)
12073 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12075 /* Fix up incomplete CLASS symbols. */
12076 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12077 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12078 if (vptr
->ts
.u
.derived
== NULL
)
12080 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12082 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12086 if (resolve_fl_derived0 (sym
) == FAILURE
)
12089 /* Resolve the type-bound procedures. */
12090 if (resolve_typebound_procedures (sym
) == FAILURE
)
12093 /* Resolve the finalizer procedures. */
12094 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12102 resolve_fl_namelist (gfc_symbol
*sym
)
12107 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12109 /* Check again, the check in match only works if NAMELIST comes
12111 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12113 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12114 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12118 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12119 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12120 "object '%s' with assumed shape in namelist "
12121 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12122 &sym
->declared_at
) == FAILURE
)
12125 if (is_non_constant_shape_array (nl
->sym
)
12126 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12127 "object '%s' with nonconstant shape in namelist "
12128 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12129 &sym
->declared_at
) == FAILURE
)
12132 if (nl
->sym
->ts
.type
== BT_CHARACTER
12133 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12134 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12135 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12136 "'%s' with nonconstant character length in "
12137 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12138 &sym
->declared_at
) == FAILURE
)
12141 /* FIXME: Once UDDTIO is implemented, the following can be
12143 if (nl
->sym
->ts
.type
== BT_CLASS
)
12145 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12146 "polymorphic and requires a defined input/output "
12147 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12151 if (nl
->sym
->ts
.type
== BT_DERIVED
12152 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12153 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12155 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12156 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12157 "or POINTER components", nl
->sym
->name
,
12158 sym
->name
, &sym
->declared_at
) == FAILURE
)
12161 /* FIXME: Once UDDTIO is implemented, the following can be
12163 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12164 "ALLOCATABLE or POINTER components and thus requires "
12165 "a defined input/output procedure", nl
->sym
->name
,
12166 sym
->name
, &sym
->declared_at
);
12171 /* Reject PRIVATE objects in a PUBLIC namelist. */
12172 if (gfc_check_symbol_access (sym
))
12174 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12176 if (!nl
->sym
->attr
.use_assoc
12177 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12178 && !gfc_check_symbol_access (nl
->sym
))
12180 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12181 "cannot be member of PUBLIC namelist '%s' at %L",
12182 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12186 /* Types with private components that came here by USE-association. */
12187 if (nl
->sym
->ts
.type
== BT_DERIVED
12188 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12190 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12191 "components and cannot be member of namelist '%s' at %L",
12192 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12196 /* Types with private components that are defined in the same module. */
12197 if (nl
->sym
->ts
.type
== BT_DERIVED
12198 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12199 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12201 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12202 "cannot be a member of PUBLIC namelist '%s' at %L",
12203 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12210 /* 14.1.2 A module or internal procedure represent local entities
12211 of the same type as a namelist member and so are not allowed. */
12212 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12214 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12217 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12218 if ((nl
->sym
== sym
->ns
->proc_name
)
12220 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12224 if (nl
->sym
&& nl
->sym
->name
)
12225 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12226 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12228 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12229 "attribute in '%s' at %L", nlsym
->name
,
12230 &sym
->declared_at
);
12240 resolve_fl_parameter (gfc_symbol
*sym
)
12242 /* A parameter array's shape needs to be constant. */
12243 if (sym
->as
!= NULL
12244 && (sym
->as
->type
== AS_DEFERRED
12245 || is_non_constant_shape_array (sym
)))
12247 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12248 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12252 /* Make sure a parameter that has been implicitly typed still
12253 matches the implicit type, since PARAMETER statements can precede
12254 IMPLICIT statements. */
12255 if (sym
->attr
.implicit_type
12256 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12259 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12260 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12264 /* Make sure the types of derived parameters are consistent. This
12265 type checking is deferred until resolution because the type may
12266 refer to a derived type from the host. */
12267 if (sym
->ts
.type
== BT_DERIVED
12268 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12270 gfc_error ("Incompatible derived type in PARAMETER at %L",
12271 &sym
->value
->where
);
12278 /* Do anything necessary to resolve a symbol. Right now, we just
12279 assume that an otherwise unknown symbol is a variable. This sort
12280 of thing commonly happens for symbols in module. */
12283 resolve_symbol (gfc_symbol
*sym
)
12285 int check_constant
, mp_flag
;
12286 gfc_symtree
*symtree
;
12287 gfc_symtree
*this_symtree
;
12290 symbol_attribute class_attr
;
12291 gfc_array_spec
*as
;
12293 if (sym
->attr
.flavor
== FL_UNKNOWN
12294 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12295 && !sym
->attr
.generic
&& !sym
->attr
.external
12296 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12299 /* If we find that a flavorless symbol is an interface in one of the
12300 parent namespaces, find its symtree in this namespace, free the
12301 symbol and set the symtree to point to the interface symbol. */
12302 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12304 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12305 if (symtree
&& (symtree
->n
.sym
->generic
||
12306 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12307 && sym
->ns
->construct_entities
)))
12309 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12311 gfc_release_symbol (sym
);
12312 symtree
->n
.sym
->refs
++;
12313 this_symtree
->n
.sym
= symtree
->n
.sym
;
12318 /* Otherwise give it a flavor according to such attributes as
12320 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12321 && sym
->attr
.intrinsic
== 0)
12322 sym
->attr
.flavor
= FL_VARIABLE
;
12323 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12325 sym
->attr
.flavor
= FL_PROCEDURE
;
12326 if (sym
->attr
.dimension
)
12327 sym
->attr
.function
= 1;
12331 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12332 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12334 if (sym
->attr
.procedure
&& sym
->ts
.interface
12335 && sym
->attr
.if_source
!= IFSRC_DECL
12336 && resolve_procedure_interface (sym
) == FAILURE
)
12339 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12340 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12342 if (sym
->attr
.external
)
12343 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12344 "at %L", &sym
->declared_at
);
12346 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12347 "at %L", &sym
->declared_at
);
12352 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12355 /* Symbols that are module procedures with results (functions) have
12356 the types and array specification copied for type checking in
12357 procedures that call them, as well as for saving to a module
12358 file. These symbols can't stand the scrutiny that their results
12360 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12362 /* Make sure that the intrinsic is consistent with its internal
12363 representation. This needs to be done before assigning a default
12364 type to avoid spurious warnings. */
12365 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12366 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12369 /* Resolve associate names. */
12371 resolve_assoc_var (sym
, true);
12373 /* Assign default type to symbols that need one and don't have one. */
12374 if (sym
->ts
.type
== BT_UNKNOWN
)
12376 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12378 gfc_set_default_type (sym
, 1, NULL
);
12381 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12382 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12383 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12384 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12386 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12388 /* The specific case of an external procedure should emit an error
12389 in the case that there is no implicit type. */
12391 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12394 /* Result may be in another namespace. */
12395 resolve_symbol (sym
->result
);
12397 if (!sym
->result
->attr
.proc_pointer
)
12399 sym
->ts
= sym
->result
->ts
;
12400 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12401 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12402 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12403 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12404 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12409 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12410 gfc_resolve_array_spec (sym
->result
->as
, false);
12412 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12414 as
= CLASS_DATA (sym
)->as
;
12415 class_attr
= CLASS_DATA (sym
)->attr
;
12416 class_attr
.pointer
= class_attr
.class_pointer
;
12420 class_attr
= sym
->attr
;
12425 if (sym
->attr
.contiguous
12426 && (!class_attr
.dimension
12427 || (as
->type
!= AS_ASSUMED_SHAPE
&& !class_attr
.pointer
)))
12429 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12430 "array pointer or an assumed-shape array", sym
->name
,
12431 &sym
->declared_at
);
12435 /* Assumed size arrays and assumed shape arrays must be dummy
12436 arguments. Array-spec's of implied-shape should have been resolved to
12437 AS_EXPLICIT already. */
12441 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12442 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12443 || as
->type
== AS_ASSUMED_SHAPE
)
12444 && sym
->attr
.dummy
== 0)
12446 if (as
->type
== AS_ASSUMED_SIZE
)
12447 gfc_error ("Assumed size array at %L must be a dummy argument",
12448 &sym
->declared_at
);
12450 gfc_error ("Assumed shape array at %L must be a dummy argument",
12451 &sym
->declared_at
);
12456 /* Make sure symbols with known intent or optional are really dummy
12457 variable. Because of ENTRY statement, this has to be deferred
12458 until resolution time. */
12460 if (!sym
->attr
.dummy
12461 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12463 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12467 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12469 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12470 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12474 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12476 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12477 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12479 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12480 "attribute must have constant length",
12481 sym
->name
, &sym
->declared_at
);
12485 if (sym
->ts
.is_c_interop
12486 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12488 gfc_error ("C interoperable character dummy variable '%s' at %L "
12489 "with VALUE attribute must have length one",
12490 sym
->name
, &sym
->declared_at
);
12495 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12496 && sym
->ts
.u
.derived
->attr
.generic
)
12498 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12499 if (!sym
->ts
.u
.derived
)
12501 gfc_error ("The derived type '%s' at %L is of type '%s', "
12502 "which has not been defined", sym
->name
,
12503 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12504 sym
->ts
.type
= BT_UNKNOWN
;
12509 if (sym
->ts
.type
== BT_ASSUMED
)
12511 /* TS 29113, C407a. */
12512 if (!sym
->attr
.dummy
)
12514 gfc_error ("Assumed type of variable %s at %L is only permitted "
12515 "for dummy variables", sym
->name
, &sym
->declared_at
);
12518 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12519 || sym
->attr
.pointer
|| sym
->attr
.value
)
12521 gfc_error ("Assumed-type variable %s at %L may not have the "
12522 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12523 sym
->name
, &sym
->declared_at
);
12526 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12528 gfc_error ("Assumed-type variable %s at %L shall not be an "
12529 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12534 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12535 do this for something that was implicitly typed because that is handled
12536 in gfc_set_default_type. Handle dummy arguments and procedure
12537 definitions separately. Also, anything that is use associated is not
12538 handled here but instead is handled in the module it is declared in.
12539 Finally, derived type definitions are allowed to be BIND(C) since that
12540 only implies that they're interoperable, and they are checked fully for
12541 interoperability when a variable is declared of that type. */
12542 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12543 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12544 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12546 gfc_try t
= SUCCESS
;
12548 /* First, make sure the variable is declared at the
12549 module-level scope (J3/04-007, Section 15.3). */
12550 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12551 sym
->attr
.in_common
== 0)
12553 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12554 "is neither a COMMON block nor declared at the "
12555 "module level scope", sym
->name
, &(sym
->declared_at
));
12558 else if (sym
->common_head
!= NULL
)
12560 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12564 /* If type() declaration, we need to verify that the components
12565 of the given type are all C interoperable, etc. */
12566 if (sym
->ts
.type
== BT_DERIVED
&&
12567 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12569 /* Make sure the user marked the derived type as BIND(C). If
12570 not, call the verify routine. This could print an error
12571 for the derived type more than once if multiple variables
12572 of that type are declared. */
12573 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12574 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12578 /* Verify the variable itself as C interoperable if it
12579 is BIND(C). It is not possible for this to succeed if
12580 the verify_bind_c_derived_type failed, so don't have to handle
12581 any error returned by verify_bind_c_derived_type. */
12582 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12583 sym
->common_block
);
12588 /* clear the is_bind_c flag to prevent reporting errors more than
12589 once if something failed. */
12590 sym
->attr
.is_bind_c
= 0;
12595 /* If a derived type symbol has reached this point, without its
12596 type being declared, we have an error. Notice that most
12597 conditions that produce undefined derived types have already
12598 been dealt with. However, the likes of:
12599 implicit type(t) (t) ..... call foo (t) will get us here if
12600 the type is not declared in the scope of the implicit
12601 statement. Change the type to BT_UNKNOWN, both because it is so
12602 and to prevent an ICE. */
12603 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12604 && sym
->ts
.u
.derived
->components
== NULL
12605 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12607 gfc_error ("The derived type '%s' at %L is of type '%s', "
12608 "which has not been defined", sym
->name
,
12609 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12610 sym
->ts
.type
= BT_UNKNOWN
;
12614 /* Make sure that the derived type has been resolved and that the
12615 derived type is visible in the symbol's namespace, if it is a
12616 module function and is not PRIVATE. */
12617 if (sym
->ts
.type
== BT_DERIVED
12618 && sym
->ts
.u
.derived
->attr
.use_assoc
12619 && sym
->ns
->proc_name
12620 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12621 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12624 /* Unless the derived-type declaration is use associated, Fortran 95
12625 does not allow public entries of private derived types.
12626 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12627 161 in 95-006r3. */
12628 if (sym
->ts
.type
== BT_DERIVED
12629 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12630 && !sym
->ts
.u
.derived
->attr
.use_assoc
12631 && gfc_check_symbol_access (sym
)
12632 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12633 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12634 "of PRIVATE derived type '%s'",
12635 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12636 : "variable", sym
->name
, &sym
->declared_at
,
12637 sym
->ts
.u
.derived
->name
) == FAILURE
)
12640 /* F2008, C1302. */
12641 if (sym
->ts
.type
== BT_DERIVED
12642 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12643 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12644 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12645 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12647 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12648 "type LOCK_TYPE must be a coarray", sym
->name
,
12649 &sym
->declared_at
);
12653 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12654 default initialization is defined (5.1.2.4.4). */
12655 if (sym
->ts
.type
== BT_DERIVED
12657 && sym
->attr
.intent
== INTENT_OUT
12659 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12661 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12663 if (c
->initializer
)
12665 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12666 "ASSUMED SIZE and so cannot have a default initializer",
12667 sym
->name
, &sym
->declared_at
);
12674 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12675 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12677 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12678 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12683 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12684 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12685 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12686 || class_attr
.codimension
)
12687 && (sym
->attr
.result
|| sym
->result
== sym
))
12689 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12690 "a coarray component", sym
->name
, &sym
->declared_at
);
12695 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12696 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12698 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12699 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12704 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12705 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12706 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12707 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12708 || class_attr
.allocatable
))
12710 gfc_error ("Variable '%s' at %L with coarray component "
12711 "shall be a nonpointer, nonallocatable scalar",
12712 sym
->name
, &sym
->declared_at
);
12716 /* F2008, C526. The function-result case was handled above. */
12717 if (class_attr
.codimension
12718 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12719 || sym
->attr
.select_type_temporary
12720 || sym
->ns
->save_all
12721 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12722 || sym
->ns
->proc_name
->attr
.is_main_program
12723 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12725 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12726 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12730 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
12731 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
12733 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12734 "deferred shape", sym
->name
, &sym
->declared_at
);
12737 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
12738 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
12740 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12741 "deferred shape", sym
->name
, &sym
->declared_at
);
12746 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12747 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12748 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12749 || (class_attr
.codimension
&& class_attr
.allocatable
))
12750 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12752 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12753 "allocatable coarray or have coarray components",
12754 sym
->name
, &sym
->declared_at
);
12758 if (class_attr
.codimension
&& sym
->attr
.dummy
12759 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12761 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12762 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12763 sym
->ns
->proc_name
->name
);
12767 switch (sym
->attr
.flavor
)
12770 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12775 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12780 if (resolve_fl_namelist (sym
) == FAILURE
)
12785 if (resolve_fl_parameter (sym
) == FAILURE
)
12793 /* Resolve array specifier. Check as well some constraints
12794 on COMMON blocks. */
12796 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12798 /* Set the formal_arg_flag so that check_conflict will not throw
12799 an error for host associated variables in the specification
12800 expression for an array_valued function. */
12801 if (sym
->attr
.function
&& sym
->as
)
12802 formal_arg_flag
= 1;
12804 gfc_resolve_array_spec (sym
->as
, check_constant
);
12806 formal_arg_flag
= 0;
12808 /* Resolve formal namespaces. */
12809 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12810 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12811 gfc_resolve (sym
->formal_ns
);
12813 /* Make sure the formal namespace is present. */
12814 if (sym
->formal
&& !sym
->formal_ns
)
12816 gfc_formal_arglist
*formal
= sym
->formal
;
12817 while (formal
&& !formal
->sym
)
12818 formal
= formal
->next
;
12822 sym
->formal_ns
= formal
->sym
->ns
;
12823 sym
->formal_ns
->refs
++;
12827 /* Check threadprivate restrictions. */
12828 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12829 && (!sym
->attr
.in_common
12830 && sym
->module
== NULL
12831 && (sym
->ns
->proc_name
== NULL
12832 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12833 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12835 /* If we have come this far we can apply default-initializers, as
12836 described in 14.7.5, to those variables that have not already
12837 been assigned one. */
12838 if (sym
->ts
.type
== BT_DERIVED
12839 && sym
->ns
== gfc_current_ns
12841 && !sym
->attr
.allocatable
12842 && !sym
->attr
.alloc_comp
)
12844 symbol_attribute
*a
= &sym
->attr
;
12846 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12847 && !a
->in_common
&& !a
->use_assoc
12848 && (a
->referenced
|| a
->result
)
12849 && !(a
->function
&& sym
!= sym
->result
))
12850 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12851 apply_default_init (sym
);
12854 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12855 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12856 && !CLASS_DATA (sym
)->attr
.class_pointer
12857 && !CLASS_DATA (sym
)->attr
.allocatable
)
12858 apply_default_init (sym
);
12860 /* If this symbol has a type-spec, check it. */
12861 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12862 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12863 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12869 /************* Resolve DATA statements *************/
12873 gfc_data_value
*vnode
;
12879 /* Advance the values structure to point to the next value in the data list. */
12882 next_data_value (void)
12884 while (mpz_cmp_ui (values
.left
, 0) == 0)
12887 if (values
.vnode
->next
== NULL
)
12890 values
.vnode
= values
.vnode
->next
;
12891 mpz_set (values
.left
, values
.vnode
->repeat
);
12899 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12905 ar_type mark
= AR_UNKNOWN
;
12907 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12913 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12917 mpz_init_set_si (offset
, 0);
12920 if (e
->expr_type
!= EXPR_VARIABLE
)
12921 gfc_internal_error ("check_data_variable(): Bad expression");
12923 sym
= e
->symtree
->n
.sym
;
12925 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12927 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12928 sym
->name
, &sym
->declared_at
);
12931 if (e
->ref
== NULL
&& sym
->as
)
12933 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12934 " declaration", sym
->name
, where
);
12938 has_pointer
= sym
->attr
.pointer
;
12940 if (gfc_is_coindexed (e
))
12942 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
12947 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12949 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12953 && ref
->type
== REF_ARRAY
12954 && ref
->u
.ar
.type
!= AR_FULL
)
12956 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12957 "be a full array", sym
->name
, where
);
12962 if (e
->rank
== 0 || has_pointer
)
12964 mpz_init_set_ui (size
, 1);
12971 /* Find the array section reference. */
12972 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12974 if (ref
->type
!= REF_ARRAY
)
12976 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12982 /* Set marks according to the reference pattern. */
12983 switch (ref
->u
.ar
.type
)
12991 /* Get the start position of array section. */
12992 gfc_get_section_index (ar
, section_index
, &offset
);
12997 gcc_unreachable ();
13000 if (gfc_array_size (e
, &size
) == FAILURE
)
13002 gfc_error ("Nonconstant array section at %L in DATA statement",
13004 mpz_clear (offset
);
13011 while (mpz_cmp_ui (size
, 0) > 0)
13013 if (next_data_value () == FAILURE
)
13015 gfc_error ("DATA statement at %L has more variables than values",
13021 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13025 /* If we have more than one element left in the repeat count,
13026 and we have more than one element left in the target variable,
13027 then create a range assignment. */
13028 /* FIXME: Only done for full arrays for now, since array sections
13030 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13031 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13035 if (mpz_cmp (size
, values
.left
) >= 0)
13037 mpz_init_set (range
, values
.left
);
13038 mpz_sub (size
, size
, values
.left
);
13039 mpz_set_ui (values
.left
, 0);
13043 mpz_init_set (range
, size
);
13044 mpz_sub (values
.left
, values
.left
, size
);
13045 mpz_set_ui (size
, 0);
13048 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13051 mpz_add (offset
, offset
, range
);
13058 /* Assign initial value to symbol. */
13061 mpz_sub_ui (values
.left
, values
.left
, 1);
13062 mpz_sub_ui (size
, size
, 1);
13064 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13069 if (mark
== AR_FULL
)
13070 mpz_add_ui (offset
, offset
, 1);
13072 /* Modify the array section indexes and recalculate the offset
13073 for next element. */
13074 else if (mark
== AR_SECTION
)
13075 gfc_advance_section (section_index
, ar
, &offset
);
13079 if (mark
== AR_SECTION
)
13081 for (i
= 0; i
< ar
->dimen
; i
++)
13082 mpz_clear (section_index
[i
]);
13086 mpz_clear (offset
);
13092 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
13094 /* Iterate over a list of elements in a DATA statement. */
13097 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13100 iterator_stack frame
;
13101 gfc_expr
*e
, *start
, *end
, *step
;
13102 gfc_try retval
= SUCCESS
;
13104 mpz_init (frame
.value
);
13107 start
= gfc_copy_expr (var
->iter
.start
);
13108 end
= gfc_copy_expr (var
->iter
.end
);
13109 step
= gfc_copy_expr (var
->iter
.step
);
13111 if (gfc_simplify_expr (start
, 1) == FAILURE
13112 || start
->expr_type
!= EXPR_CONSTANT
)
13114 gfc_error ("start of implied-do loop at %L could not be "
13115 "simplified to a constant value", &start
->where
);
13119 if (gfc_simplify_expr (end
, 1) == FAILURE
13120 || end
->expr_type
!= EXPR_CONSTANT
)
13122 gfc_error ("end of implied-do loop at %L could not be "
13123 "simplified to a constant value", &start
->where
);
13127 if (gfc_simplify_expr (step
, 1) == FAILURE
13128 || step
->expr_type
!= EXPR_CONSTANT
)
13130 gfc_error ("step of implied-do loop at %L could not be "
13131 "simplified to a constant value", &start
->where
);
13136 mpz_set (trip
, end
->value
.integer
);
13137 mpz_sub (trip
, trip
, start
->value
.integer
);
13138 mpz_add (trip
, trip
, step
->value
.integer
);
13140 mpz_div (trip
, trip
, step
->value
.integer
);
13142 mpz_set (frame
.value
, start
->value
.integer
);
13144 frame
.prev
= iter_stack
;
13145 frame
.variable
= var
->iter
.var
->symtree
;
13146 iter_stack
= &frame
;
13148 while (mpz_cmp_ui (trip
, 0) > 0)
13150 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13156 e
= gfc_copy_expr (var
->expr
);
13157 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13164 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13166 mpz_sub_ui (trip
, trip
, 1);
13170 mpz_clear (frame
.value
);
13173 gfc_free_expr (start
);
13174 gfc_free_expr (end
);
13175 gfc_free_expr (step
);
13177 iter_stack
= frame
.prev
;
13182 /* Type resolve variables in the variable list of a DATA statement. */
13185 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13189 for (; var
; var
= var
->next
)
13191 if (var
->expr
== NULL
)
13192 t
= traverse_data_list (var
, where
);
13194 t
= check_data_variable (var
, where
);
13204 /* Resolve the expressions and iterators associated with a data statement.
13205 This is separate from the assignment checking because data lists should
13206 only be resolved once. */
13209 resolve_data_variables (gfc_data_variable
*d
)
13211 for (; d
; d
= d
->next
)
13213 if (d
->list
== NULL
)
13215 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13220 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
13223 if (resolve_data_variables (d
->list
) == FAILURE
)
13232 /* Resolve a single DATA statement. We implement this by storing a pointer to
13233 the value list into static variables, and then recursively traversing the
13234 variables list, expanding iterators and such. */
13237 resolve_data (gfc_data
*d
)
13240 if (resolve_data_variables (d
->var
) == FAILURE
)
13243 values
.vnode
= d
->value
;
13244 if (d
->value
== NULL
)
13245 mpz_set_ui (values
.left
, 0);
13247 mpz_set (values
.left
, d
->value
->repeat
);
13249 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13252 /* At this point, we better not have any values left. */
13254 if (next_data_value () == SUCCESS
)
13255 gfc_error ("DATA statement at %L has more values than variables",
13260 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13261 accessed by host or use association, is a dummy argument to a pure function,
13262 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13263 is storage associated with any such variable, shall not be used in the
13264 following contexts: (clients of this function). */
13266 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13267 procedure. Returns zero if assignment is OK, nonzero if there is a
13270 gfc_impure_variable (gfc_symbol
*sym
)
13275 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13278 /* Check if the symbol's ns is inside the pure procedure. */
13279 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13283 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13287 proc
= sym
->ns
->proc_name
;
13288 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13289 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13291 proc
->attr
.function
))
13294 /* TODO: Sort out what can be storage associated, if anything, and include
13295 it here. In principle equivalences should be scanned but it does not
13296 seem to be possible to storage associate an impure variable this way. */
13301 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13302 current namespace is inside a pure procedure. */
13305 gfc_pure (gfc_symbol
*sym
)
13307 symbol_attribute attr
;
13312 /* Check if the current namespace or one of its parents
13313 belongs to a pure procedure. */
13314 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13316 sym
= ns
->proc_name
;
13320 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13328 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13332 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13333 checks if the current namespace is implicitly pure. Note that this
13334 function returns false for a PURE procedure. */
13337 gfc_implicit_pure (gfc_symbol
*sym
)
13343 /* Check if the current procedure is implicit_pure. Walk up
13344 the procedure list until we find a procedure. */
13345 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13347 sym
= ns
->proc_name
;
13351 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13356 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13357 && !sym
->attr
.pure
;
13361 /* Test whether the current procedure is elemental or not. */
13364 gfc_elemental (gfc_symbol
*sym
)
13366 symbol_attribute attr
;
13369 sym
= gfc_current_ns
->proc_name
;
13374 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13378 /* Warn about unused labels. */
13381 warn_unused_fortran_label (gfc_st_label
*label
)
13386 warn_unused_fortran_label (label
->left
);
13388 if (label
->defined
== ST_LABEL_UNKNOWN
)
13391 switch (label
->referenced
)
13393 case ST_LABEL_UNKNOWN
:
13394 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13398 case ST_LABEL_BAD_TARGET
:
13399 gfc_warning ("Label %d at %L defined but cannot be used",
13400 label
->value
, &label
->where
);
13407 warn_unused_fortran_label (label
->right
);
13411 /* Returns the sequence type of a symbol or sequence. */
13414 sequence_type (gfc_typespec ts
)
13423 if (ts
.u
.derived
->components
== NULL
)
13424 return SEQ_NONDEFAULT
;
13426 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13427 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13428 if (sequence_type (c
->ts
) != result
)
13434 if (ts
.kind
!= gfc_default_character_kind
)
13435 return SEQ_NONDEFAULT
;
13437 return SEQ_CHARACTER
;
13440 if (ts
.kind
!= gfc_default_integer_kind
)
13441 return SEQ_NONDEFAULT
;
13443 return SEQ_NUMERIC
;
13446 if (!(ts
.kind
== gfc_default_real_kind
13447 || ts
.kind
== gfc_default_double_kind
))
13448 return SEQ_NONDEFAULT
;
13450 return SEQ_NUMERIC
;
13453 if (ts
.kind
!= gfc_default_complex_kind
)
13454 return SEQ_NONDEFAULT
;
13456 return SEQ_NUMERIC
;
13459 if (ts
.kind
!= gfc_default_logical_kind
)
13460 return SEQ_NONDEFAULT
;
13462 return SEQ_NUMERIC
;
13465 return SEQ_NONDEFAULT
;
13470 /* Resolve derived type EQUIVALENCE object. */
13473 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13475 gfc_component
*c
= derived
->components
;
13480 /* Shall not be an object of nonsequence derived type. */
13481 if (!derived
->attr
.sequence
)
13483 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13484 "attribute to be an EQUIVALENCE object", sym
->name
,
13489 /* Shall not have allocatable components. */
13490 if (derived
->attr
.alloc_comp
)
13492 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13493 "components to be an EQUIVALENCE object",sym
->name
,
13498 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13500 gfc_error ("Derived type variable '%s' at %L with default "
13501 "initialization cannot be in EQUIVALENCE with a variable "
13502 "in COMMON", sym
->name
, &e
->where
);
13506 for (; c
; c
= c
->next
)
13508 if (c
->ts
.type
== BT_DERIVED
13509 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13512 /* Shall not be an object of sequence derived type containing a pointer
13513 in the structure. */
13514 if (c
->attr
.pointer
)
13516 gfc_error ("Derived type variable '%s' at %L with pointer "
13517 "component(s) cannot be an EQUIVALENCE object",
13518 sym
->name
, &e
->where
);
13526 /* Resolve equivalence object.
13527 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13528 an allocatable array, an object of nonsequence derived type, an object of
13529 sequence derived type containing a pointer at any level of component
13530 selection, an automatic object, a function name, an entry name, a result
13531 name, a named constant, a structure component, or a subobject of any of
13532 the preceding objects. A substring shall not have length zero. A
13533 derived type shall not have components with default initialization nor
13534 shall two objects of an equivalence group be initialized.
13535 Either all or none of the objects shall have an protected attribute.
13536 The simple constraints are done in symbol.c(check_conflict) and the rest
13537 are implemented here. */
13540 resolve_equivalence (gfc_equiv
*eq
)
13543 gfc_symbol
*first_sym
;
13546 locus
*last_where
= NULL
;
13547 seq_type eq_type
, last_eq_type
;
13548 gfc_typespec
*last_ts
;
13549 int object
, cnt_protected
;
13552 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13554 first_sym
= eq
->expr
->symtree
->n
.sym
;
13558 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13562 e
->ts
= e
->symtree
->n
.sym
->ts
;
13563 /* match_varspec might not know yet if it is seeing
13564 array reference or substring reference, as it doesn't
13566 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13568 gfc_ref
*ref
= e
->ref
;
13569 sym
= e
->symtree
->n
.sym
;
13571 if (sym
->attr
.dimension
)
13573 ref
->u
.ar
.as
= sym
->as
;
13577 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13578 if (e
->ts
.type
== BT_CHARACTER
13580 && ref
->type
== REF_ARRAY
13581 && ref
->u
.ar
.dimen
== 1
13582 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13583 && ref
->u
.ar
.stride
[0] == NULL
)
13585 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13586 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13589 /* Optimize away the (:) reference. */
13590 if (start
== NULL
&& end
== NULL
)
13593 e
->ref
= ref
->next
;
13595 e
->ref
->next
= ref
->next
;
13600 ref
->type
= REF_SUBSTRING
;
13602 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13604 ref
->u
.ss
.start
= start
;
13605 if (end
== NULL
&& e
->ts
.u
.cl
)
13606 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13607 ref
->u
.ss
.end
= end
;
13608 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13615 /* Any further ref is an error. */
13618 gcc_assert (ref
->type
== REF_ARRAY
);
13619 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13625 if (gfc_resolve_expr (e
) == FAILURE
)
13628 sym
= e
->symtree
->n
.sym
;
13630 if (sym
->attr
.is_protected
)
13632 if (cnt_protected
> 0 && cnt_protected
!= object
)
13634 gfc_error ("Either all or none of the objects in the "
13635 "EQUIVALENCE set at %L shall have the "
13636 "PROTECTED attribute",
13641 /* Shall not equivalence common block variables in a PURE procedure. */
13642 if (sym
->ns
->proc_name
13643 && sym
->ns
->proc_name
->attr
.pure
13644 && sym
->attr
.in_common
)
13646 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13647 "object in the pure procedure '%s'",
13648 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13652 /* Shall not be a named constant. */
13653 if (e
->expr_type
== EXPR_CONSTANT
)
13655 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13656 "object", sym
->name
, &e
->where
);
13660 if (e
->ts
.type
== BT_DERIVED
13661 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13664 /* Check that the types correspond correctly:
13666 A numeric sequence structure may be equivalenced to another sequence
13667 structure, an object of default integer type, default real type, double
13668 precision real type, default logical type such that components of the
13669 structure ultimately only become associated to objects of the same
13670 kind. A character sequence structure may be equivalenced to an object
13671 of default character kind or another character sequence structure.
13672 Other objects may be equivalenced only to objects of the same type and
13673 kind parameters. */
13675 /* Identical types are unconditionally OK. */
13676 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13677 goto identical_types
;
13679 last_eq_type
= sequence_type (*last_ts
);
13680 eq_type
= sequence_type (sym
->ts
);
13682 /* Since the pair of objects is not of the same type, mixed or
13683 non-default sequences can be rejected. */
13685 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13686 "statement at %L with different type objects";
13688 && last_eq_type
== SEQ_MIXED
13689 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13691 || (eq_type
== SEQ_MIXED
13692 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13693 &e
->where
) == FAILURE
))
13696 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13697 "statement at %L with objects of different type";
13699 && last_eq_type
== SEQ_NONDEFAULT
13700 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13701 last_where
) == FAILURE
)
13702 || (eq_type
== SEQ_NONDEFAULT
13703 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13704 &e
->where
) == FAILURE
))
13707 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13708 "EQUIVALENCE statement at %L";
13709 if (last_eq_type
== SEQ_CHARACTER
13710 && eq_type
!= SEQ_CHARACTER
13711 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13712 &e
->where
) == FAILURE
)
13715 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13716 "EQUIVALENCE statement at %L";
13717 if (last_eq_type
== SEQ_NUMERIC
13718 && eq_type
!= SEQ_NUMERIC
13719 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13720 &e
->where
) == FAILURE
)
13725 last_where
= &e
->where
;
13730 /* Shall not be an automatic array. */
13731 if (e
->ref
->type
== REF_ARRAY
13732 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13734 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13735 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13742 /* Shall not be a structure component. */
13743 if (r
->type
== REF_COMPONENT
)
13745 gfc_error ("Structure component '%s' at %L cannot be an "
13746 "EQUIVALENCE object",
13747 r
->u
.c
.component
->name
, &e
->where
);
13751 /* A substring shall not have length zero. */
13752 if (r
->type
== REF_SUBSTRING
)
13754 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13756 gfc_error ("Substring at %L has length zero",
13757 &r
->u
.ss
.start
->where
);
13767 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13770 resolve_fntype (gfc_namespace
*ns
)
13772 gfc_entry_list
*el
;
13775 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13778 /* If there are any entries, ns->proc_name is the entry master
13779 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13781 sym
= ns
->entries
->sym
;
13783 sym
= ns
->proc_name
;
13784 if (sym
->result
== sym
13785 && sym
->ts
.type
== BT_UNKNOWN
13786 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13787 && !sym
->attr
.untyped
)
13789 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13790 sym
->name
, &sym
->declared_at
);
13791 sym
->attr
.untyped
= 1;
13794 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13795 && !sym
->attr
.contained
13796 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13797 && gfc_check_symbol_access (sym
))
13799 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13800 "%L of PRIVATE type '%s'", sym
->name
,
13801 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13805 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13807 if (el
->sym
->result
== el
->sym
13808 && el
->sym
->ts
.type
== BT_UNKNOWN
13809 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13810 && !el
->sym
->attr
.untyped
)
13812 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13813 el
->sym
->name
, &el
->sym
->declared_at
);
13814 el
->sym
->attr
.untyped
= 1;
13820 /* 12.3.2.1.1 Defined operators. */
13823 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13825 gfc_formal_arglist
*formal
;
13827 if (!sym
->attr
.function
)
13829 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13830 sym
->name
, &where
);
13834 if (sym
->ts
.type
== BT_CHARACTER
13835 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13836 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13837 && sym
->result
->ts
.u
.cl
->length
))
13839 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13840 "character length", sym
->name
, &where
);
13844 formal
= sym
->formal
;
13845 if (!formal
|| !formal
->sym
)
13847 gfc_error ("User operator procedure '%s' at %L must have at least "
13848 "one argument", sym
->name
, &where
);
13852 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13854 gfc_error ("First argument of operator interface at %L must be "
13855 "INTENT(IN)", &where
);
13859 if (formal
->sym
->attr
.optional
)
13861 gfc_error ("First argument of operator interface at %L cannot be "
13862 "optional", &where
);
13866 formal
= formal
->next
;
13867 if (!formal
|| !formal
->sym
)
13870 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13872 gfc_error ("Second argument of operator interface at %L must be "
13873 "INTENT(IN)", &where
);
13877 if (formal
->sym
->attr
.optional
)
13879 gfc_error ("Second argument of operator interface at %L cannot be "
13880 "optional", &where
);
13886 gfc_error ("Operator interface at %L must have, at most, two "
13887 "arguments", &where
);
13895 gfc_resolve_uops (gfc_symtree
*symtree
)
13897 gfc_interface
*itr
;
13899 if (symtree
== NULL
)
13902 gfc_resolve_uops (symtree
->left
);
13903 gfc_resolve_uops (symtree
->right
);
13905 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13906 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13910 /* Examine all of the expressions associated with a program unit,
13911 assign types to all intermediate expressions, make sure that all
13912 assignments are to compatible types and figure out which names
13913 refer to which functions or subroutines. It doesn't check code
13914 block, which is handled by resolve_code. */
13917 resolve_types (gfc_namespace
*ns
)
13923 gfc_namespace
* old_ns
= gfc_current_ns
;
13925 /* Check that all IMPLICIT types are ok. */
13926 if (!ns
->seen_implicit_none
)
13929 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13930 if (ns
->set_flag
[letter
]
13931 && resolve_typespec_used (&ns
->default_type
[letter
],
13932 &ns
->implicit_loc
[letter
],
13937 gfc_current_ns
= ns
;
13939 resolve_entries (ns
);
13941 resolve_common_vars (ns
->blank_common
.head
, false);
13942 resolve_common_blocks (ns
->common_root
);
13944 resolve_contained_functions (ns
);
13946 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
13947 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
13948 resolve_formal_arglist (ns
->proc_name
);
13950 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13952 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13953 resolve_charlen (cl
);
13955 gfc_traverse_ns (ns
, resolve_symbol
);
13957 resolve_fntype (ns
);
13959 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13961 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13962 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13963 "also be PURE", n
->proc_name
->name
,
13964 &n
->proc_name
->declared_at
);
13970 do_concurrent_flag
= 0;
13971 gfc_check_interfaces (ns
);
13973 gfc_traverse_ns (ns
, resolve_values
);
13979 for (d
= ns
->data
; d
; d
= d
->next
)
13983 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13985 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13987 if (ns
->common_root
!= NULL
)
13988 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13990 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13991 resolve_equivalence (eq
);
13993 /* Warn about unused labels. */
13994 if (warn_unused_label
)
13995 warn_unused_fortran_label (ns
->st_labels
);
13997 gfc_resolve_uops (ns
->uop_root
);
13999 gfc_current_ns
= old_ns
;
14003 /* Call resolve_code recursively. */
14006 resolve_codes (gfc_namespace
*ns
)
14009 bitmap_obstack old_obstack
;
14011 if (ns
->resolved
== 1)
14014 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14017 gfc_current_ns
= ns
;
14019 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14020 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14023 /* Set to an out of range value. */
14024 current_entry_id
= -1;
14026 old_obstack
= labels_obstack
;
14027 bitmap_obstack_initialize (&labels_obstack
);
14029 resolve_code (ns
->code
, ns
);
14031 bitmap_obstack_release (&labels_obstack
);
14032 labels_obstack
= old_obstack
;
14036 /* This function is called after a complete program unit has been compiled.
14037 Its purpose is to examine all of the expressions associated with a program
14038 unit, assign types to all intermediate expressions, make sure that all
14039 assignments are to compatible types and figure out which names refer to
14040 which functions or subroutines. */
14043 gfc_resolve (gfc_namespace
*ns
)
14045 gfc_namespace
*old_ns
;
14046 code_stack
*old_cs_base
;
14052 old_ns
= gfc_current_ns
;
14053 old_cs_base
= cs_base
;
14055 resolve_types (ns
);
14056 resolve_codes (ns
);
14058 gfc_current_ns
= old_ns
;
14059 cs_base
= old_cs_base
;
14062 gfc_run_passes (ns
);