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 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
68 static int omp_workshare_flag
;
70 /* Nonzero if we are processing a formal arglist. The corresponding function
71 resets the flag each time that it is read. */
72 static int formal_arg_flag
= 0;
74 /* True if we are resolving a specification expression. */
75 static int specification_expr
= 0;
77 /* The id of the last entry seen. */
78 static int current_entry_id
;
80 /* We use bitmaps to determine if a branch target is valid. */
81 static bitmap_obstack labels_obstack
;
83 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
84 static bool inquiry_argument
= false;
87 gfc_is_formal_arg (void)
89 return formal_arg_flag
;
92 /* Is the symbol host associated? */
94 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
96 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
105 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
106 an ABSTRACT derived-type. If where is not NULL, an error message with that
107 locus is printed, optionally using name. */
110 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
112 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
117 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
118 name
, where
, ts
->u
.derived
->name
);
120 gfc_error ("ABSTRACT type '%s' used at %L",
121 ts
->u
.derived
->name
, where
);
131 static void resolve_symbol (gfc_symbol
*sym
);
132 static gfc_try
resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
);
135 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
138 resolve_procedure_interface (gfc_symbol
*sym
)
140 if (sym
->ts
.interface
== sym
)
142 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
143 sym
->name
, &sym
->declared_at
);
146 if (sym
->ts
.interface
->attr
.procedure
)
148 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
149 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
150 sym
->name
, &sym
->declared_at
);
154 /* Get the attributes from the interface (now resolved). */
155 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
157 gfc_symbol
*ifc
= sym
->ts
.interface
;
158 resolve_symbol (ifc
);
160 if (ifc
->attr
.intrinsic
)
161 resolve_intrinsic (ifc
, &ifc
->declared_at
);
165 sym
->ts
= ifc
->result
->ts
;
170 sym
->ts
.interface
= ifc
;
171 sym
->attr
.function
= ifc
->attr
.function
;
172 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
173 gfc_copy_formal_args (sym
, ifc
);
175 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
176 sym
->attr
.pointer
= ifc
->attr
.pointer
;
177 sym
->attr
.pure
= ifc
->attr
.pure
;
178 sym
->attr
.elemental
= ifc
->attr
.elemental
;
179 sym
->attr
.dimension
= ifc
->attr
.dimension
;
180 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
181 sym
->attr
.recursive
= ifc
->attr
.recursive
;
182 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
183 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
184 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
185 /* Copy array spec. */
186 sym
->as
= gfc_copy_array_spec (ifc
->as
);
190 for (i
= 0; i
< sym
->as
->rank
; i
++)
192 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
193 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
196 /* Copy char length. */
197 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
199 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
200 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
201 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
202 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
206 else if (sym
->ts
.interface
->name
[0] != '\0')
208 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
209 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
217 /* Resolve types of formal argument lists. These have to be done early so that
218 the formal argument lists of module procedures can be copied to the
219 containing module before the individual procedures are resolved
220 individually. We also resolve argument lists of procedures in interface
221 blocks because they are self-contained scoping units.
223 Since a dummy argument cannot be a non-dummy procedure, the only
224 resort left for untyped names are the IMPLICIT types. */
227 resolve_formal_arglist (gfc_symbol
*proc
)
229 gfc_formal_arglist
*f
;
233 if (proc
->result
!= NULL
)
238 if (gfc_elemental (proc
)
239 || sym
->attr
.pointer
|| sym
->attr
.allocatable
240 || (sym
->as
&& sym
->as
->rank
> 0))
242 proc
->attr
.always_explicit
= 1;
243 sym
->attr
.always_explicit
= 1;
248 for (f
= proc
->formal
; f
; f
= f
->next
)
254 /* Alternate return placeholder. */
255 if (gfc_elemental (proc
))
256 gfc_error ("Alternate return specifier in elemental subroutine "
257 "'%s' at %L is not allowed", proc
->name
,
259 if (proc
->attr
.function
)
260 gfc_error ("Alternate return specifier in function "
261 "'%s' at %L is not allowed", proc
->name
,
265 else if (sym
->attr
.procedure
&& sym
->ts
.interface
266 && sym
->attr
.if_source
!= IFSRC_DECL
)
267 resolve_procedure_interface (sym
);
269 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
270 resolve_formal_arglist (sym
);
272 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
274 if (gfc_pure (proc
) && !gfc_pure (sym
))
276 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
277 "also be PURE", sym
->name
, &sym
->declared_at
);
281 if (proc
->attr
.implicit_pure
&& !gfc_pure(sym
))
282 proc
->attr
.implicit_pure
= 0;
284 if (gfc_elemental (proc
))
286 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
287 "procedure", &sym
->declared_at
);
291 if (sym
->attr
.function
292 && sym
->ts
.type
== BT_UNKNOWN
293 && sym
->attr
.intrinsic
)
295 gfc_intrinsic_sym
*isym
;
296 isym
= gfc_find_function (sym
->name
);
297 if (isym
== NULL
|| !isym
->specific
)
299 gfc_error ("Unable to find a specific INTRINSIC procedure "
300 "for the reference '%s' at %L", sym
->name
,
309 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
310 && (!sym
->attr
.function
|| sym
->result
== sym
))
311 gfc_set_default_type (sym
, 1, sym
->ns
);
313 gfc_resolve_array_spec (sym
->as
, 0);
315 /* We can't tell if an array with dimension (:) is assumed or deferred
316 shape until we know if it has the pointer or allocatable attributes.
318 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
319 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
)
320 && sym
->attr
.flavor
!= FL_PROCEDURE
)
322 sym
->as
->type
= AS_ASSUMED_SHAPE
;
323 for (i
= 0; i
< sym
->as
->rank
; i
++)
324 sym
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
328 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
329 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
330 || sym
->attr
.optional
)
332 proc
->attr
.always_explicit
= 1;
334 proc
->result
->attr
.always_explicit
= 1;
337 /* If the flavor is unknown at this point, it has to be a variable.
338 A procedure specification would have already set the type. */
340 if (sym
->attr
.flavor
== FL_UNKNOWN
)
341 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
343 if (gfc_pure (proc
) && !sym
->attr
.pointer
344 && sym
->attr
.flavor
!= FL_PROCEDURE
)
346 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
349 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s' "
350 "of pure function '%s' at %L with VALUE "
351 "attribute but without INTENT(IN)", sym
->name
,
352 proc
->name
, &sym
->declared_at
);
354 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
355 "INTENT(IN) or VALUE", sym
->name
, proc
->name
,
359 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
362 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s' "
363 "of pure subroutine '%s' at %L with VALUE "
364 "attribute but without INTENT", sym
->name
,
365 proc
->name
, &sym
->declared_at
);
367 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
368 "have its INTENT specified or have the VALUE "
369 "attribute", sym
->name
, proc
->name
, &sym
->declared_at
);
373 if (proc
->attr
.implicit_pure
&& !sym
->attr
.pointer
374 && sym
->attr
.flavor
!= FL_PROCEDURE
)
376 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
377 proc
->attr
.implicit_pure
= 0;
379 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
380 proc
->attr
.implicit_pure
= 0;
383 if (gfc_elemental (proc
))
386 if (sym
->attr
.codimension
)
388 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
389 "procedure", sym
->name
, &sym
->declared_at
);
395 gfc_error ("Argument '%s' of elemental procedure at %L must "
396 "be scalar", sym
->name
, &sym
->declared_at
);
400 if (sym
->attr
.allocatable
)
402 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
403 "have the ALLOCATABLE attribute", sym
->name
,
408 if (sym
->attr
.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
)
469 resolve_formal_arglist (sym
);
473 /* Given a namespace, resolve all formal argument lists within the namespace.
477 resolve_formal_arglists (gfc_namespace
*ns
)
482 gfc_traverse_ns (ns
, find_arglists
);
487 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
491 /* If this namespace is not a function or an entry master function,
493 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
494 || sym
->attr
.entry_master
)
497 /* Try to find out of what the return type is. */
498 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
500 t
= gfc_set_default_type (sym
->result
, 0, ns
);
502 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
504 if (sym
->result
== sym
)
505 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
506 sym
->name
, &sym
->declared_at
);
507 else if (!sym
->result
->attr
.proc_pointer
)
508 gfc_error ("Result '%s' of contained function '%s' at %L has "
509 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
510 &sym
->result
->declared_at
);
511 sym
->result
->attr
.untyped
= 1;
515 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
516 type, lists the only ways a character length value of * can be used:
517 dummy arguments of procedures, named constants, and function results
518 in external functions. Internal function results and results of module
519 procedures are not on this list, ergo, not permitted. */
521 if (sym
->result
->ts
.type
== BT_CHARACTER
)
523 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
524 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
526 /* See if this is a module-procedure and adapt error message
529 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
530 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
532 gfc_error ("Character-valued %s '%s' at %L must not be"
534 module_proc
? _("module procedure")
535 : _("internal function"),
536 sym
->name
, &sym
->declared_at
);
542 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
543 introduce duplicates. */
546 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
548 gfc_formal_arglist
*f
, *new_arglist
;
551 for (; new_args
!= NULL
; new_args
= new_args
->next
)
553 new_sym
= new_args
->sym
;
554 /* See if this arg is already in the formal argument list. */
555 for (f
= proc
->formal
; f
; f
= f
->next
)
557 if (new_sym
== f
->sym
)
564 /* Add a new argument. Argument order is not important. */
565 new_arglist
= gfc_get_formal_arglist ();
566 new_arglist
->sym
= new_sym
;
567 new_arglist
->next
= proc
->formal
;
568 proc
->formal
= new_arglist
;
573 /* Flag the arguments that are not present in all entries. */
576 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
578 gfc_formal_arglist
*f
, *head
;
581 for (f
= proc
->formal
; f
; f
= f
->next
)
586 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
588 if (new_args
->sym
== f
->sym
)
595 f
->sym
->attr
.not_always_present
= 1;
600 /* Resolve alternate entry points. If a symbol has multiple entry points we
601 create a new master symbol for the main routine, and turn the existing
602 symbol into an entry point. */
605 resolve_entries (gfc_namespace
*ns
)
607 gfc_namespace
*old_ns
;
611 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
612 static int master_count
= 0;
614 if (ns
->proc_name
== NULL
)
617 /* No need to do anything if this procedure doesn't have alternate entry
622 /* We may already have resolved alternate entry points. */
623 if (ns
->proc_name
->attr
.entry_master
)
626 /* If this isn't a procedure something has gone horribly wrong. */
627 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
629 /* Remember the current namespace. */
630 old_ns
= gfc_current_ns
;
634 /* Add the main entry point to the list of entry points. */
635 el
= gfc_get_entry_list ();
636 el
->sym
= ns
->proc_name
;
638 el
->next
= ns
->entries
;
640 ns
->proc_name
->attr
.entry
= 1;
642 /* If it is a module function, it needs to be in the right namespace
643 so that gfc_get_fake_result_decl can gather up the results. The
644 need for this arose in get_proc_name, where these beasts were
645 left in their own namespace, to keep prior references linked to
646 the entry declaration.*/
647 if (ns
->proc_name
->attr
.function
648 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
651 /* Do the same for entries where the master is not a module
652 procedure. These are retained in the module namespace because
653 of the module procedure declaration. */
654 for (el
= el
->next
; el
; el
= el
->next
)
655 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
656 && el
->sym
->attr
.mod_proc
)
660 /* Add an entry statement for it. */
667 /* Create a new symbol for the master function. */
668 /* Give the internal function a unique name (within this file).
669 Also include the function name so the user has some hope of figuring
670 out what is going on. */
671 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
672 master_count
++, ns
->proc_name
->name
);
673 gfc_get_ha_symbol (name
, &proc
);
674 gcc_assert (proc
!= NULL
);
676 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
677 if (ns
->proc_name
->attr
.subroutine
)
678 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
682 gfc_typespec
*ts
, *fts
;
683 gfc_array_spec
*as
, *fas
;
684 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
686 fas
= ns
->entries
->sym
->as
;
687 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
688 fts
= &ns
->entries
->sym
->result
->ts
;
689 if (fts
->type
== BT_UNKNOWN
)
690 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
691 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
693 ts
= &el
->sym
->result
->ts
;
695 as
= as
? as
: el
->sym
->result
->as
;
696 if (ts
->type
== BT_UNKNOWN
)
697 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
699 if (! gfc_compare_types (ts
, fts
)
700 || (el
->sym
->result
->attr
.dimension
701 != ns
->entries
->sym
->result
->attr
.dimension
)
702 || (el
->sym
->result
->attr
.pointer
703 != ns
->entries
->sym
->result
->attr
.pointer
))
705 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
706 && gfc_compare_array_spec (as
, fas
) == 0)
707 gfc_error ("Function %s at %L has entries with mismatched "
708 "array specifications", ns
->entries
->sym
->name
,
709 &ns
->entries
->sym
->declared_at
);
710 /* The characteristics need to match and thus both need to have
711 the same string length, i.e. both len=*, or both len=4.
712 Having both len=<variable> is also possible, but difficult to
713 check at compile time. */
714 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
715 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
716 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
718 && ts
->u
.cl
->length
->expr_type
719 != fts
->u
.cl
->length
->expr_type
)
721 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
722 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
723 fts
->u
.cl
->length
->value
.integer
) != 0)))
724 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
725 "entries returning variables of different "
726 "string lengths", ns
->entries
->sym
->name
,
727 &ns
->entries
->sym
->declared_at
);
732 sym
= ns
->entries
->sym
->result
;
733 /* All result types the same. */
735 if (sym
->attr
.dimension
)
736 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
737 if (sym
->attr
.pointer
)
738 gfc_add_pointer (&proc
->attr
, NULL
);
742 /* Otherwise the result will be passed through a union by
744 proc
->attr
.mixed_entry_master
= 1;
745 for (el
= ns
->entries
; el
; el
= el
->next
)
747 sym
= el
->sym
->result
;
748 if (sym
->attr
.dimension
)
750 if (el
== ns
->entries
)
751 gfc_error ("FUNCTION result %s can't be an array in "
752 "FUNCTION %s at %L", sym
->name
,
753 ns
->entries
->sym
->name
, &sym
->declared_at
);
755 gfc_error ("ENTRY result %s can't be an array in "
756 "FUNCTION %s at %L", sym
->name
,
757 ns
->entries
->sym
->name
, &sym
->declared_at
);
759 else if (sym
->attr
.pointer
)
761 if (el
== ns
->entries
)
762 gfc_error ("FUNCTION result %s can't be a POINTER in "
763 "FUNCTION %s at %L", sym
->name
,
764 ns
->entries
->sym
->name
, &sym
->declared_at
);
766 gfc_error ("ENTRY result %s can't be a POINTER in "
767 "FUNCTION %s at %L", sym
->name
,
768 ns
->entries
->sym
->name
, &sym
->declared_at
);
773 if (ts
->type
== BT_UNKNOWN
)
774 ts
= gfc_get_default_type (sym
->name
, NULL
);
778 if (ts
->kind
== gfc_default_integer_kind
)
782 if (ts
->kind
== gfc_default_real_kind
783 || ts
->kind
== gfc_default_double_kind
)
787 if (ts
->kind
== gfc_default_complex_kind
)
791 if (ts
->kind
== gfc_default_logical_kind
)
795 /* We will issue error elsewhere. */
803 if (el
== ns
->entries
)
804 gfc_error ("FUNCTION result %s can't be of type %s "
805 "in FUNCTION %s at %L", sym
->name
,
806 gfc_typename (ts
), ns
->entries
->sym
->name
,
809 gfc_error ("ENTRY result %s can't be of type %s "
810 "in FUNCTION %s at %L", sym
->name
,
811 gfc_typename (ts
), ns
->entries
->sym
->name
,
818 proc
->attr
.access
= ACCESS_PRIVATE
;
819 proc
->attr
.entry_master
= 1;
821 /* Merge all the entry point arguments. */
822 for (el
= ns
->entries
; el
; el
= el
->next
)
823 merge_argument_lists (proc
, el
->sym
->formal
);
825 /* Check the master formal arguments for any that are not
826 present in all entry points. */
827 for (el
= ns
->entries
; el
; el
= el
->next
)
828 check_argument_lists (proc
, el
->sym
->formal
);
830 /* Use the master function for the function body. */
831 ns
->proc_name
= proc
;
833 /* Finalize the new symbols. */
834 gfc_commit_symbols ();
836 /* Restore the original namespace. */
837 gfc_current_ns
= old_ns
;
841 /* Resolve common variables. */
843 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
845 gfc_symbol
*csym
= sym
;
847 for (; csym
; csym
= csym
->common_next
)
849 if (csym
->value
|| csym
->attr
.data
)
851 if (!csym
->ns
->is_block_data
)
852 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
853 "but only in BLOCK DATA initialization is "
854 "allowed", csym
->name
, &csym
->declared_at
);
855 else if (!named_common
)
856 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
857 "in a blank COMMON but initialization is only "
858 "allowed in named common blocks", csym
->name
,
862 if (csym
->ts
.type
!= BT_DERIVED
)
865 if (!(csym
->ts
.u
.derived
->attr
.sequence
866 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
867 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
868 "has neither the SEQUENCE nor the BIND(C) "
869 "attribute", csym
->name
, &csym
->declared_at
);
870 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
871 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
872 "has an ultimate component that is "
873 "allocatable", csym
->name
, &csym
->declared_at
);
874 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
875 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
876 "may not have default initializer", csym
->name
,
879 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
880 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
884 /* Resolve common blocks. */
886 resolve_common_blocks (gfc_symtree
*common_root
)
890 if (common_root
== NULL
)
893 if (common_root
->left
)
894 resolve_common_blocks (common_root
->left
);
895 if (common_root
->right
)
896 resolve_common_blocks (common_root
->right
);
898 resolve_common_vars (common_root
->n
.common
->head
, true);
900 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
904 if (sym
->attr
.flavor
== FL_PARAMETER
)
905 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
906 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
908 if (sym
->attr
.intrinsic
)
909 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
910 sym
->name
, &common_root
->n
.common
->where
);
911 else if (sym
->attr
.result
912 || gfc_is_function_return_value (sym
, gfc_current_ns
))
913 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
914 "that is also a function result", sym
->name
,
915 &common_root
->n
.common
->where
);
916 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
917 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
918 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
919 "that is also a global procedure", sym
->name
,
920 &common_root
->n
.common
->where
);
924 /* Resolve contained function types. Because contained functions can call one
925 another, they have to be worked out before any of the contained procedures
928 The good news is that if a function doesn't already have a type, the only
929 way it can get one is through an IMPLICIT type or a RESULT variable, because
930 by definition contained functions are contained namespace they're contained
931 in, not in a sibling or parent namespace. */
934 resolve_contained_functions (gfc_namespace
*ns
)
936 gfc_namespace
*child
;
939 resolve_formal_arglists (ns
);
941 for (child
= ns
->contained
; child
; child
= child
->sibling
)
943 /* Resolve alternate entry points first. */
944 resolve_entries (child
);
946 /* Then check function return types. */
947 resolve_contained_fntype (child
->proc_name
, child
);
948 for (el
= child
->entries
; el
; el
= el
->next
)
949 resolve_contained_fntype (el
->sym
, child
);
954 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
957 /* Resolve all of the elements of a structure constructor and make sure that
958 the types are correct. The 'init' flag indicates that the given
959 constructor is an initializer. */
962 resolve_structure_cons (gfc_expr
*expr
, int init
)
964 gfc_constructor
*cons
;
971 if (expr
->ts
.type
== BT_DERIVED
)
972 resolve_fl_derived0 (expr
->ts
.u
.derived
);
974 cons
= gfc_constructor_first (expr
->value
.constructor
);
975 /* A constructor may have references if it is the result of substituting a
976 parameter variable. In this case we just pull out the component we
979 comp
= expr
->ref
->u
.c
.sym
->components
;
981 comp
= expr
->ts
.u
.derived
->components
;
983 /* See if the user is trying to invoke a structure constructor for one of
984 the iso_c_binding derived types. */
985 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
986 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
987 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
989 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
990 expr
->ts
.u
.derived
->name
, &(expr
->where
));
994 /* Return if structure constructor is c_null_(fun)prt. */
995 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
996 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
997 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
1000 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1007 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1013 rank
= comp
->as
? comp
->as
->rank
: 0;
1014 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1015 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1017 gfc_error ("The rank of the element in the structure "
1018 "constructor at %L does not match that of the "
1019 "component (%d/%d)", &cons
->expr
->where
,
1020 cons
->expr
->rank
, rank
);
1024 /* If we don't have the right type, try to convert it. */
1026 if (!comp
->attr
.proc_pointer
&&
1027 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1030 if (strcmp (comp
->name
, "_extends") == 0)
1032 /* Can afford to be brutal with the _extends initializer.
1033 The derived type can get lost because it is PRIVATE
1034 but it is not usage constrained by the standard. */
1035 cons
->expr
->ts
= comp
->ts
;
1038 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1039 gfc_error ("The element in the structure constructor at %L, "
1040 "for pointer component '%s', is %s but should be %s",
1041 &cons
->expr
->where
, comp
->name
,
1042 gfc_basic_typename (cons
->expr
->ts
.type
),
1043 gfc_basic_typename (comp
->ts
.type
));
1045 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1048 /* For strings, the length of the constructor should be the same as
1049 the one of the structure, ensure this if the lengths are known at
1050 compile time and when we are dealing with PARAMETER or structure
1052 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1053 && comp
->ts
.u
.cl
->length
1054 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1055 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1056 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1057 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1058 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1060 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1061 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1063 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1064 to make use of the gfc_resolve_character_array_constructor
1065 machinery. The expression is later simplified away to
1066 an array of string literals. */
1067 gfc_expr
*para
= cons
->expr
;
1068 cons
->expr
= gfc_get_expr ();
1069 cons
->expr
->ts
= para
->ts
;
1070 cons
->expr
->where
= para
->where
;
1071 cons
->expr
->expr_type
= EXPR_ARRAY
;
1072 cons
->expr
->rank
= para
->rank
;
1073 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1074 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1075 para
, &cons
->expr
->where
);
1077 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1080 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1081 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1083 gfc_charlen
*cl
, *cl2
;
1086 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1088 if (cl
== cons
->expr
->ts
.u
.cl
)
1096 cl2
->next
= cl
->next
;
1098 gfc_free_expr (cl
->length
);
1102 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1103 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1104 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1105 gfc_resolve_character_array_constructor (cons
->expr
);
1109 if (cons
->expr
->expr_type
== EXPR_NULL
1110 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1111 || comp
->attr
.proc_pointer
1112 || (comp
->ts
.type
== BT_CLASS
1113 && (CLASS_DATA (comp
)->attr
.class_pointer
1114 || CLASS_DATA (comp
)->attr
.allocatable
))))
1117 gfc_error ("The NULL in the structure constructor at %L is "
1118 "being applied to component '%s', which is neither "
1119 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1123 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1125 /* Check procedure pointer interface. */
1126 gfc_symbol
*s2
= NULL
;
1131 if (gfc_is_proc_ptr_comp (cons
->expr
, &c2
))
1133 s2
= c2
->ts
.interface
;
1136 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1138 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1139 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1141 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1143 s2
= cons
->expr
->symtree
->n
.sym
;
1144 name
= cons
->expr
->symtree
->n
.sym
->name
;
1147 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1150 gfc_error ("Interface mismatch for procedure-pointer component "
1151 "'%s' in structure constructor at %L: %s",
1152 comp
->name
, &cons
->expr
->where
, err
);
1157 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1158 || cons
->expr
->expr_type
== EXPR_NULL
)
1161 a
= gfc_expr_attr (cons
->expr
);
1163 if (!a
.pointer
&& !a
.target
)
1166 gfc_error ("The element in the structure constructor at %L, "
1167 "for pointer component '%s' should be a POINTER or "
1168 "a TARGET", &cons
->expr
->where
, comp
->name
);
1173 /* F08:C461. Additional checks for pointer initialization. */
1177 gfc_error ("Pointer initialization target at %L "
1178 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1183 gfc_error ("Pointer initialization target at %L "
1184 "must have the SAVE attribute", &cons
->expr
->where
);
1188 /* F2003, C1272 (3). */
1189 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1190 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1191 || gfc_is_coindexed (cons
->expr
)))
1194 gfc_error ("Invalid expression in the structure constructor for "
1195 "pointer component '%s' at %L in PURE procedure",
1196 comp
->name
, &cons
->expr
->where
);
1199 if (gfc_implicit_pure (NULL
)
1200 && cons
->expr
->expr_type
== EXPR_VARIABLE
1201 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1202 || gfc_is_coindexed (cons
->expr
)))
1203 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1211 /****************** Expression name resolution ******************/
1213 /* Returns 0 if a symbol was not declared with a type or
1214 attribute declaration statement, nonzero otherwise. */
1217 was_declared (gfc_symbol
*sym
)
1223 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1226 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1227 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1228 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1229 || a
.asynchronous
|| a
.codimension
)
1236 /* Determine if a symbol is generic or not. */
1239 generic_sym (gfc_symbol
*sym
)
1243 if (sym
->attr
.generic
||
1244 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1247 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1250 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1257 return generic_sym (s
);
1264 /* Determine if a symbol is specific or not. */
1267 specific_sym (gfc_symbol
*sym
)
1271 if (sym
->attr
.if_source
== IFSRC_IFBODY
1272 || sym
->attr
.proc
== PROC_MODULE
1273 || sym
->attr
.proc
== PROC_INTERNAL
1274 || sym
->attr
.proc
== PROC_ST_FUNCTION
1275 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1276 || sym
->attr
.external
)
1279 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1282 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1284 return (s
== NULL
) ? 0 : specific_sym (s
);
1288 /* Figure out if the procedure is specific, generic or unknown. */
1291 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1295 procedure_kind (gfc_symbol
*sym
)
1297 if (generic_sym (sym
))
1298 return PTYPE_GENERIC
;
1300 if (specific_sym (sym
))
1301 return PTYPE_SPECIFIC
;
1303 return PTYPE_UNKNOWN
;
1306 /* Check references to assumed size arrays. The flag need_full_assumed_size
1307 is nonzero when matching actual arguments. */
1309 static int need_full_assumed_size
= 0;
1312 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1314 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1317 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1318 What should it be? */
1319 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1320 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1321 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1323 gfc_error ("The upper bound in the last dimension must "
1324 "appear in the reference to the assumed size "
1325 "array '%s' at %L", sym
->name
, &e
->where
);
1332 /* Look for bad assumed size array references in argument expressions
1333 of elemental and array valued intrinsic procedures. Since this is
1334 called from procedure resolution functions, it only recurses at
1338 resolve_assumed_size_actual (gfc_expr
*e
)
1343 switch (e
->expr_type
)
1346 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1351 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1352 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1363 /* Check a generic procedure, passed as an actual argument, to see if
1364 there is a matching specific name. If none, it is an error, and if
1365 more than one, the reference is ambiguous. */
1367 count_specific_procs (gfc_expr
*e
)
1374 sym
= e
->symtree
->n
.sym
;
1376 for (p
= sym
->generic
; p
; p
= p
->next
)
1377 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1379 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1385 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1389 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1390 "argument at %L", sym
->name
, &e
->where
);
1396 /* See if a call to sym could possibly be a not allowed RECURSION because of
1397 a missing RECURIVE declaration. This means that either sym is the current
1398 context itself, or sym is the parent of a contained procedure calling its
1399 non-RECURSIVE containing procedure.
1400 This also works if sym is an ENTRY. */
1403 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1405 gfc_symbol
* proc_sym
;
1406 gfc_symbol
* context_proc
;
1407 gfc_namespace
* real_context
;
1409 if (sym
->attr
.flavor
== FL_PROGRAM
)
1412 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1414 /* If we've got an ENTRY, find real procedure. */
1415 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1416 proc_sym
= sym
->ns
->entries
->sym
;
1420 /* If sym is RECURSIVE, all is well of course. */
1421 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1424 /* Find the context procedure's "real" symbol if it has entries.
1425 We look for a procedure symbol, so recurse on the parents if we don't
1426 find one (like in case of a BLOCK construct). */
1427 for (real_context
= context
; ; real_context
= real_context
->parent
)
1429 /* We should find something, eventually! */
1430 gcc_assert (real_context
);
1432 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1433 : real_context
->proc_name
);
1435 /* In some special cases, there may not be a proc_name, like for this
1437 real(bad_kind()) function foo () ...
1438 when checking the call to bad_kind ().
1439 In these cases, we simply return here and assume that the
1444 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1448 /* A call from sym's body to itself is recursion, of course. */
1449 if (context_proc
== proc_sym
)
1452 /* The same is true if context is a contained procedure and sym the
1454 if (context_proc
->attr
.contained
)
1456 gfc_symbol
* parent_proc
;
1458 gcc_assert (context
->parent
);
1459 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1460 : context
->parent
->proc_name
);
1462 if (parent_proc
== proc_sym
)
1470 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1471 its typespec and formal argument list. */
1474 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1476 gfc_intrinsic_sym
* isym
= NULL
;
1482 /* Already resolved. */
1483 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1486 /* We already know this one is an intrinsic, so we don't call
1487 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1488 gfc_find_subroutine directly to check whether it is a function or
1491 if (sym
->intmod_sym_id
)
1492 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1494 isym
= gfc_find_function (sym
->name
);
1498 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1499 && !sym
->attr
.implicit_type
)
1500 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1501 " ignored", sym
->name
, &sym
->declared_at
);
1503 if (!sym
->attr
.function
&&
1504 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1509 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1511 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1513 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1514 " specifier", sym
->name
, &sym
->declared_at
);
1518 if (!sym
->attr
.subroutine
&&
1519 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1524 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1529 gfc_copy_formal_args_intr (sym
, isym
);
1531 /* Check it is actually available in the standard settings. */
1532 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1535 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1536 " available in the current standard settings but %s. Use"
1537 " an appropriate -std=* option or enable -fall-intrinsics"
1538 " in order to use it.",
1539 sym
->name
, &sym
->declared_at
, symstd
);
1547 /* Resolve a procedure expression, like passing it to a called procedure or as
1548 RHS for a procedure pointer assignment. */
1551 resolve_procedure_expression (gfc_expr
* expr
)
1555 if (expr
->expr_type
!= EXPR_VARIABLE
)
1557 gcc_assert (expr
->symtree
);
1559 sym
= expr
->symtree
->n
.sym
;
1561 if (sym
->attr
.intrinsic
)
1562 resolve_intrinsic (sym
, &expr
->where
);
1564 if (sym
->attr
.flavor
!= FL_PROCEDURE
1565 || (sym
->attr
.function
&& sym
->result
== sym
))
1568 /* A non-RECURSIVE procedure that is used as procedure expression within its
1569 own body is in danger of being called recursively. */
1570 if (is_illegal_recursion (sym
, gfc_current_ns
))
1571 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1572 " itself recursively. Declare it RECURSIVE or use"
1573 " -frecursive", sym
->name
, &expr
->where
);
1579 /* Resolve an actual argument list. Most of the time, this is just
1580 resolving the expressions in the list.
1581 The exception is that we sometimes have to decide whether arguments
1582 that look like procedure arguments are really simple variable
1586 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1587 bool no_formal_args
)
1590 gfc_symtree
*parent_st
;
1592 int save_need_full_assumed_size
;
1594 for (; arg
; arg
= arg
->next
)
1599 /* Check the label is a valid branching target. */
1602 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1604 gfc_error ("Label %d referenced at %L is never defined",
1605 arg
->label
->value
, &arg
->label
->where
);
1612 if (e
->expr_type
== EXPR_VARIABLE
1613 && e
->symtree
->n
.sym
->attr
.generic
1615 && count_specific_procs (e
) != 1)
1618 if (e
->ts
.type
!= BT_PROCEDURE
)
1620 save_need_full_assumed_size
= need_full_assumed_size
;
1621 if (e
->expr_type
!= EXPR_VARIABLE
)
1622 need_full_assumed_size
= 0;
1623 if (gfc_resolve_expr (e
) != SUCCESS
)
1625 need_full_assumed_size
= save_need_full_assumed_size
;
1629 /* See if the expression node should really be a variable reference. */
1631 sym
= e
->symtree
->n
.sym
;
1633 if (sym
->attr
.flavor
== FL_PROCEDURE
1634 || sym
->attr
.intrinsic
1635 || sym
->attr
.external
)
1639 /* If a procedure is not already determined to be something else
1640 check if it is intrinsic. */
1641 if (!sym
->attr
.intrinsic
1642 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1643 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1644 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1645 sym
->attr
.intrinsic
= 1;
1647 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1649 gfc_error ("Statement function '%s' at %L is not allowed as an "
1650 "actual argument", sym
->name
, &e
->where
);
1653 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1654 sym
->attr
.subroutine
);
1655 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1657 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1658 "actual argument", sym
->name
, &e
->where
);
1661 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1662 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1664 if (gfc_notify_std (GFC_STD_F2008
,
1665 "Fortran 2008: Internal procedure '%s' is"
1666 " used as actual argument at %L",
1667 sym
->name
, &e
->where
) == FAILURE
)
1671 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1673 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1674 "allowed as an actual argument at %L", sym
->name
,
1678 /* Check if a generic interface has a specific procedure
1679 with the same name before emitting an error. */
1680 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1683 /* Just in case a specific was found for the expression. */
1684 sym
= e
->symtree
->n
.sym
;
1686 /* If the symbol is the function that names the current (or
1687 parent) scope, then we really have a variable reference. */
1689 if (gfc_is_function_return_value (sym
, sym
->ns
))
1692 /* If all else fails, see if we have a specific intrinsic. */
1693 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1695 gfc_intrinsic_sym
*isym
;
1697 isym
= gfc_find_function (sym
->name
);
1698 if (isym
== NULL
|| !isym
->specific
)
1700 gfc_error ("Unable to find a specific INTRINSIC procedure "
1701 "for the reference '%s' at %L", sym
->name
,
1706 sym
->attr
.intrinsic
= 1;
1707 sym
->attr
.function
= 1;
1710 if (gfc_resolve_expr (e
) == FAILURE
)
1715 /* See if the name is a module procedure in a parent unit. */
1717 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1720 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1722 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1726 if (parent_st
== NULL
)
1729 sym
= parent_st
->n
.sym
;
1730 e
->symtree
= parent_st
; /* Point to the right thing. */
1732 if (sym
->attr
.flavor
== FL_PROCEDURE
1733 || sym
->attr
.intrinsic
1734 || sym
->attr
.external
)
1736 if (gfc_resolve_expr (e
) == FAILURE
)
1742 e
->expr_type
= EXPR_VARIABLE
;
1744 if (sym
->as
!= NULL
)
1746 e
->rank
= sym
->as
->rank
;
1747 e
->ref
= gfc_get_ref ();
1748 e
->ref
->type
= REF_ARRAY
;
1749 e
->ref
->u
.ar
.type
= AR_FULL
;
1750 e
->ref
->u
.ar
.as
= sym
->as
;
1753 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1754 primary.c (match_actual_arg). If above code determines that it
1755 is a variable instead, it needs to be resolved as it was not
1756 done at the beginning of this function. */
1757 save_need_full_assumed_size
= need_full_assumed_size
;
1758 if (e
->expr_type
!= EXPR_VARIABLE
)
1759 need_full_assumed_size
= 0;
1760 if (gfc_resolve_expr (e
) != SUCCESS
)
1762 need_full_assumed_size
= save_need_full_assumed_size
;
1765 /* Check argument list functions %VAL, %LOC and %REF. There is
1766 nothing to do for %REF. */
1767 if (arg
->name
&& arg
->name
[0] == '%')
1769 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1771 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1773 gfc_error ("By-value argument at %L is not of numeric "
1780 gfc_error ("By-value argument at %L cannot be an array or "
1781 "an array section", &e
->where
);
1785 /* Intrinsics are still PROC_UNKNOWN here. However,
1786 since same file external procedures are not resolvable
1787 in gfortran, it is a good deal easier to leave them to
1789 if (ptype
!= PROC_UNKNOWN
1790 && ptype
!= PROC_DUMMY
1791 && ptype
!= PROC_EXTERNAL
1792 && ptype
!= PROC_MODULE
)
1794 gfc_error ("By-value argument at %L is not allowed "
1795 "in this context", &e
->where
);
1800 /* Statement functions have already been excluded above. */
1801 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1802 && e
->ts
.type
== BT_PROCEDURE
)
1804 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1806 gfc_error ("Passing internal procedure at %L by location "
1807 "not allowed", &e
->where
);
1813 /* Fortran 2008, C1237. */
1814 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1815 && gfc_has_ultimate_pointer (e
))
1817 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1818 "component", &e
->where
);
1827 /* Do the checks of the actual argument list that are specific to elemental
1828 procedures. If called with c == NULL, we have a function, otherwise if
1829 expr == NULL, we have a subroutine. */
1832 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1834 gfc_actual_arglist
*arg0
;
1835 gfc_actual_arglist
*arg
;
1836 gfc_symbol
*esym
= NULL
;
1837 gfc_intrinsic_sym
*isym
= NULL
;
1839 gfc_intrinsic_arg
*iformal
= NULL
;
1840 gfc_formal_arglist
*eformal
= NULL
;
1841 bool formal_optional
= false;
1842 bool set_by_optional
= false;
1846 /* Is this an elemental procedure? */
1847 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1849 if (expr
->value
.function
.esym
!= NULL
1850 && expr
->value
.function
.esym
->attr
.elemental
)
1852 arg0
= expr
->value
.function
.actual
;
1853 esym
= expr
->value
.function
.esym
;
1855 else if (expr
->value
.function
.isym
!= NULL
1856 && expr
->value
.function
.isym
->elemental
)
1858 arg0
= expr
->value
.function
.actual
;
1859 isym
= expr
->value
.function
.isym
;
1864 else if (c
&& c
->ext
.actual
!= NULL
)
1866 arg0
= c
->ext
.actual
;
1868 if (c
->resolved_sym
)
1869 esym
= c
->resolved_sym
;
1871 esym
= c
->symtree
->n
.sym
;
1874 if (!esym
->attr
.elemental
)
1880 /* The rank of an elemental is the rank of its array argument(s). */
1881 for (arg
= arg0
; arg
; arg
= arg
->next
)
1883 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1885 rank
= arg
->expr
->rank
;
1886 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1887 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1888 set_by_optional
= true;
1890 /* Function specific; set the result rank and shape. */
1894 if (!expr
->shape
&& arg
->expr
->shape
)
1896 expr
->shape
= gfc_get_shape (rank
);
1897 for (i
= 0; i
< rank
; i
++)
1898 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1905 /* If it is an array, it shall not be supplied as an actual argument
1906 to an elemental procedure unless an array of the same rank is supplied
1907 as an actual argument corresponding to a nonoptional dummy argument of
1908 that elemental procedure(12.4.1.5). */
1909 formal_optional
= false;
1911 iformal
= isym
->formal
;
1913 eformal
= esym
->formal
;
1915 for (arg
= arg0
; arg
; arg
= arg
->next
)
1919 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1920 formal_optional
= true;
1921 eformal
= eformal
->next
;
1923 else if (isym
&& iformal
)
1925 if (iformal
->optional
)
1926 formal_optional
= true;
1927 iformal
= iformal
->next
;
1930 formal_optional
= true;
1932 if (pedantic
&& arg
->expr
!= NULL
1933 && arg
->expr
->expr_type
== EXPR_VARIABLE
1934 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1937 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1938 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1940 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1941 "MISSING, it cannot be the actual argument of an "
1942 "ELEMENTAL procedure unless there is a non-optional "
1943 "argument with the same rank (12.4.1.5)",
1944 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1949 for (arg
= arg0
; arg
; arg
= arg
->next
)
1951 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1954 /* Being elemental, the last upper bound of an assumed size array
1955 argument must be present. */
1956 if (resolve_assumed_size_actual (arg
->expr
))
1959 /* Elemental procedure's array actual arguments must conform. */
1962 if (gfc_check_conformance (arg
->expr
, e
,
1963 "elemental procedure") == FAILURE
)
1970 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1971 is an array, the intent inout/out variable needs to be also an array. */
1972 if (rank
> 0 && esym
&& expr
== NULL
)
1973 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1974 arg
= arg
->next
, eformal
= eformal
->next
)
1975 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1976 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1977 && arg
->expr
&& arg
->expr
->rank
== 0)
1979 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1980 "ELEMENTAL subroutine '%s' is a scalar, but another "
1981 "actual argument is an array", &arg
->expr
->where
,
1982 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1983 : "INOUT", eformal
->sym
->name
, esym
->name
);
1990 /* This function does the checking of references to global procedures
1991 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1992 77 and 95 standards. It checks for a gsymbol for the name, making
1993 one if it does not already exist. If it already exists, then the
1994 reference being resolved must correspond to the type of gsymbol.
1995 Otherwise, the new symbol is equipped with the attributes of the
1996 reference. The corresponding code that is called in creating
1997 global entities is parse.c.
1999 In addition, for all but -std=legacy, the gsymbols are used to
2000 check the interfaces of external procedures from the same file.
2001 The namespace of the gsymbol is resolved and then, once this is
2002 done the interface is checked. */
2006 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2008 if (!gsym_ns
->proc_name
->attr
.recursive
)
2011 if (sym
->ns
== gsym_ns
)
2014 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2021 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2023 if (gsym_ns
->entries
)
2025 gfc_entry_list
*entry
= gsym_ns
->entries
;
2027 for (; entry
; entry
= entry
->next
)
2029 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2031 if (strcmp (gsym_ns
->proc_name
->name
,
2032 sym
->ns
->proc_name
->name
) == 0)
2036 && strcmp (gsym_ns
->proc_name
->name
,
2037 sym
->ns
->parent
->proc_name
->name
) == 0)
2046 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2047 gfc_actual_arglist
**actual
, int sub
)
2051 enum gfc_symbol_type type
;
2053 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2055 gsym
= gfc_get_gsymbol (sym
->name
);
2057 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2058 gfc_global_used (gsym
, where
);
2060 if (gfc_option
.flag_whole_file
2061 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2062 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2063 && gsym
->type
!= GSYM_UNKNOWN
2065 && gsym
->ns
->resolved
!= -1
2066 && gsym
->ns
->proc_name
2067 && not_in_recursive (sym
, gsym
->ns
)
2068 && not_entry_self_reference (sym
, gsym
->ns
))
2070 gfc_symbol
*def_sym
;
2072 /* Resolve the gsymbol namespace if needed. */
2073 if (!gsym
->ns
->resolved
)
2075 gfc_dt_list
*old_dt_list
;
2076 struct gfc_omp_saved_state old_omp_state
;
2078 /* Stash away derived types so that the backend_decls do not
2080 old_dt_list
= gfc_derived_types
;
2081 gfc_derived_types
= NULL
;
2082 /* And stash away openmp state. */
2083 gfc_omp_save_and_clear_state (&old_omp_state
);
2085 gfc_resolve (gsym
->ns
);
2087 /* Store the new derived types with the global namespace. */
2088 if (gfc_derived_types
)
2089 gsym
->ns
->derived_types
= gfc_derived_types
;
2091 /* Restore the derived types of this namespace. */
2092 gfc_derived_types
= old_dt_list
;
2093 /* And openmp state. */
2094 gfc_omp_restore_state (&old_omp_state
);
2097 /* Make sure that translation for the gsymbol occurs before
2098 the procedure currently being resolved. */
2099 ns
= gfc_global_ns_list
;
2100 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2102 if (ns
->sibling
== gsym
->ns
)
2104 ns
->sibling
= gsym
->ns
->sibling
;
2105 gsym
->ns
->sibling
= gfc_global_ns_list
;
2106 gfc_global_ns_list
= gsym
->ns
;
2111 def_sym
= gsym
->ns
->proc_name
;
2112 if (def_sym
->attr
.entry_master
)
2114 gfc_entry_list
*entry
;
2115 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2116 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2118 def_sym
= entry
->sym
;
2123 /* Differences in constant character lengths. */
2124 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2126 long int l1
= 0, l2
= 0;
2127 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2128 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2131 && cl1
->length
!= NULL
2132 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2133 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2136 && cl2
->length
!= NULL
2137 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2138 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2140 if (l1
&& l2
&& l1
!= l2
)
2141 gfc_error ("Character length mismatch in return type of "
2142 "function '%s' at %L (%ld/%ld)", sym
->name
,
2143 &sym
->declared_at
, l1
, l2
);
2146 /* Type mismatch of function return type and expected type. */
2147 if (sym
->attr
.function
2148 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2149 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2150 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2151 gfc_typename (&def_sym
->ts
));
2153 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2155 gfc_formal_arglist
*arg
= def_sym
->formal
;
2156 for ( ; arg
; arg
= arg
->next
)
2159 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2160 else if (arg
->sym
->attr
.allocatable
2161 || arg
->sym
->attr
.asynchronous
2162 || arg
->sym
->attr
.optional
2163 || arg
->sym
->attr
.pointer
2164 || arg
->sym
->attr
.target
2165 || arg
->sym
->attr
.value
2166 || arg
->sym
->attr
.volatile_
)
2168 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2169 "has an attribute that requires an explicit "
2170 "interface for this procedure", arg
->sym
->name
,
2171 sym
->name
, &sym
->declared_at
);
2174 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2175 else if (arg
->sym
&& arg
->sym
->as
2176 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2178 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2179 "argument '%s' must have an explicit interface",
2180 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2183 /* F2008, 12.4.2.2 (2c) */
2184 else if (arg
->sym
->attr
.codimension
)
2186 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2187 "'%s' must have an explicit interface",
2188 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2191 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2192 else if (false) /* TODO: is a parametrized derived type */
2194 gfc_error ("Procedure '%s' at %L with parametrized derived "
2195 "type argument '%s' must have an explicit "
2196 "interface", sym
->name
, &sym
->declared_at
,
2200 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2201 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2203 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2204 "argument '%s' must have an explicit interface",
2205 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2210 if (def_sym
->attr
.function
)
2212 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2213 if (def_sym
->as
&& def_sym
->as
->rank
2214 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2215 gfc_error ("The reference to function '%s' at %L either needs an "
2216 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2219 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2220 if ((def_sym
->result
->attr
.pointer
2221 || def_sym
->result
->attr
.allocatable
)
2222 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2223 || def_sym
->result
->attr
.pointer
2224 != sym
->result
->attr
.pointer
2225 || def_sym
->result
->attr
.allocatable
2226 != sym
->result
->attr
.allocatable
))
2227 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2228 "result must have an explicit interface", sym
->name
,
2231 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2232 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2233 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2235 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2237 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2238 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2240 gfc_error ("Nonconstant character-length function '%s' at %L "
2241 "must have an explicit interface", sym
->name
,
2247 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2248 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2250 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2251 "interface", sym
->name
, &sym
->declared_at
);
2254 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2255 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2257 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2258 "an explicit interface", sym
->name
, &sym
->declared_at
);
2261 if (gfc_option
.flag_whole_file
== 1
2262 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2263 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2264 gfc_errors_to_warnings (1);
2266 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2267 gfc_procedure_use (def_sym
, actual
, where
);
2269 gfc_errors_to_warnings (0);
2272 if (gsym
->type
== GSYM_UNKNOWN
)
2275 gsym
->where
= *where
;
2282 /************* Function resolution *************/
2284 /* Resolve a function call known to be generic.
2285 Section 14.1.2.4.1. */
2288 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2292 if (sym
->attr
.generic
)
2294 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2297 expr
->value
.function
.name
= s
->name
;
2298 expr
->value
.function
.esym
= s
;
2300 if (s
->ts
.type
!= BT_UNKNOWN
)
2302 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2303 expr
->ts
= s
->result
->ts
;
2306 expr
->rank
= s
->as
->rank
;
2307 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2308 expr
->rank
= s
->result
->as
->rank
;
2310 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2315 /* TODO: Need to search for elemental references in generic
2319 if (sym
->attr
.intrinsic
)
2320 return gfc_intrinsic_func_interface (expr
, 0);
2327 resolve_generic_f (gfc_expr
*expr
)
2332 sym
= expr
->symtree
->n
.sym
;
2336 m
= resolve_generic_f0 (expr
, sym
);
2339 else if (m
== MATCH_ERROR
)
2343 if (sym
->ns
->parent
== NULL
)
2345 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2349 if (!generic_sym (sym
))
2353 /* Last ditch attempt. See if the reference is to an intrinsic
2354 that possesses a matching interface. 14.1.2.4 */
2355 if (sym
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2357 gfc_error ("There is no specific function for the generic '%s' at %L",
2358 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2362 m
= gfc_intrinsic_func_interface (expr
, 0);
2366 gfc_error ("Generic function '%s' at %L is not consistent with a "
2367 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2374 /* Resolve a function call known to be specific. */
2377 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2381 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2383 if (sym
->attr
.dummy
)
2385 sym
->attr
.proc
= PROC_DUMMY
;
2389 sym
->attr
.proc
= PROC_EXTERNAL
;
2393 if (sym
->attr
.proc
== PROC_MODULE
2394 || sym
->attr
.proc
== PROC_ST_FUNCTION
2395 || sym
->attr
.proc
== PROC_INTERNAL
)
2398 if (sym
->attr
.intrinsic
)
2400 m
= gfc_intrinsic_func_interface (expr
, 1);
2404 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2405 "with an intrinsic", sym
->name
, &expr
->where
);
2413 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2416 expr
->ts
= sym
->result
->ts
;
2419 expr
->value
.function
.name
= sym
->name
;
2420 expr
->value
.function
.esym
= sym
;
2421 if (sym
->as
!= NULL
)
2422 expr
->rank
= sym
->as
->rank
;
2429 resolve_specific_f (gfc_expr
*expr
)
2434 sym
= expr
->symtree
->n
.sym
;
2438 m
= resolve_specific_f0 (sym
, expr
);
2441 if (m
== MATCH_ERROR
)
2444 if (sym
->ns
->parent
== NULL
)
2447 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2453 gfc_error ("Unable to resolve the specific function '%s' at %L",
2454 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2460 /* Resolve a procedure call not known to be generic nor specific. */
2463 resolve_unknown_f (gfc_expr
*expr
)
2468 sym
= expr
->symtree
->n
.sym
;
2470 if (sym
->attr
.dummy
)
2472 sym
->attr
.proc
= PROC_DUMMY
;
2473 expr
->value
.function
.name
= sym
->name
;
2477 /* See if we have an intrinsic function reference. */
2479 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2481 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2486 /* The reference is to an external name. */
2488 sym
->attr
.proc
= PROC_EXTERNAL
;
2489 expr
->value
.function
.name
= sym
->name
;
2490 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2492 if (sym
->as
!= NULL
)
2493 expr
->rank
= sym
->as
->rank
;
2495 /* Type of the expression is either the type of the symbol or the
2496 default type of the symbol. */
2499 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2501 if (sym
->ts
.type
!= BT_UNKNOWN
)
2505 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2507 if (ts
->type
== BT_UNKNOWN
)
2509 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2510 sym
->name
, &expr
->where
);
2521 /* Return true, if the symbol is an external procedure. */
2523 is_external_proc (gfc_symbol
*sym
)
2525 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2526 && !(sym
->attr
.intrinsic
2527 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2528 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2529 && !sym
->attr
.proc_pointer
2530 && !sym
->attr
.use_assoc
2538 /* Figure out if a function reference is pure or not. Also set the name
2539 of the function for a potential error message. Return nonzero if the
2540 function is PURE, zero if not. */
2542 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2545 pure_function (gfc_expr
*e
, const char **name
)
2551 if (e
->symtree
!= NULL
2552 && e
->symtree
->n
.sym
!= NULL
2553 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2554 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2556 if (e
->value
.function
.esym
)
2558 pure
= gfc_pure (e
->value
.function
.esym
);
2559 *name
= e
->value
.function
.esym
->name
;
2561 else if (e
->value
.function
.isym
)
2563 pure
= e
->value
.function
.isym
->pure
2564 || e
->value
.function
.isym
->elemental
;
2565 *name
= e
->value
.function
.isym
->name
;
2569 /* Implicit functions are not pure. */
2571 *name
= e
->value
.function
.name
;
2579 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2580 int *f ATTRIBUTE_UNUSED
)
2584 /* Don't bother recursing into other statement functions
2585 since they will be checked individually for purity. */
2586 if (e
->expr_type
!= EXPR_FUNCTION
2588 || e
->symtree
->n
.sym
== sym
2589 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2592 return pure_function (e
, &name
) ? false : true;
2597 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2599 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2604 is_scalar_expr_ptr (gfc_expr
*expr
)
2606 gfc_try retval
= SUCCESS
;
2611 /* See if we have a gfc_ref, which means we have a substring, array
2612 reference, or a component. */
2613 if (expr
->ref
!= NULL
)
2616 while (ref
->next
!= NULL
)
2622 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2623 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2628 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2630 else if (ref
->u
.ar
.type
== AR_FULL
)
2632 /* The user can give a full array if the array is of size 1. */
2633 if (ref
->u
.ar
.as
!= NULL
2634 && ref
->u
.ar
.as
->rank
== 1
2635 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2636 && ref
->u
.ar
.as
->lower
[0] != NULL
2637 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2638 && ref
->u
.ar
.as
->upper
[0] != NULL
2639 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2641 /* If we have a character string, we need to check if
2642 its length is one. */
2643 if (expr
->ts
.type
== BT_CHARACTER
)
2645 if (expr
->ts
.u
.cl
== NULL
2646 || expr
->ts
.u
.cl
->length
== NULL
2647 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2653 /* We have constant lower and upper bounds. If the
2654 difference between is 1, it can be considered a
2656 FIXME: Use gfc_dep_compare_expr instead. */
2657 start
= (int) mpz_get_si
2658 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2659 end
= (int) mpz_get_si
2660 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2661 if (end
- start
+ 1 != 1)
2676 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2678 /* Character string. Make sure it's of length 1. */
2679 if (expr
->ts
.u
.cl
== NULL
2680 || expr
->ts
.u
.cl
->length
== NULL
2681 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2684 else if (expr
->rank
!= 0)
2691 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2692 and, in the case of c_associated, set the binding label based on
2696 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2697 gfc_symbol
**new_sym
)
2699 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2700 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2701 int optional_arg
= 0;
2702 gfc_try retval
= SUCCESS
;
2703 gfc_symbol
*args_sym
;
2704 gfc_typespec
*arg_ts
;
2705 symbol_attribute arg_attr
;
2707 if (args
->expr
->expr_type
== EXPR_CONSTANT
2708 || args
->expr
->expr_type
== EXPR_OP
2709 || args
->expr
->expr_type
== EXPR_NULL
)
2711 gfc_error ("Argument to '%s' at %L is not a variable",
2712 sym
->name
, &(args
->expr
->where
));
2716 args_sym
= args
->expr
->symtree
->n
.sym
;
2718 /* The typespec for the actual arg should be that stored in the expr
2719 and not necessarily that of the expr symbol (args_sym), because
2720 the actual expression could be a part-ref of the expr symbol. */
2721 arg_ts
= &(args
->expr
->ts
);
2722 arg_attr
= gfc_expr_attr (args
->expr
);
2724 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2726 /* If the user gave two args then they are providing something for
2727 the optional arg (the second cptr). Therefore, set the name and
2728 binding label to the c_associated for two cptrs. Otherwise,
2729 set c_associated to expect one cptr. */
2733 sprintf (name
, "%s_2", sym
->name
);
2734 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2740 sprintf (name
, "%s_1", sym
->name
);
2741 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2745 /* Get a new symbol for the version of c_associated that
2747 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2749 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2750 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2752 sprintf (name
, "%s", sym
->name
);
2753 sprintf (binding_label
, "%s", sym
->binding_label
);
2755 /* Error check the call. */
2756 if (args
->next
!= NULL
)
2758 gfc_error_now ("More actual than formal arguments in '%s' "
2759 "call at %L", name
, &(args
->expr
->where
));
2762 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2767 /* Make sure we have either the target or pointer attribute. */
2768 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2770 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2771 "a TARGET or an associated pointer",
2773 sym
->name
, &(args
->expr
->where
));
2777 if (gfc_is_coindexed (args
->expr
))
2779 gfc_error_now ("Coindexed argument not permitted"
2780 " in '%s' call at %L", name
,
2781 &(args
->expr
->where
));
2785 /* Follow references to make sure there are no array
2787 seen_section
= false;
2789 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2791 if (ref
->type
== REF_ARRAY
)
2793 if (ref
->u
.ar
.type
== AR_SECTION
)
2794 seen_section
= true;
2796 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2799 for (r
= ref
->next
; r
; r
=r
->next
)
2800 if (r
->type
== REF_COMPONENT
)
2802 gfc_error_now ("Array section not permitted"
2803 " in '%s' call at %L", name
,
2804 &(args
->expr
->where
));
2812 if (seen_section
&& retval
== SUCCESS
)
2813 gfc_warning ("Array section in '%s' call at %L", name
,
2814 &(args
->expr
->where
));
2816 /* See if we have interoperable type and type param. */
2817 if (verify_c_interop (arg_ts
) == SUCCESS
2818 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2820 if (args_sym
->attr
.target
== 1)
2822 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2823 has the target attribute and is interoperable. */
2824 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2825 allocatable variable that has the TARGET attribute and
2826 is not an array of zero size. */
2827 if (args_sym
->attr
.allocatable
== 1)
2829 if (args_sym
->attr
.dimension
!= 0
2830 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2832 gfc_error_now ("Allocatable variable '%s' used as a "
2833 "parameter to '%s' at %L must not be "
2834 "an array of zero size",
2835 args_sym
->name
, sym
->name
,
2836 &(args
->expr
->where
));
2842 /* A non-allocatable target variable with C
2843 interoperable type and type parameters must be
2845 if (args_sym
&& args_sym
->attr
.dimension
)
2847 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2849 gfc_error ("Assumed-shape array '%s' at %L "
2850 "cannot be an argument to the "
2851 "procedure '%s' because "
2852 "it is not C interoperable",
2854 &(args
->expr
->where
), sym
->name
);
2857 else if (args_sym
->as
->type
== AS_DEFERRED
)
2859 gfc_error ("Deferred-shape array '%s' at %L "
2860 "cannot be an argument to the "
2861 "procedure '%s' because "
2862 "it is not C interoperable",
2864 &(args
->expr
->where
), sym
->name
);
2869 /* Make sure it's not a character string. Arrays of
2870 any type should be ok if the variable is of a C
2871 interoperable type. */
2872 if (arg_ts
->type
== BT_CHARACTER
)
2873 if (arg_ts
->u
.cl
!= NULL
2874 && (arg_ts
->u
.cl
->length
== NULL
2875 || arg_ts
->u
.cl
->length
->expr_type
2878 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2880 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2882 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2883 "at %L must have a length of 1",
2884 args_sym
->name
, sym
->name
,
2885 &(args
->expr
->where
));
2890 else if (arg_attr
.pointer
2891 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2893 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2895 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2896 "associated scalar POINTER", args_sym
->name
,
2897 sym
->name
, &(args
->expr
->where
));
2903 /* The parameter is not required to be C interoperable. If it
2904 is not C interoperable, it must be a nonpolymorphic scalar
2905 with no length type parameters. It still must have either
2906 the pointer or target attribute, and it can be
2907 allocatable (but must be allocated when c_loc is called). */
2908 if (args
->expr
->rank
!= 0
2909 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2911 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2912 "scalar", args_sym
->name
, sym
->name
,
2913 &(args
->expr
->where
));
2916 else if (arg_ts
->type
== BT_CHARACTER
2917 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2919 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2920 "%L must have a length of 1",
2921 args_sym
->name
, sym
->name
,
2922 &(args
->expr
->where
));
2925 else if (arg_ts
->type
== BT_CLASS
)
2927 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2928 "polymorphic", args_sym
->name
, sym
->name
,
2929 &(args
->expr
->where
));
2934 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2936 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2938 /* TODO: Update this error message to allow for procedure
2939 pointers once they are implemented. */
2940 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2942 args_sym
->name
, sym
->name
,
2943 &(args
->expr
->where
));
2946 else if (args_sym
->attr
.is_bind_c
!= 1)
2948 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2950 args_sym
->name
, sym
->name
,
2951 &(args
->expr
->where
));
2956 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2961 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2962 "iso_c_binding function: '%s'!\n", sym
->name
);
2969 /* Resolve a function call, which means resolving the arguments, then figuring
2970 out which entity the name refers to. */
2973 resolve_function (gfc_expr
*expr
)
2975 gfc_actual_arglist
*arg
;
2980 procedure_type p
= PROC_INTRINSIC
;
2981 bool no_formal_args
;
2985 sym
= expr
->symtree
->n
.sym
;
2987 /* If this is a procedure pointer component, it has already been resolved. */
2988 if (gfc_is_proc_ptr_comp (expr
, NULL
))
2991 if (sym
&& sym
->attr
.intrinsic
2992 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
2995 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2997 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3001 /* If this ia a deferred TBP with an abstract interface (which may
3002 of course be referenced), expr->value.function.esym will be set. */
3003 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3005 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3006 sym
->name
, &expr
->where
);
3010 /* Switch off assumed size checking and do this again for certain kinds
3011 of procedure, once the procedure itself is resolved. */
3012 need_full_assumed_size
++;
3014 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3015 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3017 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3018 inquiry_argument
= true;
3019 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3021 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3022 p
, no_formal_args
) == FAILURE
)
3024 inquiry_argument
= false;
3028 inquiry_argument
= false;
3030 /* Need to setup the call to the correct c_associated, depending on
3031 the number of cptrs to user gives to compare. */
3032 if (sym
&& sym
->attr
.is_iso_c
== 1)
3034 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3038 /* Get the symtree for the new symbol (resolved func).
3039 the old one will be freed later, when it's no longer used. */
3040 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3043 /* Resume assumed_size checking. */
3044 need_full_assumed_size
--;
3046 /* If the procedure is external, check for usage. */
3047 if (sym
&& is_external_proc (sym
))
3048 resolve_global_procedure (sym
, &expr
->where
,
3049 &expr
->value
.function
.actual
, 0);
3051 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3053 && sym
->ts
.u
.cl
->length
== NULL
3055 && !sym
->ts
.deferred
3056 && expr
->value
.function
.esym
== NULL
3057 && !sym
->attr
.contained
)
3059 /* Internal procedures are taken care of in resolve_contained_fntype. */
3060 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3061 "be used at %L since it is not a dummy argument",
3062 sym
->name
, &expr
->where
);
3066 /* See if function is already resolved. */
3068 if (expr
->value
.function
.name
!= NULL
)
3070 if (expr
->ts
.type
== BT_UNKNOWN
)
3076 /* Apply the rules of section 14.1.2. */
3078 switch (procedure_kind (sym
))
3081 t
= resolve_generic_f (expr
);
3084 case PTYPE_SPECIFIC
:
3085 t
= resolve_specific_f (expr
);
3089 t
= resolve_unknown_f (expr
);
3093 gfc_internal_error ("resolve_function(): bad function type");
3097 /* If the expression is still a function (it might have simplified),
3098 then we check to see if we are calling an elemental function. */
3100 if (expr
->expr_type
!= EXPR_FUNCTION
)
3103 temp
= need_full_assumed_size
;
3104 need_full_assumed_size
= 0;
3106 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3109 if (omp_workshare_flag
3110 && expr
->value
.function
.esym
3111 && ! gfc_elemental (expr
->value
.function
.esym
))
3113 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3114 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3119 #define GENERIC_ID expr->value.function.isym->id
3120 else if (expr
->value
.function
.actual
!= NULL
3121 && expr
->value
.function
.isym
!= NULL
3122 && GENERIC_ID
!= GFC_ISYM_LBOUND
3123 && GENERIC_ID
!= GFC_ISYM_LEN
3124 && GENERIC_ID
!= GFC_ISYM_LOC
3125 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3127 /* Array intrinsics must also have the last upper bound of an
3128 assumed size array argument. UBOUND and SIZE have to be
3129 excluded from the check if the second argument is anything
3132 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3134 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3135 && arg
->next
!= NULL
&& arg
->next
->expr
)
3137 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3140 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3143 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3148 if (arg
->expr
!= NULL
3149 && arg
->expr
->rank
> 0
3150 && resolve_assumed_size_actual (arg
->expr
))
3156 need_full_assumed_size
= temp
;
3159 if (!pure_function (expr
, &name
) && name
)
3163 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3164 "FORALL %s", name
, &expr
->where
,
3165 forall_flag
== 2 ? "mask" : "block");
3168 else if (do_concurrent_flag
)
3170 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3171 "DO CONCURRENT %s", name
, &expr
->where
,
3172 do_concurrent_flag
== 2 ? "mask" : "block");
3175 else if (gfc_pure (NULL
))
3177 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3178 "procedure within a PURE procedure", name
, &expr
->where
);
3183 if (!pure_function (expr
, &name
) && name
&& gfc_implicit_pure (NULL
))
3184 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3186 /* Functions without the RECURSIVE attribution are not allowed to
3187 * call themselves. */
3188 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3191 esym
= expr
->value
.function
.esym
;
3193 if (is_illegal_recursion (esym
, gfc_current_ns
))
3195 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3196 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3197 " function '%s' is not RECURSIVE",
3198 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3200 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3201 " is not RECURSIVE", esym
->name
, &expr
->where
);
3207 /* Character lengths of use associated functions may contains references to
3208 symbols not referenced from the current program unit otherwise. Make sure
3209 those symbols are marked as referenced. */
3211 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3212 && expr
->value
.function
.esym
->attr
.use_assoc
)
3214 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3217 /* Make sure that the expression has a typespec that works. */
3218 if (expr
->ts
.type
== BT_UNKNOWN
)
3220 if (expr
->symtree
->n
.sym
->result
3221 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3222 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3223 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3230 /************* Subroutine resolution *************/
3233 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3239 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3240 sym
->name
, &c
->loc
);
3241 else if (do_concurrent_flag
)
3242 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3243 "PURE", sym
->name
, &c
->loc
);
3244 else if (gfc_pure (NULL
))
3245 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3251 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3255 if (sym
->attr
.generic
)
3257 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3260 c
->resolved_sym
= s
;
3261 pure_subroutine (c
, s
);
3265 /* TODO: Need to search for elemental references in generic interface. */
3268 if (sym
->attr
.intrinsic
)
3269 return gfc_intrinsic_sub_interface (c
, 0);
3276 resolve_generic_s (gfc_code
*c
)
3281 sym
= c
->symtree
->n
.sym
;
3285 m
= resolve_generic_s0 (c
, sym
);
3288 else if (m
== MATCH_ERROR
)
3292 if (sym
->ns
->parent
== NULL
)
3294 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3298 if (!generic_sym (sym
))
3302 /* Last ditch attempt. See if the reference is to an intrinsic
3303 that possesses a matching interface. 14.1.2.4 */
3304 sym
= c
->symtree
->n
.sym
;
3306 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3308 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3309 sym
->name
, &c
->loc
);
3313 m
= gfc_intrinsic_sub_interface (c
, 0);
3317 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3318 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3324 /* Set the name and binding label of the subroutine symbol in the call
3325 expression represented by 'c' to include the type and kind of the
3326 second parameter. This function is for resolving the appropriate
3327 version of c_f_pointer() and c_f_procpointer(). For example, a
3328 call to c_f_pointer() for a default integer pointer could have a
3329 name of c_f_pointer_i4. If no second arg exists, which is an error
3330 for these two functions, it defaults to the generic symbol's name
3331 and binding label. */
3334 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3335 char *name
, char *binding_label
)
3337 gfc_expr
*arg
= NULL
;
3341 /* The second arg of c_f_pointer and c_f_procpointer determines
3342 the type and kind for the procedure name. */
3343 arg
= c
->ext
.actual
->next
->expr
;
3347 /* Set up the name to have the given symbol's name,
3348 plus the type and kind. */
3349 /* a derived type is marked with the type letter 'u' */
3350 if (arg
->ts
.type
== BT_DERIVED
)
3353 kind
= 0; /* set the kind as 0 for now */
3357 type
= gfc_type_letter (arg
->ts
.type
);
3358 kind
= arg
->ts
.kind
;
3361 if (arg
->ts
.type
== BT_CHARACTER
)
3362 /* Kind info for character strings not needed. */
3365 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3366 /* Set up the binding label as the given symbol's label plus
3367 the type and kind. */
3368 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
3372 /* If the second arg is missing, set the name and label as
3373 was, cause it should at least be found, and the missing
3374 arg error will be caught by compare_parameters(). */
3375 sprintf (name
, "%s", sym
->name
);
3376 sprintf (binding_label
, "%s", sym
->binding_label
);
3383 /* Resolve a generic version of the iso_c_binding procedure given
3384 (sym) to the specific one based on the type and kind of the
3385 argument(s). Currently, this function resolves c_f_pointer() and
3386 c_f_procpointer based on the type and kind of the second argument
3387 (FPTR). Other iso_c_binding procedures aren't specially handled.
3388 Upon successfully exiting, c->resolved_sym will hold the resolved
3389 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3393 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3395 gfc_symbol
*new_sym
;
3396 /* this is fine, since we know the names won't use the max */
3397 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3398 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
3399 /* default to success; will override if find error */
3400 match m
= MATCH_YES
;
3402 /* Make sure the actual arguments are in the necessary order (based on the
3403 formal args) before resolving. */
3404 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3406 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3407 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3409 set_name_and_label (c
, sym
, name
, binding_label
);
3411 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3413 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3415 /* Make sure we got a third arg if the second arg has non-zero
3416 rank. We must also check that the type and rank are
3417 correct since we short-circuit this check in
3418 gfc_procedure_use() (called above to sort actual args). */
3419 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3421 if(c
->ext
.actual
->next
->next
== NULL
3422 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3425 gfc_error ("Missing SHAPE parameter for call to %s "
3426 "at %L", sym
->name
, &(c
->loc
));
3428 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3430 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3433 gfc_error ("SHAPE parameter for call to %s at %L must "
3434 "be a rank 1 INTEGER array", sym
->name
,
3441 if (m
!= MATCH_ERROR
)
3443 /* the 1 means to add the optional arg to formal list */
3444 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3446 /* for error reporting, say it's declared where the original was */
3447 new_sym
->declared_at
= sym
->declared_at
;
3452 /* no differences for c_loc or c_funloc */
3456 /* set the resolved symbol */
3457 if (m
!= MATCH_ERROR
)
3458 c
->resolved_sym
= new_sym
;
3460 c
->resolved_sym
= sym
;
3466 /* Resolve a subroutine call known to be specific. */
3469 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3473 if(sym
->attr
.is_iso_c
)
3475 m
= gfc_iso_c_sub_interface (c
,sym
);
3479 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3481 if (sym
->attr
.dummy
)
3483 sym
->attr
.proc
= PROC_DUMMY
;
3487 sym
->attr
.proc
= PROC_EXTERNAL
;
3491 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3494 if (sym
->attr
.intrinsic
)
3496 m
= gfc_intrinsic_sub_interface (c
, 1);
3500 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3501 "with an intrinsic", sym
->name
, &c
->loc
);
3509 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3511 c
->resolved_sym
= sym
;
3512 pure_subroutine (c
, sym
);
3519 resolve_specific_s (gfc_code
*c
)
3524 sym
= c
->symtree
->n
.sym
;
3528 m
= resolve_specific_s0 (c
, sym
);
3531 if (m
== MATCH_ERROR
)
3534 if (sym
->ns
->parent
== NULL
)
3537 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3543 sym
= c
->symtree
->n
.sym
;
3544 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3545 sym
->name
, &c
->loc
);
3551 /* Resolve a subroutine call not known to be generic nor specific. */
3554 resolve_unknown_s (gfc_code
*c
)
3558 sym
= c
->symtree
->n
.sym
;
3560 if (sym
->attr
.dummy
)
3562 sym
->attr
.proc
= PROC_DUMMY
;
3566 /* See if we have an intrinsic function reference. */
3568 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3570 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3575 /* The reference is to an external name. */
3578 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3580 c
->resolved_sym
= sym
;
3582 pure_subroutine (c
, sym
);
3588 /* Resolve a subroutine call. Although it was tempting to use the same code
3589 for functions, subroutines and functions are stored differently and this
3590 makes things awkward. */
3593 resolve_call (gfc_code
*c
)
3596 procedure_type ptype
= PROC_INTRINSIC
;
3597 gfc_symbol
*csym
, *sym
;
3598 bool no_formal_args
;
3600 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3602 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3604 gfc_error ("'%s' at %L has a type, which is not consistent with "
3605 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3609 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3612 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3613 sym
= st
? st
->n
.sym
: NULL
;
3614 if (sym
&& csym
!= sym
3615 && sym
->ns
== gfc_current_ns
3616 && sym
->attr
.flavor
== FL_PROCEDURE
3617 && sym
->attr
.contained
)
3620 if (csym
->attr
.generic
)
3621 c
->symtree
->n
.sym
= sym
;
3624 csym
= c
->symtree
->n
.sym
;
3628 /* If this ia a deferred TBP with an abstract interface
3629 (which may of course be referenced), c->expr1 will be set. */
3630 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3632 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3633 csym
->name
, &c
->loc
);
3637 /* Subroutines without the RECURSIVE attribution are not allowed to
3638 * call themselves. */
3639 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3641 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3642 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3643 " subroutine '%s' is not RECURSIVE",
3644 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3646 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3647 " is not RECURSIVE", csym
->name
, &c
->loc
);
3652 /* Switch off assumed size checking and do this again for certain kinds
3653 of procedure, once the procedure itself is resolved. */
3654 need_full_assumed_size
++;
3657 ptype
= csym
->attr
.proc
;
3659 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3660 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3661 no_formal_args
) == FAILURE
)
3664 /* Resume assumed_size checking. */
3665 need_full_assumed_size
--;
3667 /* If external, check for usage. */
3668 if (csym
&& is_external_proc (csym
))
3669 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3672 if (c
->resolved_sym
== NULL
)
3674 c
->resolved_isym
= NULL
;
3675 switch (procedure_kind (csym
))
3678 t
= resolve_generic_s (c
);
3681 case PTYPE_SPECIFIC
:
3682 t
= resolve_specific_s (c
);
3686 t
= resolve_unknown_s (c
);
3690 gfc_internal_error ("resolve_subroutine(): bad function type");
3694 /* Some checks of elemental subroutine actual arguments. */
3695 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3702 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3703 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3704 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3705 if their shapes do not match. If either op1->shape or op2->shape is
3706 NULL, return SUCCESS. */
3709 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3716 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3718 for (i
= 0; i
< op1
->rank
; i
++)
3720 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3722 gfc_error ("Shapes for operands at %L and %L are not conformable",
3723 &op1
->where
, &op2
->where
);
3734 /* Resolve an operator expression node. This can involve replacing the
3735 operation with a user defined function call. */
3738 resolve_operator (gfc_expr
*e
)
3740 gfc_expr
*op1
, *op2
;
3742 bool dual_locus_error
;
3745 /* Resolve all subnodes-- give them types. */
3747 switch (e
->value
.op
.op
)
3750 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3753 /* Fall through... */
3756 case INTRINSIC_UPLUS
:
3757 case INTRINSIC_UMINUS
:
3758 case INTRINSIC_PARENTHESES
:
3759 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3764 /* Typecheck the new node. */
3766 op1
= e
->value
.op
.op1
;
3767 op2
= e
->value
.op
.op2
;
3768 dual_locus_error
= false;
3770 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3771 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3773 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3777 switch (e
->value
.op
.op
)
3779 case INTRINSIC_UPLUS
:
3780 case INTRINSIC_UMINUS
:
3781 if (op1
->ts
.type
== BT_INTEGER
3782 || op1
->ts
.type
== BT_REAL
3783 || op1
->ts
.type
== BT_COMPLEX
)
3789 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3790 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3793 case INTRINSIC_PLUS
:
3794 case INTRINSIC_MINUS
:
3795 case INTRINSIC_TIMES
:
3796 case INTRINSIC_DIVIDE
:
3797 case INTRINSIC_POWER
:
3798 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3800 gfc_type_convert_binary (e
, 1);
3805 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3806 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3807 gfc_typename (&op2
->ts
));
3810 case INTRINSIC_CONCAT
:
3811 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3812 && op1
->ts
.kind
== op2
->ts
.kind
)
3814 e
->ts
.type
= BT_CHARACTER
;
3815 e
->ts
.kind
= op1
->ts
.kind
;
3820 _("Operands of string concatenation operator at %%L are %s/%s"),
3821 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3827 case INTRINSIC_NEQV
:
3828 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3830 e
->ts
.type
= BT_LOGICAL
;
3831 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3832 if (op1
->ts
.kind
< e
->ts
.kind
)
3833 gfc_convert_type (op1
, &e
->ts
, 2);
3834 else if (op2
->ts
.kind
< e
->ts
.kind
)
3835 gfc_convert_type (op2
, &e
->ts
, 2);
3839 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3840 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3841 gfc_typename (&op2
->ts
));
3846 if (op1
->ts
.type
== BT_LOGICAL
)
3848 e
->ts
.type
= BT_LOGICAL
;
3849 e
->ts
.kind
= op1
->ts
.kind
;
3853 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3854 gfc_typename (&op1
->ts
));
3858 case INTRINSIC_GT_OS
:
3860 case INTRINSIC_GE_OS
:
3862 case INTRINSIC_LT_OS
:
3864 case INTRINSIC_LE_OS
:
3865 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3867 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3871 /* Fall through... */
3874 case INTRINSIC_EQ_OS
:
3876 case INTRINSIC_NE_OS
:
3877 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3878 && op1
->ts
.kind
== op2
->ts
.kind
)
3880 e
->ts
.type
= BT_LOGICAL
;
3881 e
->ts
.kind
= gfc_default_logical_kind
;
3885 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3887 gfc_type_convert_binary (e
, 1);
3889 e
->ts
.type
= BT_LOGICAL
;
3890 e
->ts
.kind
= gfc_default_logical_kind
;
3894 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3896 _("Logicals at %%L must be compared with %s instead of %s"),
3897 (e
->value
.op
.op
== INTRINSIC_EQ
3898 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3899 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3902 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3903 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3904 gfc_typename (&op2
->ts
));
3908 case INTRINSIC_USER
:
3909 if (e
->value
.op
.uop
->op
== NULL
)
3910 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3911 else if (op2
== NULL
)
3912 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3913 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3916 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3917 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3918 gfc_typename (&op2
->ts
));
3919 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3924 case INTRINSIC_PARENTHESES
:
3926 if (e
->ts
.type
== BT_CHARACTER
)
3927 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3931 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3934 /* Deal with arrayness of an operand through an operator. */
3938 switch (e
->value
.op
.op
)
3940 case INTRINSIC_PLUS
:
3941 case INTRINSIC_MINUS
:
3942 case INTRINSIC_TIMES
:
3943 case INTRINSIC_DIVIDE
:
3944 case INTRINSIC_POWER
:
3945 case INTRINSIC_CONCAT
:
3949 case INTRINSIC_NEQV
:
3951 case INTRINSIC_EQ_OS
:
3953 case INTRINSIC_NE_OS
:
3955 case INTRINSIC_GT_OS
:
3957 case INTRINSIC_GE_OS
:
3959 case INTRINSIC_LT_OS
:
3961 case INTRINSIC_LE_OS
:
3963 if (op1
->rank
== 0 && op2
->rank
== 0)
3966 if (op1
->rank
== 0 && op2
->rank
!= 0)
3968 e
->rank
= op2
->rank
;
3970 if (e
->shape
== NULL
)
3971 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3974 if (op1
->rank
!= 0 && op2
->rank
== 0)
3976 e
->rank
= op1
->rank
;
3978 if (e
->shape
== NULL
)
3979 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3982 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3984 if (op1
->rank
== op2
->rank
)
3986 e
->rank
= op1
->rank
;
3987 if (e
->shape
== NULL
)
3989 t
= compare_shapes (op1
, op2
);
3993 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3998 /* Allow higher level expressions to work. */
4001 /* Try user-defined operators, and otherwise throw an error. */
4002 dual_locus_error
= true;
4004 _("Inconsistent ranks for operator at %%L and %%L"));
4011 case INTRINSIC_PARENTHESES
:
4013 case INTRINSIC_UPLUS
:
4014 case INTRINSIC_UMINUS
:
4015 /* Simply copy arrayness attribute */
4016 e
->rank
= op1
->rank
;
4018 if (e
->shape
== NULL
)
4019 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4027 /* Attempt to simplify the expression. */
4030 t
= gfc_simplify_expr (e
, 0);
4031 /* Some calls do not succeed in simplification and return FAILURE
4032 even though there is no error; e.g. variable references to
4033 PARAMETER arrays. */
4034 if (!gfc_is_constant_expr (e
))
4043 if (gfc_extend_expr (e
, &real_error
) == SUCCESS
)
4050 if (dual_locus_error
)
4051 gfc_error (msg
, &op1
->where
, &op2
->where
);
4053 gfc_error (msg
, &e
->where
);
4059 /************** Array resolution subroutines **************/
4062 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4065 /* Compare two integer expressions. */
4068 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4072 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4073 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4076 /* If either of the types isn't INTEGER, we must have
4077 raised an error earlier. */
4079 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4082 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4092 /* Compare an integer expression with an integer. */
4095 compare_bound_int (gfc_expr
*a
, int b
)
4099 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4102 if (a
->ts
.type
!= BT_INTEGER
)
4103 gfc_internal_error ("compare_bound_int(): Bad expression");
4105 i
= mpz_cmp_si (a
->value
.integer
, b
);
4115 /* Compare an integer expression with a mpz_t. */
4118 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4122 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4125 if (a
->ts
.type
!= BT_INTEGER
)
4126 gfc_internal_error ("compare_bound_int(): Bad expression");
4128 i
= mpz_cmp (a
->value
.integer
, b
);
4138 /* Compute the last value of a sequence given by a triplet.
4139 Return 0 if it wasn't able to compute the last value, or if the
4140 sequence if empty, and 1 otherwise. */
4143 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4144 gfc_expr
*stride
, mpz_t last
)
4148 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4149 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4150 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4153 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4154 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4157 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4159 if (compare_bound (start
, end
) == CMP_GT
)
4161 mpz_set (last
, end
->value
.integer
);
4165 if (compare_bound_int (stride
, 0) == CMP_GT
)
4167 /* Stride is positive */
4168 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4173 /* Stride is negative */
4174 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4179 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4180 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4181 mpz_sub (last
, end
->value
.integer
, rem
);
4188 /* Compare a single dimension of an array reference to the array
4192 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4196 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4198 gcc_assert (ar
->stride
[i
] == NULL
);
4199 /* This implies [*] as [*:] and [*:3] are not possible. */
4200 if (ar
->start
[i
] == NULL
)
4202 gcc_assert (ar
->end
[i
] == NULL
);
4207 /* Given start, end and stride values, calculate the minimum and
4208 maximum referenced indexes. */
4210 switch (ar
->dimen_type
[i
])
4213 case DIMEN_THIS_IMAGE
:
4218 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4221 gfc_warning ("Array reference at %L is out of bounds "
4222 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4223 mpz_get_si (ar
->start
[i
]->value
.integer
),
4224 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4226 gfc_warning ("Array reference at %L is out of bounds "
4227 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4228 mpz_get_si (ar
->start
[i
]->value
.integer
),
4229 mpz_get_si (as
->lower
[i
]->value
.integer
),
4233 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4236 gfc_warning ("Array reference at %L is out of bounds "
4237 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4238 mpz_get_si (ar
->start
[i
]->value
.integer
),
4239 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4241 gfc_warning ("Array reference at %L is out of bounds "
4242 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4243 mpz_get_si (ar
->start
[i
]->value
.integer
),
4244 mpz_get_si (as
->upper
[i
]->value
.integer
),
4253 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4254 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4256 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4258 /* Check for zero stride, which is not allowed. */
4259 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4261 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4265 /* if start == len || (stride > 0 && start < len)
4266 || (stride < 0 && start > len),
4267 then the array section contains at least one element. In this
4268 case, there is an out-of-bounds access if
4269 (start < lower || start > upper). */
4270 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4271 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4272 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4273 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4274 && comp_start_end
== CMP_GT
))
4276 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4278 gfc_warning ("Lower array reference at %L is out of bounds "
4279 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4280 mpz_get_si (AR_START
->value
.integer
),
4281 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4284 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4286 gfc_warning ("Lower array reference at %L is out of bounds "
4287 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4288 mpz_get_si (AR_START
->value
.integer
),
4289 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4294 /* If we can compute the highest index of the array section,
4295 then it also has to be between lower and upper. */
4296 mpz_init (last_value
);
4297 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4300 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4302 gfc_warning ("Upper array reference at %L is out of bounds "
4303 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4304 mpz_get_si (last_value
),
4305 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4306 mpz_clear (last_value
);
4309 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4311 gfc_warning ("Upper array reference at %L is out of bounds "
4312 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4313 mpz_get_si (last_value
),
4314 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4315 mpz_clear (last_value
);
4319 mpz_clear (last_value
);
4327 gfc_internal_error ("check_dimension(): Bad array reference");
4334 /* Compare an array reference with an array specification. */
4337 compare_spec_to_ref (gfc_array_ref
*ar
)
4344 /* TODO: Full array sections are only allowed as actual parameters. */
4345 if (as
->type
== AS_ASSUMED_SIZE
4346 && (/*ar->type == AR_FULL
4347 ||*/ (ar
->type
== AR_SECTION
4348 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4350 gfc_error ("Rightmost upper bound of assumed size array section "
4351 "not specified at %L", &ar
->where
);
4355 if (ar
->type
== AR_FULL
)
4358 if (as
->rank
!= ar
->dimen
)
4360 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4361 &ar
->where
, ar
->dimen
, as
->rank
);
4365 /* ar->codimen == 0 is a local array. */
4366 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4368 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4369 &ar
->where
, ar
->codimen
, as
->corank
);
4373 for (i
= 0; i
< as
->rank
; i
++)
4374 if (check_dimension (i
, ar
, as
) == FAILURE
)
4377 /* Local access has no coarray spec. */
4378 if (ar
->codimen
!= 0)
4379 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4381 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4382 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4384 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4385 i
+ 1 - as
->rank
, &ar
->where
);
4388 if (check_dimension (i
, ar
, as
) == FAILURE
)
4392 if (as
->corank
&& ar
->codimen
== 0)
4395 ar
->codimen
= as
->corank
;
4396 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4397 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4404 /* Resolve one part of an array index. */
4407 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4408 int force_index_integer_kind
)
4415 if (gfc_resolve_expr (index
) == FAILURE
)
4418 if (check_scalar
&& index
->rank
!= 0)
4420 gfc_error ("Array index at %L must be scalar", &index
->where
);
4424 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4426 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4427 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4431 if (index
->ts
.type
== BT_REAL
)
4432 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4433 &index
->where
) == FAILURE
)
4436 if ((index
->ts
.kind
!= gfc_index_integer_kind
4437 && force_index_integer_kind
)
4438 || index
->ts
.type
!= BT_INTEGER
)
4441 ts
.type
= BT_INTEGER
;
4442 ts
.kind
= gfc_index_integer_kind
;
4444 gfc_convert_type_warn (index
, &ts
, 2, 0);
4450 /* Resolve one part of an array index. */
4453 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4455 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4458 /* Resolve a dim argument to an intrinsic function. */
4461 gfc_resolve_dim_arg (gfc_expr
*dim
)
4466 if (gfc_resolve_expr (dim
) == FAILURE
)
4471 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4476 if (dim
->ts
.type
!= BT_INTEGER
)
4478 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4482 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4487 ts
.type
= BT_INTEGER
;
4488 ts
.kind
= gfc_index_integer_kind
;
4490 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4496 /* Given an expression that contains array references, update those array
4497 references to point to the right array specifications. While this is
4498 filled in during matching, this information is difficult to save and load
4499 in a module, so we take care of it here.
4501 The idea here is that the original array reference comes from the
4502 base symbol. We traverse the list of reference structures, setting
4503 the stored reference to references. Component references can
4504 provide an additional array specification. */
4507 find_array_spec (gfc_expr
*e
)
4511 gfc_symbol
*derived
;
4514 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4515 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4517 as
= e
->symtree
->n
.sym
->as
;
4520 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4525 gfc_internal_error ("find_array_spec(): Missing spec");
4532 if (derived
== NULL
)
4533 derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
4535 if (derived
->attr
.is_class
)
4536 derived
= derived
->components
->ts
.u
.derived
;
4538 c
= derived
->components
;
4540 for (; c
; c
= c
->next
)
4541 if (c
== ref
->u
.c
.component
)
4543 /* Track the sequence of component references. */
4544 if (c
->ts
.type
== BT_DERIVED
)
4545 derived
= c
->ts
.u
.derived
;
4550 gfc_internal_error ("find_array_spec(): Component not found");
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
&& ar
->as
->rank
== 0)
4649 ar
->type
= AR_ELEMENT
;
4651 /* If the reference type is unknown, figure out what kind it is. */
4653 if (ar
->type
== AR_UNKNOWN
)
4655 ar
->type
= AR_ELEMENT
;
4656 for (i
= 0; i
< ar
->dimen
; i
++)
4657 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4658 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4660 ar
->type
= AR_SECTION
;
4665 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4673 resolve_substring (gfc_ref
*ref
)
4675 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4677 if (ref
->u
.ss
.start
!= NULL
)
4679 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4682 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4684 gfc_error ("Substring start index at %L must be of type INTEGER",
4685 &ref
->u
.ss
.start
->where
);
4689 if (ref
->u
.ss
.start
->rank
!= 0)
4691 gfc_error ("Substring start index at %L must be scalar",
4692 &ref
->u
.ss
.start
->where
);
4696 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4697 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4698 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4700 gfc_error ("Substring start index at %L is less than one",
4701 &ref
->u
.ss
.start
->where
);
4706 if (ref
->u
.ss
.end
!= NULL
)
4708 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4711 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4713 gfc_error ("Substring end index at %L must be of type INTEGER",
4714 &ref
->u
.ss
.end
->where
);
4718 if (ref
->u
.ss
.end
->rank
!= 0)
4720 gfc_error ("Substring end index at %L must be scalar",
4721 &ref
->u
.ss
.end
->where
);
4725 if (ref
->u
.ss
.length
!= NULL
4726 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4727 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4728 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4730 gfc_error ("Substring end index at %L exceeds the string length",
4731 &ref
->u
.ss
.start
->where
);
4735 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4736 gfc_integer_kinds
[k
].huge
) == CMP_GT
4737 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4738 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4740 gfc_error ("Substring end index at %L is too large",
4741 &ref
->u
.ss
.end
->where
);
4750 /* This function supplies missing substring charlens. */
4753 gfc_resolve_substring_charlen (gfc_expr
*e
)
4756 gfc_expr
*start
, *end
;
4758 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4759 if (char_ref
->type
== REF_SUBSTRING
)
4765 gcc_assert (char_ref
->next
== NULL
);
4769 if (e
->ts
.u
.cl
->length
)
4770 gfc_free_expr (e
->ts
.u
.cl
->length
);
4771 else if (e
->expr_type
== EXPR_VARIABLE
4772 && e
->symtree
->n
.sym
->attr
.dummy
)
4776 e
->ts
.type
= BT_CHARACTER
;
4777 e
->ts
.kind
= gfc_default_character_kind
;
4780 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4782 if (char_ref
->u
.ss
.start
)
4783 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4785 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4787 if (char_ref
->u
.ss
.end
)
4788 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4789 else if (e
->expr_type
== EXPR_VARIABLE
)
4790 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4797 /* Length = (end - start +1). */
4798 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4799 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4800 gfc_get_int_expr (gfc_default_integer_kind
,
4803 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4804 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4806 /* Make sure that the length is simplified. */
4807 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4808 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4812 /* Resolve subtype references. */
4815 resolve_ref (gfc_expr
*expr
)
4817 int current_part_dimension
, n_components
, seen_part_dimension
;
4820 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4821 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4823 find_array_spec (expr
);
4827 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4831 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4839 resolve_substring (ref
);
4843 /* Check constraints on part references. */
4845 current_part_dimension
= 0;
4846 seen_part_dimension
= 0;
4849 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4854 switch (ref
->u
.ar
.type
)
4857 /* Coarray scalar. */
4858 if (ref
->u
.ar
.as
->rank
== 0)
4860 current_part_dimension
= 0;
4865 current_part_dimension
= 1;
4869 current_part_dimension
= 0;
4873 gfc_internal_error ("resolve_ref(): Bad array reference");
4879 if (current_part_dimension
|| seen_part_dimension
)
4882 if (ref
->u
.c
.component
->attr
.pointer
4883 || ref
->u
.c
.component
->attr
.proc_pointer
)
4885 gfc_error ("Component to the right of a part reference "
4886 "with nonzero rank must not have the POINTER "
4887 "attribute at %L", &expr
->where
);
4890 else if (ref
->u
.c
.component
->attr
.allocatable
)
4892 gfc_error ("Component to the right of a part reference "
4893 "with nonzero rank must not have the ALLOCATABLE "
4894 "attribute at %L", &expr
->where
);
4906 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4907 || ref
->next
== NULL
)
4908 && current_part_dimension
4909 && seen_part_dimension
)
4911 gfc_error ("Two or more part references with nonzero rank must "
4912 "not be specified at %L", &expr
->where
);
4916 if (ref
->type
== REF_COMPONENT
)
4918 if (current_part_dimension
)
4919 seen_part_dimension
= 1;
4921 /* reset to make sure */
4922 current_part_dimension
= 0;
4930 /* Given an expression, determine its shape. This is easier than it sounds.
4931 Leaves the shape array NULL if it is not possible to determine the shape. */
4934 expression_shape (gfc_expr
*e
)
4936 mpz_t array
[GFC_MAX_DIMENSIONS
];
4939 if (e
->rank
== 0 || e
->shape
!= NULL
)
4942 for (i
= 0; i
< e
->rank
; i
++)
4943 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4946 e
->shape
= gfc_get_shape (e
->rank
);
4948 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4953 for (i
--; i
>= 0; i
--)
4954 mpz_clear (array
[i
]);
4958 /* Given a variable expression node, compute the rank of the expression by
4959 examining the base symbol and any reference structures it may have. */
4962 expression_rank (gfc_expr
*e
)
4967 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4968 could lead to serious confusion... */
4969 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4973 if (e
->expr_type
== EXPR_ARRAY
)
4975 /* Constructors can have a rank different from one via RESHAPE(). */
4977 if (e
->symtree
== NULL
)
4983 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4984 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4990 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4992 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4993 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4994 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4996 if (ref
->type
!= REF_ARRAY
)
4999 if (ref
->u
.ar
.type
== AR_FULL
)
5001 rank
= ref
->u
.ar
.as
->rank
;
5005 if (ref
->u
.ar
.type
== AR_SECTION
)
5007 /* Figure out the rank of the section. */
5009 gfc_internal_error ("expression_rank(): Two array specs");
5011 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5012 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5013 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5023 expression_shape (e
);
5027 /* Resolve a variable expression. */
5030 resolve_variable (gfc_expr
*e
)
5037 if (e
->symtree
== NULL
)
5039 sym
= e
->symtree
->n
.sym
;
5041 /* If this is an associate-name, it may be parsed with an array reference
5042 in error even though the target is scalar. Fail directly in this case. */
5043 if (sym
->assoc
&& !sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5046 /* On the other hand, the parser may not have known this is an array;
5047 in this case, we have to add a FULL reference. */
5048 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5050 e
->ref
= gfc_get_ref ();
5051 e
->ref
->type
= REF_ARRAY
;
5052 e
->ref
->u
.ar
.type
= AR_FULL
;
5053 e
->ref
->u
.ar
.dimen
= 0;
5056 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5059 if (sym
->attr
.flavor
== FL_PROCEDURE
5060 && (!sym
->attr
.function
5061 || (sym
->attr
.function
&& sym
->result
5062 && sym
->result
->attr
.proc_pointer
5063 && !sym
->result
->attr
.function
)))
5065 e
->ts
.type
= BT_PROCEDURE
;
5066 goto resolve_procedure
;
5069 if (sym
->ts
.type
!= BT_UNKNOWN
)
5070 gfc_variable_attr (e
, &e
->ts
);
5073 /* Must be a simple variable reference. */
5074 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5079 if (check_assumed_size_reference (sym
, e
))
5082 /* Deal with forward references to entries during resolve_code, to
5083 satisfy, at least partially, 12.5.2.5. */
5084 if (gfc_current_ns
->entries
5085 && current_entry_id
== sym
->entry_id
5088 && cs_base
->current
->op
!= EXEC_ENTRY
)
5090 gfc_entry_list
*entry
;
5091 gfc_formal_arglist
*formal
;
5095 /* If the symbol is a dummy... */
5096 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5098 entry
= gfc_current_ns
->entries
;
5101 /* ...test if the symbol is a parameter of previous entries. */
5102 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5103 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5105 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5109 /* If it has not been seen as a dummy, this is an error. */
5112 if (specification_expr
)
5113 gfc_error ("Variable '%s', used in a specification expression"
5114 ", is referenced at %L before the ENTRY statement "
5115 "in which it is a parameter",
5116 sym
->name
, &cs_base
->current
->loc
);
5118 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5119 "statement in which it is a parameter",
5120 sym
->name
, &cs_base
->current
->loc
);
5125 /* Now do the same check on the specification expressions. */
5126 specification_expr
= 1;
5127 if (sym
->ts
.type
== BT_CHARACTER
5128 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5132 for (n
= 0; n
< sym
->as
->rank
; n
++)
5134 specification_expr
= 1;
5135 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5137 specification_expr
= 1;
5138 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5141 specification_expr
= 0;
5144 /* Update the symbol's entry level. */
5145 sym
->entry_id
= current_entry_id
+ 1;
5148 /* If a symbol has been host_associated mark it. This is used latter,
5149 to identify if aliasing is possible via host association. */
5150 if (sym
->attr
.flavor
== FL_VARIABLE
5151 && gfc_current_ns
->parent
5152 && (gfc_current_ns
->parent
== sym
->ns
5153 || (gfc_current_ns
->parent
->parent
5154 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5155 sym
->attr
.host_assoc
= 1;
5158 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5161 /* F2008, C617 and C1229. */
5162 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5163 && gfc_is_coindexed (e
))
5165 gfc_ref
*ref
, *ref2
= NULL
;
5167 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5169 if (ref
->type
== REF_COMPONENT
)
5171 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5175 for ( ; ref
; ref
= ref
->next
)
5176 if (ref
->type
== REF_COMPONENT
)
5179 /* Expression itself is not coindexed object. */
5180 if (ref
&& e
->ts
.type
== BT_CLASS
)
5182 gfc_error ("Polymorphic subobject of coindexed object at %L",
5187 /* Expression itself is coindexed object. */
5191 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5192 for ( ; c
; c
= c
->next
)
5193 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5195 gfc_error ("Coindexed object with polymorphic allocatable "
5196 "subcomponent at %L", &e
->where
);
5207 /* Checks to see that the correct symbol has been host associated.
5208 The only situation where this arises is that in which a twice
5209 contained function is parsed after the host association is made.
5210 Therefore, on detecting this, change the symbol in the expression
5211 and convert the array reference into an actual arglist if the old
5212 symbol is a variable. */
5214 check_host_association (gfc_expr
*e
)
5216 gfc_symbol
*sym
, *old_sym
;
5220 gfc_actual_arglist
*arg
, *tail
= NULL
;
5221 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5223 /* If the expression is the result of substitution in
5224 interface.c(gfc_extend_expr) because there is no way in
5225 which the host association can be wrong. */
5226 if (e
->symtree
== NULL
5227 || e
->symtree
->n
.sym
== NULL
5228 || e
->user_operator
)
5231 old_sym
= e
->symtree
->n
.sym
;
5233 if (gfc_current_ns
->parent
5234 && old_sym
->ns
!= gfc_current_ns
)
5236 /* Use the 'USE' name so that renamed module symbols are
5237 correctly handled. */
5238 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5240 if (sym
&& old_sym
!= sym
5241 && sym
->ts
.type
== old_sym
->ts
.type
5242 && sym
->attr
.flavor
== FL_PROCEDURE
5243 && sym
->attr
.contained
)
5245 /* Clear the shape, since it might not be valid. */
5246 gfc_free_shape (&e
->shape
, e
->rank
);
5248 /* Give the expression the right symtree! */
5249 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5250 gcc_assert (st
!= NULL
);
5252 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5253 || e
->expr_type
== EXPR_FUNCTION
)
5255 /* Original was function so point to the new symbol, since
5256 the actual argument list is already attached to the
5258 e
->value
.function
.esym
= NULL
;
5263 /* Original was variable so convert array references into
5264 an actual arglist. This does not need any checking now
5265 since resolve_function will take care of it. */
5266 e
->value
.function
.actual
= NULL
;
5267 e
->expr_type
= EXPR_FUNCTION
;
5270 /* Ambiguity will not arise if the array reference is not
5271 the last reference. */
5272 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5273 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5276 gcc_assert (ref
->type
== REF_ARRAY
);
5278 /* Grab the start expressions from the array ref and
5279 copy them into actual arguments. */
5280 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5282 arg
= gfc_get_actual_arglist ();
5283 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5284 if (e
->value
.function
.actual
== NULL
)
5285 tail
= e
->value
.function
.actual
= arg
;
5293 /* Dump the reference list and set the rank. */
5294 gfc_free_ref_list (e
->ref
);
5296 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5299 gfc_resolve_expr (e
);
5303 /* This might have changed! */
5304 return e
->expr_type
== EXPR_FUNCTION
;
5309 gfc_resolve_character_operator (gfc_expr
*e
)
5311 gfc_expr
*op1
= e
->value
.op
.op1
;
5312 gfc_expr
*op2
= e
->value
.op
.op2
;
5313 gfc_expr
*e1
= NULL
;
5314 gfc_expr
*e2
= NULL
;
5316 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5318 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5319 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5320 else if (op1
->expr_type
== EXPR_CONSTANT
)
5321 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5322 op1
->value
.character
.length
);
5324 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5325 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5326 else if (op2
->expr_type
== EXPR_CONSTANT
)
5327 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5328 op2
->value
.character
.length
);
5330 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5335 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5336 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5337 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5338 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5339 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5345 /* Ensure that an character expression has a charlen and, if possible, a
5346 length expression. */
5349 fixup_charlen (gfc_expr
*e
)
5351 /* The cases fall through so that changes in expression type and the need
5352 for multiple fixes are picked up. In all circumstances, a charlen should
5353 be available for the middle end to hang a backend_decl on. */
5354 switch (e
->expr_type
)
5357 gfc_resolve_character_operator (e
);
5360 if (e
->expr_type
== EXPR_ARRAY
)
5361 gfc_resolve_character_array_constructor (e
);
5363 case EXPR_SUBSTRING
:
5364 if (!e
->ts
.u
.cl
&& e
->ref
)
5365 gfc_resolve_substring_charlen (e
);
5369 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5376 /* Update an actual argument to include the passed-object for type-bound
5377 procedures at the right position. */
5379 static gfc_actual_arglist
*
5380 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5383 gcc_assert (argpos
> 0);
5387 gfc_actual_arglist
* result
;
5389 result
= gfc_get_actual_arglist ();
5393 result
->name
= name
;
5399 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5401 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5406 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5409 extract_compcall_passed_object (gfc_expr
* e
)
5413 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5415 if (e
->value
.compcall
.base_object
)
5416 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5419 po
= gfc_get_expr ();
5420 po
->expr_type
= EXPR_VARIABLE
;
5421 po
->symtree
= e
->symtree
;
5422 po
->ref
= gfc_copy_ref (e
->ref
);
5423 po
->where
= e
->where
;
5426 if (gfc_resolve_expr (po
) == FAILURE
)
5433 /* Update the arglist of an EXPR_COMPCALL expression to include the
5437 update_compcall_arglist (gfc_expr
* e
)
5440 gfc_typebound_proc
* tbp
;
5442 tbp
= e
->value
.compcall
.tbp
;
5447 po
= extract_compcall_passed_object (e
);
5451 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5457 gcc_assert (tbp
->pass_arg_num
> 0);
5458 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5466 /* Extract the passed object from a PPC call (a copy of it). */
5469 extract_ppc_passed_object (gfc_expr
*e
)
5474 po
= gfc_get_expr ();
5475 po
->expr_type
= EXPR_VARIABLE
;
5476 po
->symtree
= e
->symtree
;
5477 po
->ref
= gfc_copy_ref (e
->ref
);
5478 po
->where
= e
->where
;
5480 /* Remove PPC reference. */
5482 while ((*ref
)->next
)
5483 ref
= &(*ref
)->next
;
5484 gfc_free_ref_list (*ref
);
5487 if (gfc_resolve_expr (po
) == FAILURE
)
5494 /* Update the actual arglist of a procedure pointer component to include the
5498 update_ppc_arglist (gfc_expr
* e
)
5502 gfc_typebound_proc
* tb
;
5504 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5511 else if (tb
->nopass
)
5514 po
= extract_ppc_passed_object (e
);
5521 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5526 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5528 gfc_error ("Base object for procedure-pointer component call at %L is of"
5529 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5533 gcc_assert (tb
->pass_arg_num
> 0);
5534 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5542 /* Check that the object a TBP is called on is valid, i.e. it must not be
5543 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5546 check_typebound_baseobject (gfc_expr
* e
)
5549 gfc_try return_value
= FAILURE
;
5551 base
= extract_compcall_passed_object (e
);
5555 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5558 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5560 gfc_error ("Base object for type-bound procedure call at %L is of"
5561 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5565 /* F08:C1230. If the procedure called is NOPASS,
5566 the base object must be scalar. */
5567 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5569 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5570 " be scalar", &e
->where
);
5574 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5577 gfc_error ("Non-scalar base object at %L currently not implemented",
5582 return_value
= SUCCESS
;
5585 gfc_free_expr (base
);
5586 return return_value
;
5590 /* Resolve a call to a type-bound procedure, either function or subroutine,
5591 statically from the data in an EXPR_COMPCALL expression. The adapted
5592 arglist and the target-procedure symtree are returned. */
5595 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5596 gfc_actual_arglist
** actual
)
5598 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5599 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5601 /* Update the actual arglist for PASS. */
5602 if (update_compcall_arglist (e
) == FAILURE
)
5605 *actual
= e
->value
.compcall
.actual
;
5606 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5608 gfc_free_ref_list (e
->ref
);
5610 e
->value
.compcall
.actual
= NULL
;
5616 /* Get the ultimate declared type from an expression. In addition,
5617 return the last class/derived type reference and the copy of the
5620 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5623 gfc_symbol
*declared
;
5630 *new_ref
= gfc_copy_ref (e
->ref
);
5632 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5634 if (ref
->type
!= REF_COMPONENT
)
5637 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5638 || ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5640 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5646 if (declared
== NULL
)
5647 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5653 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5654 which of the specific bindings (if any) matches the arglist and transform
5655 the expression into a call of that binding. */
5658 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5660 gfc_typebound_proc
* genproc
;
5661 const char* genname
;
5663 gfc_symbol
*derived
;
5665 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5666 genname
= e
->value
.compcall
.name
;
5667 genproc
= e
->value
.compcall
.tbp
;
5669 if (!genproc
->is_generic
)
5672 /* Try the bindings on this type and in the inheritance hierarchy. */
5673 for (; genproc
; genproc
= genproc
->overridden
)
5677 gcc_assert (genproc
->is_generic
);
5678 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5681 gfc_actual_arglist
* args
;
5684 gcc_assert (g
->specific
);
5686 if (g
->specific
->error
)
5689 target
= g
->specific
->u
.specific
->n
.sym
;
5691 /* Get the right arglist by handling PASS/NOPASS. */
5692 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5693 if (!g
->specific
->nopass
)
5696 po
= extract_compcall_passed_object (e
);
5700 gcc_assert (g
->specific
->pass_arg_num
> 0);
5701 gcc_assert (!g
->specific
->error
);
5702 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5703 g
->specific
->pass_arg
);
5705 resolve_actual_arglist (args
, target
->attr
.proc
,
5706 is_external_proc (target
) && !target
->formal
);
5708 /* Check if this arglist matches the formal. */
5709 matches
= gfc_arglist_matches_symbol (&args
, target
);
5711 /* Clean up and break out of the loop if we've found it. */
5712 gfc_free_actual_arglist (args
);
5715 e
->value
.compcall
.tbp
= g
->specific
;
5716 genname
= g
->specific_st
->name
;
5717 /* Pass along the name for CLASS methods, where the vtab
5718 procedure pointer component has to be referenced. */
5726 /* Nothing matching found! */
5727 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5728 " '%s' at %L", genname
, &e
->where
);
5732 /* Make sure that we have the right specific instance for the name. */
5733 derived
= get_declared_from_expr (NULL
, NULL
, e
);
5735 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5737 e
->value
.compcall
.tbp
= st
->n
.tb
;
5743 /* Resolve a call to a type-bound subroutine. */
5746 resolve_typebound_call (gfc_code
* c
, const char **name
)
5748 gfc_actual_arglist
* newactual
;
5749 gfc_symtree
* target
;
5751 /* Check that's really a SUBROUTINE. */
5752 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5754 gfc_error ("'%s' at %L should be a SUBROUTINE",
5755 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5759 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5762 /* Pass along the name for CLASS methods, where the vtab
5763 procedure pointer component has to be referenced. */
5765 *name
= c
->expr1
->value
.compcall
.name
;
5767 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5770 /* Transform into an ordinary EXEC_CALL for now. */
5772 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5775 c
->ext
.actual
= newactual
;
5776 c
->symtree
= target
;
5777 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5779 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5781 gfc_free_expr (c
->expr1
);
5782 c
->expr1
= gfc_get_expr ();
5783 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5784 c
->expr1
->symtree
= target
;
5785 c
->expr1
->where
= c
->loc
;
5787 return resolve_call (c
);
5791 /* Resolve a component-call expression. */
5793 resolve_compcall (gfc_expr
* e
, const char **name
)
5795 gfc_actual_arglist
* newactual
;
5796 gfc_symtree
* target
;
5798 /* Check that's really a FUNCTION. */
5799 if (!e
->value
.compcall
.tbp
->function
)
5801 gfc_error ("'%s' at %L should be a FUNCTION",
5802 e
->value
.compcall
.name
, &e
->where
);
5806 /* These must not be assign-calls! */
5807 gcc_assert (!e
->value
.compcall
.assign
);
5809 if (check_typebound_baseobject (e
) == FAILURE
)
5812 /* Pass along the name for CLASS methods, where the vtab
5813 procedure pointer component has to be referenced. */
5815 *name
= e
->value
.compcall
.name
;
5817 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5819 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5821 /* Take the rank from the function's symbol. */
5822 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5823 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5825 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5826 arglist to the TBP's binding target. */
5828 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5831 e
->value
.function
.actual
= newactual
;
5832 e
->value
.function
.name
= NULL
;
5833 e
->value
.function
.esym
= target
->n
.sym
;
5834 e
->value
.function
.isym
= NULL
;
5835 e
->symtree
= target
;
5836 e
->ts
= target
->n
.sym
->ts
;
5837 e
->expr_type
= EXPR_FUNCTION
;
5839 /* Resolution is not necessary if this is a class subroutine; this
5840 function only has to identify the specific proc. Resolution of
5841 the call will be done next in resolve_typebound_call. */
5842 return gfc_resolve_expr (e
);
5847 /* Resolve a typebound function, or 'method'. First separate all
5848 the non-CLASS references by calling resolve_compcall directly. */
5851 resolve_typebound_function (gfc_expr
* e
)
5853 gfc_symbol
*declared
;
5864 /* Deal with typebound operators for CLASS objects. */
5865 expr
= e
->value
.compcall
.base_object
;
5866 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5868 /* Since the typebound operators are generic, we have to ensure
5869 that any delays in resolution are corrected and that the vtab
5872 declared
= ts
.u
.derived
;
5873 c
= gfc_find_component (declared
, "_vptr", true, true);
5874 if (c
->ts
.u
.derived
== NULL
)
5875 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5877 if (resolve_compcall (e
, &name
) == FAILURE
)
5880 /* Use the generic name if it is there. */
5881 name
= name
? name
: e
->value
.function
.esym
->name
;
5882 e
->symtree
= expr
->symtree
;
5883 e
->ref
= gfc_copy_ref (expr
->ref
);
5884 gfc_add_vptr_component (e
);
5885 gfc_add_component_ref (e
, name
);
5886 e
->value
.function
.esym
= NULL
;
5891 return resolve_compcall (e
, NULL
);
5893 if (resolve_ref (e
) == FAILURE
)
5896 /* Get the CLASS declared type. */
5897 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
);
5899 /* Weed out cases of the ultimate component being a derived type. */
5900 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5901 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5903 gfc_free_ref_list (new_ref
);
5904 return resolve_compcall (e
, NULL
);
5907 c
= gfc_find_component (declared
, "_data", true, true);
5908 declared
= c
->ts
.u
.derived
;
5910 /* Treat the call as if it is a typebound procedure, in order to roll
5911 out the correct name for the specific function. */
5912 if (resolve_compcall (e
, &name
) == FAILURE
)
5916 /* Then convert the expression to a procedure pointer component call. */
5917 e
->value
.function
.esym
= NULL
;
5923 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5924 gfc_add_vptr_component (e
);
5925 gfc_add_component_ref (e
, name
);
5927 /* Recover the typespec for the expression. This is really only
5928 necessary for generic procedures, where the additional call
5929 to gfc_add_component_ref seems to throw the collection of the
5930 correct typespec. */
5935 /* Resolve a typebound subroutine, or 'method'. First separate all
5936 the non-CLASS references by calling resolve_typebound_call
5940 resolve_typebound_subroutine (gfc_code
*code
)
5942 gfc_symbol
*declared
;
5951 st
= code
->expr1
->symtree
;
5953 /* Deal with typebound operators for CLASS objects. */
5954 expr
= code
->expr1
->value
.compcall
.base_object
;
5955 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5957 /* Since the typebound operators are generic, we have to ensure
5958 that any delays in resolution are corrected and that the vtab
5960 declared
= expr
->ts
.u
.derived
;
5961 c
= gfc_find_component (declared
, "_vptr", true, true);
5962 if (c
->ts
.u
.derived
== NULL
)
5963 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5965 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5968 /* Use the generic name if it is there. */
5969 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5970 code
->expr1
->symtree
= expr
->symtree
;
5971 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5972 gfc_add_vptr_component (code
->expr1
);
5973 gfc_add_component_ref (code
->expr1
, name
);
5974 code
->expr1
->value
.function
.esym
= NULL
;
5979 return resolve_typebound_call (code
, NULL
);
5981 if (resolve_ref (code
->expr1
) == FAILURE
)
5984 /* Get the CLASS declared type. */
5985 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
);
5987 /* Weed out cases of the ultimate component being a derived type. */
5988 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5989 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5991 gfc_free_ref_list (new_ref
);
5992 return resolve_typebound_call (code
, NULL
);
5995 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5997 ts
= code
->expr1
->ts
;
5999 /* Then convert the expression to a procedure pointer component call. */
6000 code
->expr1
->value
.function
.esym
= NULL
;
6001 code
->expr1
->symtree
= st
;
6004 code
->expr1
->ref
= new_ref
;
6006 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6007 gfc_add_vptr_component (code
->expr1
);
6008 gfc_add_component_ref (code
->expr1
, name
);
6010 /* Recover the typespec for the expression. This is really only
6011 necessary for generic procedures, where the additional call
6012 to gfc_add_component_ref seems to throw the collection of the
6013 correct typespec. */
6014 code
->expr1
->ts
= ts
;
6019 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6022 resolve_ppc_call (gfc_code
* c
)
6024 gfc_component
*comp
;
6027 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6030 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6031 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6033 if (!comp
->attr
.subroutine
)
6034 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6036 if (resolve_ref (c
->expr1
) == FAILURE
)
6039 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6042 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6044 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6045 comp
->formal
== NULL
) == FAILURE
)
6048 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6054 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6057 resolve_expr_ppc (gfc_expr
* e
)
6059 gfc_component
*comp
;
6062 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6065 /* Convert to EXPR_FUNCTION. */
6066 e
->expr_type
= EXPR_FUNCTION
;
6067 e
->value
.function
.isym
= NULL
;
6068 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6070 if (comp
->as
!= NULL
)
6071 e
->rank
= comp
->as
->rank
;
6073 if (!comp
->attr
.function
)
6074 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6076 if (resolve_ref (e
) == FAILURE
)
6079 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6080 comp
->formal
== NULL
) == FAILURE
)
6083 if (update_ppc_arglist (e
) == FAILURE
)
6086 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6093 gfc_is_expandable_expr (gfc_expr
*e
)
6095 gfc_constructor
*con
;
6097 if (e
->expr_type
== EXPR_ARRAY
)
6099 /* Traverse the constructor looking for variables that are flavor
6100 parameter. Parameters must be expanded since they are fully used at
6102 con
= gfc_constructor_first (e
->value
.constructor
);
6103 for (; con
; con
= gfc_constructor_next (con
))
6105 if (con
->expr
->expr_type
== EXPR_VARIABLE
6106 && con
->expr
->symtree
6107 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6108 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6110 if (con
->expr
->expr_type
== EXPR_ARRAY
6111 && gfc_is_expandable_expr (con
->expr
))
6119 /* Resolve an expression. That is, make sure that types of operands agree
6120 with their operators, intrinsic operators are converted to function calls
6121 for overloaded types and unresolved function references are resolved. */
6124 gfc_resolve_expr (gfc_expr
*e
)
6132 /* inquiry_argument only applies to variables. */
6133 inquiry_save
= inquiry_argument
;
6134 if (e
->expr_type
!= EXPR_VARIABLE
)
6135 inquiry_argument
= false;
6137 switch (e
->expr_type
)
6140 t
= resolve_operator (e
);
6146 if (check_host_association (e
))
6147 t
= resolve_function (e
);
6150 t
= resolve_variable (e
);
6152 expression_rank (e
);
6155 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6156 && e
->ref
->type
!= REF_SUBSTRING
)
6157 gfc_resolve_substring_charlen (e
);
6162 t
= resolve_typebound_function (e
);
6165 case EXPR_SUBSTRING
:
6166 t
= resolve_ref (e
);
6175 t
= resolve_expr_ppc (e
);
6180 if (resolve_ref (e
) == FAILURE
)
6183 t
= gfc_resolve_array_constructor (e
);
6184 /* Also try to expand a constructor. */
6187 expression_rank (e
);
6188 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6189 gfc_expand_constructor (e
, false);
6192 /* This provides the opportunity for the length of constructors with
6193 character valued function elements to propagate the string length
6194 to the expression. */
6195 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6197 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6198 here rather then add a duplicate test for it above. */
6199 gfc_expand_constructor (e
, false);
6200 t
= gfc_resolve_character_array_constructor (e
);
6205 case EXPR_STRUCTURE
:
6206 t
= resolve_ref (e
);
6210 t
= resolve_structure_cons (e
, 0);
6214 t
= gfc_simplify_expr (e
, 0);
6218 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6221 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6224 inquiry_argument
= inquiry_save
;
6230 /* Resolve an expression from an iterator. They must be scalar and have
6231 INTEGER or (optionally) REAL type. */
6234 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6235 const char *name_msgid
)
6237 if (gfc_resolve_expr (expr
) == FAILURE
)
6240 if (expr
->rank
!= 0)
6242 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6246 if (expr
->ts
.type
!= BT_INTEGER
)
6248 if (expr
->ts
.type
== BT_REAL
)
6251 return gfc_notify_std (GFC_STD_F95_DEL
,
6252 "Deleted feature: %s at %L must be integer",
6253 _(name_msgid
), &expr
->where
);
6256 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6263 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6271 /* Resolve the expressions in an iterator structure. If REAL_OK is
6272 false allow only INTEGER type iterators, otherwise allow REAL types. */
6275 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6277 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6281 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6285 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6286 "Start expression in DO loop") == FAILURE
)
6289 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6290 "End expression in DO loop") == FAILURE
)
6293 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6294 "Step expression in DO loop") == FAILURE
)
6297 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6299 if ((iter
->step
->ts
.type
== BT_INTEGER
6300 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6301 || (iter
->step
->ts
.type
== BT_REAL
6302 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6304 gfc_error ("Step expression in DO loop at %L cannot be zero",
6305 &iter
->step
->where
);
6310 /* Convert start, end, and step to the same type as var. */
6311 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6312 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6313 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6315 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6316 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6317 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6319 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6320 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6321 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6323 if (iter
->start
->expr_type
== EXPR_CONSTANT
6324 && iter
->end
->expr_type
== EXPR_CONSTANT
6325 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6328 if (iter
->start
->ts
.type
== BT_INTEGER
)
6330 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6331 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6335 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6336 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6338 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6339 gfc_warning ("DO loop at %L will be executed zero times",
6340 &iter
->step
->where
);
6347 /* Traversal function for find_forall_index. f == 2 signals that
6348 that variable itself is not to be checked - only the references. */
6351 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6353 if (expr
->expr_type
!= EXPR_VARIABLE
)
6356 /* A scalar assignment */
6357 if (!expr
->ref
|| *f
== 1)
6359 if (expr
->symtree
->n
.sym
== sym
)
6371 /* Check whether the FORALL index appears in the expression or not.
6372 Returns SUCCESS if SYM is found in EXPR. */
6375 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6377 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6384 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6385 to be a scalar INTEGER variable. The subscripts and stride are scalar
6386 INTEGERs, and if stride is a constant it must be nonzero.
6387 Furthermore "A subscript or stride in a forall-triplet-spec shall
6388 not contain a reference to any index-name in the
6389 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6392 resolve_forall_iterators (gfc_forall_iterator
*it
)
6394 gfc_forall_iterator
*iter
, *iter2
;
6396 for (iter
= it
; iter
; iter
= iter
->next
)
6398 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6399 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6400 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6403 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6404 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6405 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6406 &iter
->start
->where
);
6407 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6408 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6410 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6411 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6412 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6414 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6415 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6417 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6419 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6420 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6421 &iter
->stride
->where
, "INTEGER");
6423 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6424 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6425 gfc_error ("FORALL stride expression at %L cannot be zero",
6426 &iter
->stride
->where
);
6428 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6429 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
6432 for (iter
= it
; iter
; iter
= iter
->next
)
6433 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6435 if (find_forall_index (iter2
->start
,
6436 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6437 || find_forall_index (iter2
->end
,
6438 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6439 || find_forall_index (iter2
->stride
,
6440 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6441 gfc_error ("FORALL index '%s' may not appear in triplet "
6442 "specification at %L", iter
->var
->symtree
->name
,
6443 &iter2
->start
->where
);
6448 /* Given a pointer to a symbol that is a derived type, see if it's
6449 inaccessible, i.e. if it's defined in another module and the components are
6450 PRIVATE. The search is recursive if necessary. Returns zero if no
6451 inaccessible components are found, nonzero otherwise. */
6454 derived_inaccessible (gfc_symbol
*sym
)
6458 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6461 for (c
= sym
->components
; c
; c
= c
->next
)
6463 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6471 /* Resolve the argument of a deallocate expression. The expression must be
6472 a pointer or a full array. */
6475 resolve_deallocate_expr (gfc_expr
*e
)
6477 symbol_attribute attr
;
6478 int allocatable
, pointer
;
6483 if (gfc_resolve_expr (e
) == FAILURE
)
6486 if (e
->expr_type
!= EXPR_VARIABLE
)
6489 sym
= e
->symtree
->n
.sym
;
6491 if (sym
->ts
.type
== BT_CLASS
)
6493 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6494 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6498 allocatable
= sym
->attr
.allocatable
;
6499 pointer
= sym
->attr
.pointer
;
6501 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6506 if (ref
->u
.ar
.type
!= AR_FULL
6507 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6508 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6513 c
= ref
->u
.c
.component
;
6514 if (c
->ts
.type
== BT_CLASS
)
6516 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6517 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6521 allocatable
= c
->attr
.allocatable
;
6522 pointer
= c
->attr
.pointer
;
6532 attr
= gfc_expr_attr (e
);
6534 if (allocatable
== 0 && attr
.pointer
== 0)
6537 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6543 if (gfc_is_coindexed (e
))
6545 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6550 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6553 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6561 /* Returns true if the expression e contains a reference to the symbol sym. */
6563 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6565 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6572 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6574 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6578 /* Given the expression node e for an allocatable/pointer of derived type to be
6579 allocated, get the expression node to be initialized afterwards (needed for
6580 derived types with default initializers, and derived types with allocatable
6581 components that need nullification.) */
6584 gfc_expr_to_initialize (gfc_expr
*e
)
6590 result
= gfc_copy_expr (e
);
6592 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6593 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6594 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6596 ref
->u
.ar
.type
= AR_FULL
;
6598 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6599 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6604 gfc_free_shape (&result
->shape
, result
->rank
);
6606 /* Recalculate rank, shape, etc. */
6607 gfc_resolve_expr (result
);
6612 /* If the last ref of an expression is an array ref, return a copy of the
6613 expression with that one removed. Otherwise, a copy of the original
6614 expression. This is used for allocate-expressions and pointer assignment
6615 LHS, where there may be an array specification that needs to be stripped
6616 off when using gfc_check_vardef_context. */
6619 remove_last_array_ref (gfc_expr
* e
)
6624 e2
= gfc_copy_expr (e
);
6625 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6626 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6628 gfc_free_ref_list (*r
);
6637 /* Used in resolve_allocate_expr to check that a allocation-object and
6638 a source-expr are conformable. This does not catch all possible
6639 cases; in particular a runtime checking is needed. */
6642 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6645 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6647 /* First compare rank. */
6648 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6650 gfc_error ("Source-expr at %L must be scalar or have the "
6651 "same rank as the allocate-object at %L",
6652 &e1
->where
, &e2
->where
);
6663 for (i
= 0; i
< e1
->rank
; i
++)
6665 if (tail
->u
.ar
.end
[i
])
6667 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6668 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6669 mpz_add_ui (s
, s
, 1);
6673 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6676 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6678 gfc_error ("Source-expr at %L and allocate-object at %L must "
6679 "have the same shape", &e1
->where
, &e2
->where
);
6692 /* Resolve the expression in an ALLOCATE statement, doing the additional
6693 checks to see whether the expression is OK or not. The expression must
6694 have a trailing array reference that gives the size of the array. */
6697 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6699 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6702 symbol_attribute attr
;
6703 gfc_ref
*ref
, *ref2
;
6706 gfc_symbol
*sym
= NULL
;
6711 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6712 checking of coarrays. */
6713 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6714 if (ref
->next
== NULL
)
6717 if (ref
&& ref
->type
== REF_ARRAY
)
6718 ref
->u
.ar
.in_allocate
= true;
6720 if (gfc_resolve_expr (e
) == FAILURE
)
6723 /* Make sure the expression is allocatable or a pointer. If it is
6724 pointer, the next-to-last reference must be a pointer. */
6728 sym
= e
->symtree
->n
.sym
;
6730 /* Check whether ultimate component is abstract and CLASS. */
6733 if (e
->expr_type
!= EXPR_VARIABLE
)
6736 attr
= gfc_expr_attr (e
);
6737 pointer
= attr
.pointer
;
6738 dimension
= attr
.dimension
;
6739 codimension
= attr
.codimension
;
6743 if (sym
->ts
.type
== BT_CLASS
)
6745 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6746 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6747 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6748 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6749 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6753 allocatable
= sym
->attr
.allocatable
;
6754 pointer
= sym
->attr
.pointer
;
6755 dimension
= sym
->attr
.dimension
;
6756 codimension
= sym
->attr
.codimension
;
6761 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6766 if (ref
->u
.ar
.codimen
> 0)
6769 for (n
= ref
->u
.ar
.dimen
;
6770 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6771 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6778 if (ref
->next
!= NULL
)
6786 gfc_error ("Coindexed allocatable object at %L",
6791 c
= ref
->u
.c
.component
;
6792 if (c
->ts
.type
== BT_CLASS
)
6794 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6795 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6796 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6797 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6798 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6802 allocatable
= c
->attr
.allocatable
;
6803 pointer
= c
->attr
.pointer
;
6804 dimension
= c
->attr
.dimension
;
6805 codimension
= c
->attr
.codimension
;
6806 is_abstract
= c
->attr
.abstract
;
6818 if (allocatable
== 0 && pointer
== 0)
6820 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6825 /* Some checks for the SOURCE tag. */
6828 /* Check F03:C631. */
6829 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6831 gfc_error ("Type of entity at %L is type incompatible with "
6832 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6836 /* Check F03:C632 and restriction following Note 6.18. */
6837 if (code
->expr3
->rank
> 0
6838 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
6841 /* Check F03:C633. */
6842 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
6844 gfc_error ("The allocate-object at %L and the source-expr at %L "
6845 "shall have the same kind type parameter",
6846 &e
->where
, &code
->expr3
->where
);
6850 /* Check F2008, C642. */
6851 if (code
->expr3
->ts
.type
== BT_DERIVED
6852 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6853 || (code
->expr3
->ts
.u
.derived
->from_intmod
6854 == INTMOD_ISO_FORTRAN_ENV
6855 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6856 == ISOFORTRAN_LOCK_TYPE
)))
6858 gfc_error ("The source-expr at %L shall neither be of type "
6859 "LOCK_TYPE nor have a LOCK_TYPE component if "
6860 "allocate-object at %L is a coarray",
6861 &code
->expr3
->where
, &e
->where
);
6866 /* Check F08:C629. */
6867 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6870 gcc_assert (e
->ts
.type
== BT_CLASS
);
6871 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6872 "type-spec or source-expr", sym
->name
, &e
->where
);
6876 /* In the variable definition context checks, gfc_expr_attr is used
6877 on the expression. This is fooled by the array specification
6878 present in e, thus we have to eliminate that one temporarily. */
6879 e2
= remove_last_array_ref (e
);
6881 if (t
== SUCCESS
&& pointer
)
6882 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
6884 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
6891 /* Set up default initializer if needed. */
6895 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6896 ts
= code
->ext
.alloc
.ts
;
6900 if (ts
.type
== BT_CLASS
)
6901 ts
= ts
.u
.derived
->components
->ts
;
6903 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6905 gfc_code
*init_st
= gfc_get_code ();
6906 init_st
->loc
= code
->loc
;
6907 init_st
->op
= EXEC_INIT_ASSIGN
;
6908 init_st
->expr1
= gfc_expr_to_initialize (e
);
6909 init_st
->expr2
= init_e
;
6910 init_st
->next
= code
->next
;
6911 code
->next
= init_st
;
6914 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6916 /* Default initialization via MOLD (non-polymorphic). */
6917 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6918 gfc_resolve_expr (rhs
);
6919 gfc_free_expr (code
->expr3
);
6923 if (e
->ts
.type
== BT_CLASS
)
6925 /* Make sure the vtab symbol is present when
6926 the module variables are generated. */
6927 gfc_typespec ts
= e
->ts
;
6929 ts
= code
->expr3
->ts
;
6930 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6931 ts
= code
->ext
.alloc
.ts
;
6932 gfc_find_derived_vtab (ts
.u
.derived
);
6935 if (dimension
== 0 && codimension
== 0)
6938 /* Make sure the last reference node is an array specifiction. */
6940 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6941 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6943 gfc_error ("Array specification required in ALLOCATE statement "
6944 "at %L", &e
->where
);
6948 /* Make sure that the array section reference makes sense in the
6949 context of an ALLOCATE specification. */
6954 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6955 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6957 gfc_error ("Coarray specification required in ALLOCATE statement "
6958 "at %L", &e
->where
);
6962 for (i
= 0; i
< ar
->dimen
; i
++)
6964 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6967 switch (ar
->dimen_type
[i
])
6973 if (ar
->start
[i
] != NULL
6974 && ar
->end
[i
] != NULL
6975 && ar
->stride
[i
] == NULL
)
6978 /* Fall Through... */
6983 case DIMEN_THIS_IMAGE
:
6984 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6990 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6992 sym
= a
->expr
->symtree
->n
.sym
;
6994 /* TODO - check derived type components. */
6995 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6998 if ((ar
->start
[i
] != NULL
6999 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7000 || (ar
->end
[i
] != NULL
7001 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7003 gfc_error ("'%s' must not appear in the array specification at "
7004 "%L in the same ALLOCATE statement where it is "
7005 "itself allocated", sym
->name
, &ar
->where
);
7011 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7013 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7014 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7016 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7018 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7019 "statement at %L", &e
->where
);
7025 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7026 && ar
->stride
[i
] == NULL
)
7029 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7042 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7044 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7045 gfc_alloc
*a
, *p
, *q
;
7048 errmsg
= code
->expr2
;
7050 /* Check the stat variable. */
7053 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7055 if ((stat
->ts
.type
!= BT_INTEGER
7056 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7057 || stat
->ref
->type
== REF_COMPONENT
)))
7059 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7060 "variable", &stat
->where
);
7062 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7063 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7065 gfc_ref
*ref1
, *ref2
;
7068 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7069 ref1
= ref1
->next
, ref2
= ref2
->next
)
7071 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7073 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7082 gfc_error ("Stat-variable at %L shall not be %sd within "
7083 "the same %s statement", &stat
->where
, fcn
, fcn
);
7089 /* Check the errmsg variable. */
7093 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7096 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7098 if ((errmsg
->ts
.type
!= BT_CHARACTER
7100 && (errmsg
->ref
->type
== REF_ARRAY
7101 || errmsg
->ref
->type
== REF_COMPONENT
)))
7102 || errmsg
->rank
> 0 )
7103 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7104 "variable", &errmsg
->where
);
7106 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7107 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7109 gfc_ref
*ref1
, *ref2
;
7112 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7113 ref1
= ref1
->next
, ref2
= ref2
->next
)
7115 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7117 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7126 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7127 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7133 /* Check that an allocate-object appears only once in the statement.
7134 FIXME: Checking derived types is disabled. */
7135 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7138 for (q
= p
->next
; q
; q
= q
->next
)
7141 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7143 /* This is a potential collision. */
7144 gfc_ref
*pr
= pe
->ref
;
7145 gfc_ref
*qr
= qe
->ref
;
7147 /* Follow the references until
7148 a) They start to differ, in which case there is no error;
7149 you can deallocate a%b and a%c in a single statement
7150 b) Both of them stop, which is an error
7151 c) One of them stops, which is also an error. */
7154 if (pr
== NULL
&& qr
== NULL
)
7156 gfc_error ("Allocate-object at %L also appears at %L",
7157 &pe
->where
, &qe
->where
);
7160 else if (pr
!= NULL
&& qr
== NULL
)
7162 gfc_error ("Allocate-object at %L is subobject of"
7163 " object at %L", &pe
->where
, &qe
->where
);
7166 else if (pr
== NULL
&& qr
!= NULL
)
7168 gfc_error ("Allocate-object at %L is subobject of"
7169 " object at %L", &qe
->where
, &pe
->where
);
7172 /* Here, pr != NULL && qr != NULL */
7173 gcc_assert(pr
->type
== qr
->type
);
7174 if (pr
->type
== REF_ARRAY
)
7176 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7178 gcc_assert (qr
->type
== REF_ARRAY
);
7180 if (pr
->next
&& qr
->next
)
7182 gfc_array_ref
*par
= &(pr
->u
.ar
);
7183 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7184 if (gfc_dep_compare_expr (par
->start
[0],
7185 qar
->start
[0]) != 0)
7191 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7202 if (strcmp (fcn
, "ALLOCATE") == 0)
7204 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7205 resolve_allocate_expr (a
->expr
, code
);
7209 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7210 resolve_deallocate_expr (a
->expr
);
7215 /************ SELECT CASE resolution subroutines ************/
7217 /* Callback function for our mergesort variant. Determines interval
7218 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7219 op1 > op2. Assumes we're not dealing with the default case.
7220 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7221 There are nine situations to check. */
7224 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7228 if (op1
->low
== NULL
) /* op1 = (:L) */
7230 /* op2 = (:N), so overlap. */
7232 /* op2 = (M:) or (M:N), L < M */
7233 if (op2
->low
!= NULL
7234 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7237 else if (op1
->high
== NULL
) /* op1 = (K:) */
7239 /* op2 = (M:), so overlap. */
7241 /* op2 = (:N) or (M:N), K > N */
7242 if (op2
->high
!= NULL
7243 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7246 else /* op1 = (K:L) */
7248 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7249 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7251 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7252 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7254 else /* op2 = (M:N) */
7258 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7261 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7270 /* Merge-sort a double linked case list, detecting overlap in the
7271 process. LIST is the head of the double linked case list before it
7272 is sorted. Returns the head of the sorted list if we don't see any
7273 overlap, or NULL otherwise. */
7276 check_case_overlap (gfc_case
*list
)
7278 gfc_case
*p
, *q
, *e
, *tail
;
7279 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7281 /* If the passed list was empty, return immediately. */
7288 /* Loop unconditionally. The only exit from this loop is a return
7289 statement, when we've finished sorting the case list. */
7296 /* Count the number of merges we do in this pass. */
7299 /* Loop while there exists a merge to be done. */
7304 /* Count this merge. */
7307 /* Cut the list in two pieces by stepping INSIZE places
7308 forward in the list, starting from P. */
7311 for (i
= 0; i
< insize
; i
++)
7320 /* Now we have two lists. Merge them! */
7321 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7323 /* See from which the next case to merge comes from. */
7326 /* P is empty so the next case must come from Q. */
7331 else if (qsize
== 0 || q
== NULL
)
7340 cmp
= compare_cases (p
, q
);
7343 /* The whole case range for P is less than the
7351 /* The whole case range for Q is greater than
7352 the case range for P. */
7359 /* The cases overlap, or they are the same
7360 element in the list. Either way, we must
7361 issue an error and get the next case from P. */
7362 /* FIXME: Sort P and Q by line number. */
7363 gfc_error ("CASE label at %L overlaps with CASE "
7364 "label at %L", &p
->where
, &q
->where
);
7372 /* Add the next element to the merged list. */
7381 /* P has now stepped INSIZE places along, and so has Q. So
7382 they're the same. */
7387 /* If we have done only one merge or none at all, we've
7388 finished sorting the cases. */
7397 /* Otherwise repeat, merging lists twice the size. */
7403 /* Check to see if an expression is suitable for use in a CASE statement.
7404 Makes sure that all case expressions are scalar constants of the same
7405 type. Return FAILURE if anything is wrong. */
7408 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7410 if (e
== NULL
) return SUCCESS
;
7412 if (e
->ts
.type
!= case_expr
->ts
.type
)
7414 gfc_error ("Expression in CASE statement at %L must be of type %s",
7415 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7419 /* C805 (R808) For a given case-construct, each case-value shall be of
7420 the same type as case-expr. For character type, length differences
7421 are allowed, but the kind type parameters shall be the same. */
7423 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7425 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7426 &e
->where
, case_expr
->ts
.kind
);
7430 /* Convert the case value kind to that of case expression kind,
7433 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7434 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7438 gfc_error ("Expression in CASE statement at %L must be scalar",
7447 /* Given a completely parsed select statement, we:
7449 - Validate all expressions and code within the SELECT.
7450 - Make sure that the selection expression is not of the wrong type.
7451 - Make sure that no case ranges overlap.
7452 - Eliminate unreachable cases and unreachable code resulting from
7453 removing case labels.
7455 The standard does allow unreachable cases, e.g. CASE (5:3). But
7456 they are a hassle for code generation, and to prevent that, we just
7457 cut them out here. This is not necessary for overlapping cases
7458 because they are illegal and we never even try to generate code.
7460 We have the additional caveat that a SELECT construct could have
7461 been a computed GOTO in the source code. Fortunately we can fairly
7462 easily work around that here: The case_expr for a "real" SELECT CASE
7463 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7464 we have to do is make sure that the case_expr is a scalar integer
7468 resolve_select (gfc_code
*code
)
7471 gfc_expr
*case_expr
;
7472 gfc_case
*cp
, *default_case
, *tail
, *head
;
7473 int seen_unreachable
;
7479 if (code
->expr1
== NULL
)
7481 /* This was actually a computed GOTO statement. */
7482 case_expr
= code
->expr2
;
7483 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7484 gfc_error ("Selection expression in computed GOTO statement "
7485 "at %L must be a scalar integer expression",
7488 /* Further checking is not necessary because this SELECT was built
7489 by the compiler, so it should always be OK. Just move the
7490 case_expr from expr2 to expr so that we can handle computed
7491 GOTOs as normal SELECTs from here on. */
7492 code
->expr1
= code
->expr2
;
7497 case_expr
= code
->expr1
;
7499 type
= case_expr
->ts
.type
;
7500 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7502 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7503 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7505 /* Punt. Going on here just produce more garbage error messages. */
7509 if (case_expr
->rank
!= 0)
7511 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7512 "expression", &case_expr
->where
);
7519 /* Raise a warning if an INTEGER case value exceeds the range of
7520 the case-expr. Later, all expressions will be promoted to the
7521 largest kind of all case-labels. */
7523 if (type
== BT_INTEGER
)
7524 for (body
= code
->block
; body
; body
= body
->block
)
7525 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7528 && gfc_check_integer_range (cp
->low
->value
.integer
,
7529 case_expr
->ts
.kind
) != ARITH_OK
)
7530 gfc_warning ("Expression in CASE statement at %L is "
7531 "not in the range of %s", &cp
->low
->where
,
7532 gfc_typename (&case_expr
->ts
));
7535 && cp
->low
!= cp
->high
7536 && gfc_check_integer_range (cp
->high
->value
.integer
,
7537 case_expr
->ts
.kind
) != ARITH_OK
)
7538 gfc_warning ("Expression in CASE statement at %L is "
7539 "not in the range of %s", &cp
->high
->where
,
7540 gfc_typename (&case_expr
->ts
));
7543 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7544 of the SELECT CASE expression and its CASE values. Walk the lists
7545 of case values, and if we find a mismatch, promote case_expr to
7546 the appropriate kind. */
7548 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7550 for (body
= code
->block
; body
; body
= body
->block
)
7552 /* Walk the case label list. */
7553 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7555 /* Intercept the DEFAULT case. It does not have a kind. */
7556 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7559 /* Unreachable case ranges are discarded, so ignore. */
7560 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7561 && cp
->low
!= cp
->high
7562 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7566 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7567 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7569 if (cp
->high
!= NULL
7570 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7571 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7576 /* Assume there is no DEFAULT case. */
7577 default_case
= NULL
;
7582 for (body
= code
->block
; body
; body
= body
->block
)
7584 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7586 seen_unreachable
= 0;
7588 /* Walk the case label list, making sure that all case labels
7590 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7592 /* Count the number of cases in the whole construct. */
7595 /* Intercept the DEFAULT case. */
7596 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7598 if (default_case
!= NULL
)
7600 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7601 "by a second DEFAULT CASE at %L",
7602 &default_case
->where
, &cp
->where
);
7613 /* Deal with single value cases and case ranges. Errors are
7614 issued from the validation function. */
7615 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7616 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7622 if (type
== BT_LOGICAL
7623 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7624 || cp
->low
!= cp
->high
))
7626 gfc_error ("Logical range in CASE statement at %L is not "
7627 "allowed", &cp
->low
->where
);
7632 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7635 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7636 if (value
& seen_logical
)
7638 gfc_error ("Constant logical value in CASE statement "
7639 "is repeated at %L",
7644 seen_logical
|= value
;
7647 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7648 && cp
->low
!= cp
->high
7649 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7651 if (gfc_option
.warn_surprising
)
7652 gfc_warning ("Range specification at %L can never "
7653 "be matched", &cp
->where
);
7655 cp
->unreachable
= 1;
7656 seen_unreachable
= 1;
7660 /* If the case range can be matched, it can also overlap with
7661 other cases. To make sure it does not, we put it in a
7662 double linked list here. We sort that with a merge sort
7663 later on to detect any overlapping cases. */
7667 head
->right
= head
->left
= NULL
;
7672 tail
->right
->left
= tail
;
7679 /* It there was a failure in the previous case label, give up
7680 for this case label list. Continue with the next block. */
7684 /* See if any case labels that are unreachable have been seen.
7685 If so, we eliminate them. This is a bit of a kludge because
7686 the case lists for a single case statement (label) is a
7687 single forward linked lists. */
7688 if (seen_unreachable
)
7690 /* Advance until the first case in the list is reachable. */
7691 while (body
->ext
.block
.case_list
!= NULL
7692 && body
->ext
.block
.case_list
->unreachable
)
7694 gfc_case
*n
= body
->ext
.block
.case_list
;
7695 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7697 gfc_free_case_list (n
);
7700 /* Strip all other unreachable cases. */
7701 if (body
->ext
.block
.case_list
)
7703 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7705 if (cp
->next
->unreachable
)
7707 gfc_case
*n
= cp
->next
;
7708 cp
->next
= cp
->next
->next
;
7710 gfc_free_case_list (n
);
7717 /* See if there were overlapping cases. If the check returns NULL,
7718 there was overlap. In that case we don't do anything. If head
7719 is non-NULL, we prepend the DEFAULT case. The sorted list can
7720 then used during code generation for SELECT CASE constructs with
7721 a case expression of a CHARACTER type. */
7724 head
= check_case_overlap (head
);
7726 /* Prepend the default_case if it is there. */
7727 if (head
!= NULL
&& default_case
)
7729 default_case
->left
= NULL
;
7730 default_case
->right
= head
;
7731 head
->left
= default_case
;
7735 /* Eliminate dead blocks that may be the result if we've seen
7736 unreachable case labels for a block. */
7737 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7739 if (body
->block
->ext
.block
.case_list
== NULL
)
7741 /* Cut the unreachable block from the code chain. */
7742 gfc_code
*c
= body
->block
;
7743 body
->block
= c
->block
;
7745 /* Kill the dead block, but not the blocks below it. */
7747 gfc_free_statements (c
);
7751 /* More than two cases is legal but insane for logical selects.
7752 Issue a warning for it. */
7753 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7755 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7760 /* Check if a derived type is extensible. */
7763 gfc_type_is_extensible (gfc_symbol
*sym
)
7765 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7769 /* Resolve an associate name: Resolve target and ensure the type-spec is
7770 correct as well as possibly the array-spec. */
7773 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7777 gcc_assert (sym
->assoc
);
7778 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7780 /* If this is for SELECT TYPE, the target may not yet be set. In that
7781 case, return. Resolution will be called later manually again when
7783 target
= sym
->assoc
->target
;
7786 gcc_assert (!sym
->assoc
->dangling
);
7788 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7791 /* For variable targets, we get some attributes from the target. */
7792 if (target
->expr_type
== EXPR_VARIABLE
)
7796 gcc_assert (target
->symtree
);
7797 tsym
= target
->symtree
->n
.sym
;
7799 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7800 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7802 sym
->attr
.target
= (tsym
->attr
.target
|| tsym
->attr
.pointer
);
7805 /* Get type if this was not already set. Note that it can be
7806 some other type than the target in case this is a SELECT TYPE
7807 selector! So we must not update when the type is already there. */
7808 if (sym
->ts
.type
== BT_UNKNOWN
)
7809 sym
->ts
= target
->ts
;
7810 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7812 /* See if this is a valid association-to-variable. */
7813 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7814 && !gfc_has_vector_subscript (target
));
7816 /* Finally resolve if this is an array or not. */
7817 if (sym
->attr
.dimension
&& target
->rank
== 0)
7819 gfc_error ("Associate-name '%s' at %L is used as array",
7820 sym
->name
, &sym
->declared_at
);
7821 sym
->attr
.dimension
= 0;
7824 if (target
->rank
> 0)
7825 sym
->attr
.dimension
= 1;
7827 if (sym
->attr
.dimension
)
7829 sym
->as
= gfc_get_array_spec ();
7830 sym
->as
->rank
= target
->rank
;
7831 sym
->as
->type
= AS_DEFERRED
;
7833 /* Target must not be coindexed, thus the associate-variable
7835 sym
->as
->corank
= 0;
7840 /* Resolve a SELECT TYPE statement. */
7843 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7845 gfc_symbol
*selector_type
;
7846 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7847 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7850 char name
[GFC_MAX_SYMBOL_LEN
];
7854 ns
= code
->ext
.block
.ns
;
7857 /* Check for F03:C813. */
7858 if (code
->expr1
->ts
.type
!= BT_CLASS
7859 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7861 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7862 "at %L", &code
->loc
);
7868 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7869 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7870 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7873 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7875 /* Loop over TYPE IS / CLASS IS cases. */
7876 for (body
= code
->block
; body
; body
= body
->block
)
7878 c
= body
->ext
.block
.case_list
;
7880 /* Check F03:C815. */
7881 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7882 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7884 gfc_error ("Derived type '%s' at %L must be extensible",
7885 c
->ts
.u
.derived
->name
, &c
->where
);
7890 /* Check F03:C816. */
7891 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7892 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
7894 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7895 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7900 /* Intercept the DEFAULT case. */
7901 if (c
->ts
.type
== BT_UNKNOWN
)
7903 /* Check F03:C818. */
7906 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7907 "by a second DEFAULT CASE at %L",
7908 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7913 default_case
= body
;
7920 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7921 target if present. If there are any EXIT statements referring to the
7922 SELECT TYPE construct, this is no problem because the gfc_code
7923 reference stays the same and EXIT is equally possible from the BLOCK
7924 it is changed to. */
7925 code
->op
= EXEC_BLOCK
;
7928 gfc_association_list
* assoc
;
7930 assoc
= gfc_get_association_list ();
7931 assoc
->st
= code
->expr1
->symtree
;
7932 assoc
->target
= gfc_copy_expr (code
->expr2
);
7933 /* assoc->variable will be set by resolve_assoc_var. */
7935 code
->ext
.block
.assoc
= assoc
;
7936 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
7938 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
7941 code
->ext
.block
.assoc
= NULL
;
7943 /* Add EXEC_SELECT to switch on type. */
7944 new_st
= gfc_get_code ();
7945 new_st
->op
= code
->op
;
7946 new_st
->expr1
= code
->expr1
;
7947 new_st
->expr2
= code
->expr2
;
7948 new_st
->block
= code
->block
;
7949 code
->expr1
= code
->expr2
= NULL
;
7954 ns
->code
->next
= new_st
;
7956 code
->op
= EXEC_SELECT
;
7957 gfc_add_vptr_component (code
->expr1
);
7958 gfc_add_hash_component (code
->expr1
);
7960 /* Loop over TYPE IS / CLASS IS cases. */
7961 for (body
= code
->block
; body
; body
= body
->block
)
7963 c
= body
->ext
.block
.case_list
;
7965 if (c
->ts
.type
== BT_DERIVED
)
7966 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7967 c
->ts
.u
.derived
->hash_value
);
7969 else if (c
->ts
.type
== BT_UNKNOWN
)
7972 /* Associate temporary to selector. This should only be done
7973 when this case is actually true, so build a new ASSOCIATE
7974 that does precisely this here (instead of using the
7977 if (c
->ts
.type
== BT_CLASS
)
7978 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
7980 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
7981 st
= gfc_find_symtree (ns
->sym_root
, name
);
7982 gcc_assert (st
->n
.sym
->assoc
);
7983 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
7984 if (c
->ts
.type
== BT_DERIVED
)
7985 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
7987 new_st
= gfc_get_code ();
7988 new_st
->op
= EXEC_BLOCK
;
7989 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
7990 new_st
->ext
.block
.ns
->code
= body
->next
;
7991 body
->next
= new_st
;
7993 /* Chain in the new list only if it is marked as dangling. Otherwise
7994 there is a CASE label overlap and this is already used. Just ignore,
7995 the error is diagonsed elsewhere. */
7996 if (st
->n
.sym
->assoc
->dangling
)
7998 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
7999 st
->n
.sym
->assoc
->dangling
= 0;
8002 resolve_assoc_var (st
->n
.sym
, false);
8005 /* Take out CLASS IS cases for separate treatment. */
8007 while (body
&& body
->block
)
8009 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8011 /* Add to class_is list. */
8012 if (class_is
== NULL
)
8014 class_is
= body
->block
;
8019 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8020 tail
->block
= body
->block
;
8023 /* Remove from EXEC_SELECT list. */
8024 body
->block
= body
->block
->block
;
8037 /* Add a default case to hold the CLASS IS cases. */
8038 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8039 tail
->block
= gfc_get_code ();
8041 tail
->op
= EXEC_SELECT_TYPE
;
8042 tail
->ext
.block
.case_list
= gfc_get_case ();
8043 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8045 default_case
= tail
;
8048 /* More than one CLASS IS block? */
8049 if (class_is
->block
)
8053 /* Sort CLASS IS blocks by extension level. */
8057 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8060 /* F03:C817 (check for doubles). */
8061 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8062 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8064 gfc_error ("Double CLASS IS block in SELECT TYPE "
8066 &c2
->ext
.block
.case_list
->where
);
8069 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8070 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8073 (*c1
)->block
= c2
->block
;
8083 /* Generate IF chain. */
8084 if_st
= gfc_get_code ();
8085 if_st
->op
= EXEC_IF
;
8087 for (body
= class_is
; body
; body
= body
->block
)
8089 new_st
->block
= gfc_get_code ();
8090 new_st
= new_st
->block
;
8091 new_st
->op
= EXEC_IF
;
8092 /* Set up IF condition: Call _gfortran_is_extension_of. */
8093 new_st
->expr1
= gfc_get_expr ();
8094 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8095 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8096 new_st
->expr1
->ts
.kind
= 4;
8097 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8098 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8099 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8100 /* Set up arguments. */
8101 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8102 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8103 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8104 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8105 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8106 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8107 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8108 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8109 new_st
->next
= body
->next
;
8111 if (default_case
->next
)
8113 new_st
->block
= gfc_get_code ();
8114 new_st
= new_st
->block
;
8115 new_st
->op
= EXEC_IF
;
8116 new_st
->next
= default_case
->next
;
8119 /* Replace CLASS DEFAULT code by the IF chain. */
8120 default_case
->next
= if_st
;
8123 /* Resolve the internal code. This can not be done earlier because
8124 it requires that the sym->assoc of selectors is set already. */
8125 gfc_current_ns
= ns
;
8126 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8127 gfc_current_ns
= old_ns
;
8129 resolve_select (code
);
8133 /* Resolve a transfer statement. This is making sure that:
8134 -- a derived type being transferred has only non-pointer components
8135 -- a derived type being transferred doesn't have private components, unless
8136 it's being transferred from the module where the type was defined
8137 -- we're not trying to transfer a whole assumed size array. */
8140 resolve_transfer (gfc_code
*code
)
8149 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8150 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8151 exp
= exp
->value
.op
.op1
;
8153 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8155 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8156 "MOLD=", &exp
->where
);
8160 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8161 && exp
->expr_type
!= EXPR_FUNCTION
))
8164 /* If we are reading, the variable will be changed. Note that
8165 code->ext.dt may be NULL if the TRANSFER is related to
8166 an INQUIRE statement -- but in this case, we are not reading, either. */
8167 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8168 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8172 sym
= exp
->symtree
->n
.sym
;
8175 /* Go to actual component transferred. */
8176 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8177 if (ref
->type
== REF_COMPONENT
)
8178 ts
= &ref
->u
.c
.component
->ts
;
8180 if (ts
->type
== BT_CLASS
)
8182 /* FIXME: Test for defined input/output. */
8183 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8184 "it is processed by a defined input/output procedure",
8189 if (ts
->type
== BT_DERIVED
)
8191 /* Check that transferred derived type doesn't contain POINTER
8193 if (ts
->u
.derived
->attr
.pointer_comp
)
8195 gfc_error ("Data transfer element at %L cannot have POINTER "
8196 "components unless it is processed by a defined "
8197 "input/output procedure", &code
->loc
);
8202 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8204 gfc_error ("Data transfer element at %L cannot have "
8205 "procedure pointer components", &code
->loc
);
8209 if (ts
->u
.derived
->attr
.alloc_comp
)
8211 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8212 "components unless it is processed by a defined "
8213 "input/output procedure", &code
->loc
);
8217 if (derived_inaccessible (ts
->u
.derived
))
8219 gfc_error ("Data transfer element at %L cannot have "
8220 "PRIVATE components",&code
->loc
);
8225 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
8226 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8228 gfc_error ("Data transfer element at %L cannot be a full reference to "
8229 "an assumed-size array", &code
->loc
);
8235 /*********** Toplevel code resolution subroutines ***********/
8237 /* Find the set of labels that are reachable from this block. We also
8238 record the last statement in each block. */
8241 find_reachable_labels (gfc_code
*block
)
8248 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8250 /* Collect labels in this block. We don't keep those corresponding
8251 to END {IF|SELECT}, these are checked in resolve_branch by going
8252 up through the code_stack. */
8253 for (c
= block
; c
; c
= c
->next
)
8255 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8256 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8259 /* Merge with labels from parent block. */
8262 gcc_assert (cs_base
->prev
->reachable_labels
);
8263 bitmap_ior_into (cs_base
->reachable_labels
,
8264 cs_base
->prev
->reachable_labels
);
8270 resolve_lock_unlock (gfc_code
*code
)
8272 if (code
->expr1
->ts
.type
!= BT_DERIVED
8273 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8274 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8275 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8276 || code
->expr1
->rank
!= 0
8277 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8278 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8279 &code
->expr1
->where
);
8283 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8284 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8285 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8286 &code
->expr2
->where
);
8289 && gfc_check_vardef_context (code
->expr2
, false, false,
8290 _("STAT variable")) == FAILURE
)
8295 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8296 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8297 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8298 &code
->expr3
->where
);
8301 && gfc_check_vardef_context (code
->expr3
, false, false,
8302 _("ERRMSG variable")) == FAILURE
)
8305 /* Check ACQUIRED_LOCK. */
8307 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8308 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8309 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8310 "variable", &code
->expr4
->where
);
8313 && gfc_check_vardef_context (code
->expr4
, false, false,
8314 _("ACQUIRED_LOCK variable")) == FAILURE
)
8320 resolve_sync (gfc_code
*code
)
8322 /* Check imageset. The * case matches expr1 == NULL. */
8325 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8326 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8327 "INTEGER expression", &code
->expr1
->where
);
8328 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8329 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8330 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8331 &code
->expr1
->where
);
8332 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8333 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8335 gfc_constructor
*cons
;
8336 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8337 for (; cons
; cons
= gfc_constructor_next (cons
))
8338 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8339 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8340 gfc_error ("Imageset argument at %L must between 1 and "
8341 "num_images()", &cons
->expr
->where
);
8347 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8348 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8349 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8350 &code
->expr2
->where
);
8354 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8355 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8356 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8357 &code
->expr3
->where
);
8361 /* Given a branch to a label, see if the branch is conforming.
8362 The code node describes where the branch is located. */
8365 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8372 /* Step one: is this a valid branching target? */
8374 if (label
->defined
== ST_LABEL_UNKNOWN
)
8376 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8381 if (label
->defined
!= ST_LABEL_TARGET
)
8383 gfc_error ("Statement at %L is not a valid branch target statement "
8384 "for the branch statement at %L", &label
->where
, &code
->loc
);
8388 /* Step two: make sure this branch is not a branch to itself ;-) */
8390 if (code
->here
== label
)
8392 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8396 /* Step three: See if the label is in the same block as the
8397 branching statement. The hard work has been done by setting up
8398 the bitmap reachable_labels. */
8400 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8402 /* Check now whether there is a CRITICAL construct; if so, check
8403 whether the label is still visible outside of the CRITICAL block,
8404 which is invalid. */
8405 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8407 if (stack
->current
->op
== EXEC_CRITICAL
8408 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8409 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8410 "label at %L", &code
->loc
, &label
->where
);
8411 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8412 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8413 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8414 "for label at %L", &code
->loc
, &label
->where
);
8420 /* Step four: If we haven't found the label in the bitmap, it may
8421 still be the label of the END of the enclosing block, in which
8422 case we find it by going up the code_stack. */
8424 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8426 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8428 if (stack
->current
->op
== EXEC_CRITICAL
)
8430 /* Note: A label at END CRITICAL does not leave the CRITICAL
8431 construct as END CRITICAL is still part of it. */
8432 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8433 " at %L", &code
->loc
, &label
->where
);
8436 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8438 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8439 "label at %L", &code
->loc
, &label
->where
);
8446 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8450 /* The label is not in an enclosing block, so illegal. This was
8451 allowed in Fortran 66, so we allow it as extension. No
8452 further checks are necessary in this case. */
8453 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8454 "as the GOTO statement at %L", &label
->where
,
8460 /* Check whether EXPR1 has the same shape as EXPR2. */
8463 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8465 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8466 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8467 gfc_try result
= FAILURE
;
8470 /* Compare the rank. */
8471 if (expr1
->rank
!= expr2
->rank
)
8474 /* Compare the size of each dimension. */
8475 for (i
=0; i
<expr1
->rank
; i
++)
8477 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8480 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8483 if (mpz_cmp (shape
[i
], shape2
[i
]))
8487 /* When either of the two expression is an assumed size array, we
8488 ignore the comparison of dimension sizes. */
8493 gfc_clear_shape (shape
, i
);
8494 gfc_clear_shape (shape2
, i
);
8499 /* Check whether a WHERE assignment target or a WHERE mask expression
8500 has the same shape as the outmost WHERE mask expression. */
8503 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8509 cblock
= code
->block
;
8511 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8512 In case of nested WHERE, only the outmost one is stored. */
8513 if (mask
== NULL
) /* outmost WHERE */
8515 else /* inner WHERE */
8522 /* Check if the mask-expr has a consistent shape with the
8523 outmost WHERE mask-expr. */
8524 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8525 gfc_error ("WHERE mask at %L has inconsistent shape",
8526 &cblock
->expr1
->where
);
8529 /* the assignment statement of a WHERE statement, or the first
8530 statement in where-body-construct of a WHERE construct */
8531 cnext
= cblock
->next
;
8536 /* WHERE assignment statement */
8539 /* Check shape consistent for WHERE assignment target. */
8540 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8541 gfc_error ("WHERE assignment target at %L has "
8542 "inconsistent shape", &cnext
->expr1
->where
);
8546 case EXEC_ASSIGN_CALL
:
8547 resolve_call (cnext
);
8548 if (!cnext
->resolved_sym
->attr
.elemental
)
8549 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8550 &cnext
->ext
.actual
->expr
->where
);
8553 /* WHERE or WHERE construct is part of a where-body-construct */
8555 resolve_where (cnext
, e
);
8559 gfc_error ("Unsupported statement inside WHERE at %L",
8562 /* the next statement within the same where-body-construct */
8563 cnext
= cnext
->next
;
8565 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8566 cblock
= cblock
->block
;
8571 /* Resolve assignment in FORALL construct.
8572 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8573 FORALL index variables. */
8576 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8580 for (n
= 0; n
< nvar
; n
++)
8582 gfc_symbol
*forall_index
;
8584 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8586 /* Check whether the assignment target is one of the FORALL index
8588 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8589 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8590 gfc_error ("Assignment to a FORALL index variable at %L",
8591 &code
->expr1
->where
);
8594 /* If one of the FORALL index variables doesn't appear in the
8595 assignment variable, then there could be a many-to-one
8596 assignment. Emit a warning rather than an error because the
8597 mask could be resolving this problem. */
8598 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8599 gfc_warning ("The FORALL with index '%s' is not used on the "
8600 "left side of the assignment at %L and so might "
8601 "cause multiple assignment to this object",
8602 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8608 /* Resolve WHERE statement in FORALL construct. */
8611 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8612 gfc_expr
**var_expr
)
8617 cblock
= code
->block
;
8620 /* the assignment statement of a WHERE statement, or the first
8621 statement in where-body-construct of a WHERE construct */
8622 cnext
= cblock
->next
;
8627 /* WHERE assignment statement */
8629 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8632 /* WHERE operator assignment statement */
8633 case EXEC_ASSIGN_CALL
:
8634 resolve_call (cnext
);
8635 if (!cnext
->resolved_sym
->attr
.elemental
)
8636 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8637 &cnext
->ext
.actual
->expr
->where
);
8640 /* WHERE or WHERE construct is part of a where-body-construct */
8642 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8646 gfc_error ("Unsupported statement inside WHERE at %L",
8649 /* the next statement within the same where-body-construct */
8650 cnext
= cnext
->next
;
8652 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8653 cblock
= cblock
->block
;
8658 /* Traverse the FORALL body to check whether the following errors exist:
8659 1. For assignment, check if a many-to-one assignment happens.
8660 2. For WHERE statement, check the WHERE body to see if there is any
8661 many-to-one assignment. */
8664 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8668 c
= code
->block
->next
;
8674 case EXEC_POINTER_ASSIGN
:
8675 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8678 case EXEC_ASSIGN_CALL
:
8682 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8683 there is no need to handle it here. */
8687 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8692 /* The next statement in the FORALL body. */
8698 /* Counts the number of iterators needed inside a forall construct, including
8699 nested forall constructs. This is used to allocate the needed memory
8700 in gfc_resolve_forall. */
8703 gfc_count_forall_iterators (gfc_code
*code
)
8705 int max_iters
, sub_iters
, current_iters
;
8706 gfc_forall_iterator
*fa
;
8708 gcc_assert(code
->op
== EXEC_FORALL
);
8712 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8715 code
= code
->block
->next
;
8719 if (code
->op
== EXEC_FORALL
)
8721 sub_iters
= gfc_count_forall_iterators (code
);
8722 if (sub_iters
> max_iters
)
8723 max_iters
= sub_iters
;
8728 return current_iters
+ max_iters
;
8732 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8733 gfc_resolve_forall_body to resolve the FORALL body. */
8736 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8738 static gfc_expr
**var_expr
;
8739 static int total_var
= 0;
8740 static int nvar
= 0;
8742 gfc_forall_iterator
*fa
;
8747 /* Start to resolve a FORALL construct */
8748 if (forall_save
== 0)
8750 /* Count the total number of FORALL index in the nested FORALL
8751 construct in order to allocate the VAR_EXPR with proper size. */
8752 total_var
= gfc_count_forall_iterators (code
);
8754 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8755 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8758 /* The information about FORALL iterator, including FORALL index start, end
8759 and stride. The FORALL index can not appear in start, end or stride. */
8760 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8762 /* Check if any outer FORALL index name is the same as the current
8764 for (i
= 0; i
< nvar
; i
++)
8766 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8768 gfc_error ("An outer FORALL construct already has an index "
8769 "with this name %L", &fa
->var
->where
);
8773 /* Record the current FORALL index. */
8774 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8778 /* No memory leak. */
8779 gcc_assert (nvar
<= total_var
);
8782 /* Resolve the FORALL body. */
8783 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8785 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8786 gfc_resolve_blocks (code
->block
, ns
);
8790 /* Free only the VAR_EXPRs allocated in this frame. */
8791 for (i
= nvar
; i
< tmp
; i
++)
8792 gfc_free_expr (var_expr
[i
]);
8796 /* We are in the outermost FORALL construct. */
8797 gcc_assert (forall_save
== 0);
8799 /* VAR_EXPR is not needed any more. */
8806 /* Resolve a BLOCK construct statement. */
8809 resolve_block_construct (gfc_code
* code
)
8811 /* Resolve the BLOCK's namespace. */
8812 gfc_resolve (code
->ext
.block
.ns
);
8814 /* For an ASSOCIATE block, the associations (and their targets) are already
8815 resolved during resolve_symbol. */
8819 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8822 static void resolve_code (gfc_code
*, gfc_namespace
*);
8825 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8829 for (; b
; b
= b
->block
)
8831 t
= gfc_resolve_expr (b
->expr1
);
8832 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
8838 if (t
== SUCCESS
&& b
->expr1
!= NULL
8839 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8840 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8847 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8848 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8853 resolve_branch (b
->label1
, b
);
8857 resolve_block_construct (b
);
8861 case EXEC_SELECT_TYPE
:
8865 case EXEC_DO_CONCURRENT
:
8873 case EXEC_OMP_ATOMIC
:
8874 case EXEC_OMP_CRITICAL
:
8876 case EXEC_OMP_MASTER
:
8877 case EXEC_OMP_ORDERED
:
8878 case EXEC_OMP_PARALLEL
:
8879 case EXEC_OMP_PARALLEL_DO
:
8880 case EXEC_OMP_PARALLEL_SECTIONS
:
8881 case EXEC_OMP_PARALLEL_WORKSHARE
:
8882 case EXEC_OMP_SECTIONS
:
8883 case EXEC_OMP_SINGLE
:
8885 case EXEC_OMP_TASKWAIT
:
8886 case EXEC_OMP_TASKYIELD
:
8887 case EXEC_OMP_WORKSHARE
:
8891 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8894 resolve_code (b
->next
, ns
);
8899 /* Does everything to resolve an ordinary assignment. Returns true
8900 if this is an interface assignment. */
8902 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
8912 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
8916 if (code
->op
== EXEC_ASSIGN_CALL
)
8918 lhs
= code
->ext
.actual
->expr
;
8919 rhsptr
= &code
->ext
.actual
->next
->expr
;
8923 gfc_actual_arglist
* args
;
8924 gfc_typebound_proc
* tbp
;
8926 gcc_assert (code
->op
== EXEC_COMPCALL
);
8928 args
= code
->expr1
->value
.compcall
.actual
;
8930 rhsptr
= &args
->next
->expr
;
8932 tbp
= code
->expr1
->value
.compcall
.tbp
;
8933 gcc_assert (!tbp
->is_generic
);
8936 /* Make a temporary rhs when there is a default initializer
8937 and rhs is the same symbol as the lhs. */
8938 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
8939 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
8940 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
8941 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
8942 *rhsptr
= gfc_get_parentheses (*rhsptr
);
8951 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
8952 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8953 &code
->loc
) == FAILURE
)
8956 /* Handle the case of a BOZ literal on the RHS. */
8957 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
8960 if (gfc_option
.warn_surprising
)
8961 gfc_warning ("BOZ literal at %L is bitwise transferred "
8962 "non-integer symbol '%s'", &code
->loc
,
8963 lhs
->symtree
->n
.sym
->name
);
8965 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
8967 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
8969 if (rc
== ARITH_UNDERFLOW
)
8970 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8971 ". This check can be disabled with the option "
8972 "-fno-range-check", &rhs
->where
);
8973 else if (rc
== ARITH_OVERFLOW
)
8974 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8975 ". This check can be disabled with the option "
8976 "-fno-range-check", &rhs
->where
);
8977 else if (rc
== ARITH_NAN
)
8978 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8979 ". This check can be disabled with the option "
8980 "-fno-range-check", &rhs
->where
);
8985 if (lhs
->ts
.type
== BT_CHARACTER
8986 && gfc_option
.warn_character_truncation
)
8988 if (lhs
->ts
.u
.cl
!= NULL
8989 && lhs
->ts
.u
.cl
->length
!= NULL
8990 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8991 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
8993 if (rhs
->expr_type
== EXPR_CONSTANT
)
8994 rlen
= rhs
->value
.character
.length
;
8996 else if (rhs
->ts
.u
.cl
!= NULL
8997 && rhs
->ts
.u
.cl
->length
!= NULL
8998 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8999 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9001 if (rlen
&& llen
&& rlen
> llen
)
9002 gfc_warning_now ("CHARACTER expression will be truncated "
9003 "in assignment (%d/%d) at %L",
9004 llen
, rlen
, &code
->loc
);
9007 /* Ensure that a vector index expression for the lvalue is evaluated
9008 to a temporary if the lvalue symbol is referenced in it. */
9011 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9012 if (ref
->type
== REF_ARRAY
)
9014 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9015 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9016 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9017 ref
->u
.ar
.start
[n
]))
9019 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9023 if (gfc_pure (NULL
))
9025 if (lhs
->ts
.type
== BT_DERIVED
9026 && lhs
->expr_type
== EXPR_VARIABLE
9027 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9028 && rhs
->expr_type
== EXPR_VARIABLE
9029 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9030 || gfc_is_coindexed (rhs
)))
9033 if (gfc_is_coindexed (rhs
))
9034 gfc_error ("Coindexed expression at %L is assigned to "
9035 "a derived type variable with a POINTER "
9036 "component in a PURE procedure",
9039 gfc_error ("The impure variable at %L is assigned to "
9040 "a derived type variable with a POINTER "
9041 "component in a PURE procedure (12.6)",
9046 /* Fortran 2008, C1283. */
9047 if (gfc_is_coindexed (lhs
))
9049 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9050 "procedure", &rhs
->where
);
9055 if (gfc_implicit_pure (NULL
))
9057 if (lhs
->expr_type
== EXPR_VARIABLE
9058 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9059 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9060 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9062 if (lhs
->ts
.type
== BT_DERIVED
9063 && lhs
->expr_type
== EXPR_VARIABLE
9064 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9065 && rhs
->expr_type
== EXPR_VARIABLE
9066 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9067 || gfc_is_coindexed (rhs
)))
9068 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9070 /* Fortran 2008, C1283. */
9071 if (gfc_is_coindexed (lhs
))
9072 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9076 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9077 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9078 if (lhs
->ts
.type
== BT_CLASS
)
9080 gfc_error ("Variable must not be polymorphic in assignment at %L",
9085 /* F2008, Section 7.2.1.2. */
9086 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9088 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9089 "component in assignment at %L", &lhs
->where
);
9093 gfc_check_assign (lhs
, rhs
, 1);
9098 /* Given a block of code, recursively resolve everything pointed to by this
9102 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9104 int omp_workshare_save
;
9105 int forall_save
, do_concurrent_save
;
9109 frame
.prev
= cs_base
;
9113 find_reachable_labels (code
);
9115 for (; code
; code
= code
->next
)
9117 frame
.current
= code
;
9118 forall_save
= forall_flag
;
9119 do_concurrent_save
= do_concurrent_flag
;
9121 if (code
->op
== EXEC_FORALL
)
9124 gfc_resolve_forall (code
, ns
, forall_save
);
9127 else if (code
->block
)
9129 omp_workshare_save
= -1;
9132 case EXEC_OMP_PARALLEL_WORKSHARE
:
9133 omp_workshare_save
= omp_workshare_flag
;
9134 omp_workshare_flag
= 1;
9135 gfc_resolve_omp_parallel_blocks (code
, ns
);
9137 case EXEC_OMP_PARALLEL
:
9138 case EXEC_OMP_PARALLEL_DO
:
9139 case EXEC_OMP_PARALLEL_SECTIONS
:
9141 omp_workshare_save
= omp_workshare_flag
;
9142 omp_workshare_flag
= 0;
9143 gfc_resolve_omp_parallel_blocks (code
, ns
);
9146 gfc_resolve_omp_do_blocks (code
, ns
);
9148 case EXEC_SELECT_TYPE
:
9149 /* Blocks are handled in resolve_select_type because we have
9150 to transform the SELECT TYPE into ASSOCIATE first. */
9152 case EXEC_DO_CONCURRENT
:
9153 do_concurrent_flag
= 1;
9154 gfc_resolve_blocks (code
->block
, ns
);
9155 do_concurrent_flag
= 2;
9157 case EXEC_OMP_WORKSHARE
:
9158 omp_workshare_save
= omp_workshare_flag
;
9159 omp_workshare_flag
= 1;
9162 gfc_resolve_blocks (code
->block
, ns
);
9166 if (omp_workshare_save
!= -1)
9167 omp_workshare_flag
= omp_workshare_save
;
9171 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9172 t
= gfc_resolve_expr (code
->expr1
);
9173 forall_flag
= forall_save
;
9174 do_concurrent_flag
= do_concurrent_save
;
9176 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9179 if (code
->op
== EXEC_ALLOCATE
9180 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9186 case EXEC_END_BLOCK
:
9187 case EXEC_END_NESTED_BLOCK
:
9191 case EXEC_ERROR_STOP
:
9195 case EXEC_ASSIGN_CALL
:
9200 case EXEC_SYNC_IMAGES
:
9201 case EXEC_SYNC_MEMORY
:
9202 resolve_sync (code
);
9207 resolve_lock_unlock (code
);
9211 /* Keep track of which entry we are up to. */
9212 current_entry_id
= code
->ext
.entry
->id
;
9216 resolve_where (code
, NULL
);
9220 if (code
->expr1
!= NULL
)
9222 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9223 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9224 "INTEGER variable", &code
->expr1
->where
);
9225 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9226 gfc_error ("Variable '%s' has not been assigned a target "
9227 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9228 &code
->expr1
->where
);
9231 resolve_branch (code
->label1
, code
);
9235 if (code
->expr1
!= NULL
9236 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9237 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9238 "INTEGER return specifier", &code
->expr1
->where
);
9241 case EXEC_INIT_ASSIGN
:
9242 case EXEC_END_PROCEDURE
:
9249 if (gfc_check_vardef_context (code
->expr1
, false, false,
9250 _("assignment")) == FAILURE
)
9253 if (resolve_ordinary_assign (code
, ns
))
9255 if (code
->op
== EXEC_COMPCALL
)
9262 case EXEC_LABEL_ASSIGN
:
9263 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9264 gfc_error ("Label %d referenced at %L is never defined",
9265 code
->label1
->value
, &code
->label1
->where
);
9267 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9268 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9269 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9270 != gfc_default_integer_kind
9271 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9272 gfc_error ("ASSIGN statement at %L requires a scalar "
9273 "default INTEGER variable", &code
->expr1
->where
);
9276 case EXEC_POINTER_ASSIGN
:
9283 /* This is both a variable definition and pointer assignment
9284 context, so check both of them. For rank remapping, a final
9285 array ref may be present on the LHS and fool gfc_expr_attr
9286 used in gfc_check_vardef_context. Remove it. */
9287 e
= remove_last_array_ref (code
->expr1
);
9288 t
= gfc_check_vardef_context (e
, true, false,
9289 _("pointer assignment"));
9291 t
= gfc_check_vardef_context (e
, false, false,
9292 _("pointer assignment"));
9297 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9301 case EXEC_ARITHMETIC_IF
:
9303 && code
->expr1
->ts
.type
!= BT_INTEGER
9304 && code
->expr1
->ts
.type
!= BT_REAL
)
9305 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9306 "expression", &code
->expr1
->where
);
9308 resolve_branch (code
->label1
, code
);
9309 resolve_branch (code
->label2
, code
);
9310 resolve_branch (code
->label3
, code
);
9314 if (t
== SUCCESS
&& code
->expr1
!= NULL
9315 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9316 || code
->expr1
->rank
!= 0))
9317 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9318 &code
->expr1
->where
);
9323 resolve_call (code
);
9328 resolve_typebound_subroutine (code
);
9332 resolve_ppc_call (code
);
9336 /* Select is complicated. Also, a SELECT construct could be
9337 a transformed computed GOTO. */
9338 resolve_select (code
);
9341 case EXEC_SELECT_TYPE
:
9342 resolve_select_type (code
, ns
);
9346 resolve_block_construct (code
);
9350 if (code
->ext
.iterator
!= NULL
)
9352 gfc_iterator
*iter
= code
->ext
.iterator
;
9353 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9354 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9359 if (code
->expr1
== NULL
)
9360 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9362 && (code
->expr1
->rank
!= 0
9363 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9364 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9365 "a scalar LOGICAL expression", &code
->expr1
->where
);
9370 resolve_allocate_deallocate (code
, "ALLOCATE");
9374 case EXEC_DEALLOCATE
:
9376 resolve_allocate_deallocate (code
, "DEALLOCATE");
9381 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9384 resolve_branch (code
->ext
.open
->err
, code
);
9388 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9391 resolve_branch (code
->ext
.close
->err
, code
);
9394 case EXEC_BACKSPACE
:
9398 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9401 resolve_branch (code
->ext
.filepos
->err
, code
);
9405 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9408 resolve_branch (code
->ext
.inquire
->err
, code
);
9412 gcc_assert (code
->ext
.inquire
!= NULL
);
9413 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9416 resolve_branch (code
->ext
.inquire
->err
, code
);
9420 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9423 resolve_branch (code
->ext
.wait
->err
, code
);
9424 resolve_branch (code
->ext
.wait
->end
, code
);
9425 resolve_branch (code
->ext
.wait
->eor
, code
);
9430 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9433 resolve_branch (code
->ext
.dt
->err
, code
);
9434 resolve_branch (code
->ext
.dt
->end
, code
);
9435 resolve_branch (code
->ext
.dt
->eor
, code
);
9439 resolve_transfer (code
);
9442 case EXEC_DO_CONCURRENT
:
9444 resolve_forall_iterators (code
->ext
.forall_iterator
);
9446 if (code
->expr1
!= NULL
9447 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9448 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9449 "expression", &code
->expr1
->where
);
9452 case EXEC_OMP_ATOMIC
:
9453 case EXEC_OMP_BARRIER
:
9454 case EXEC_OMP_CRITICAL
:
9455 case EXEC_OMP_FLUSH
:
9457 case EXEC_OMP_MASTER
:
9458 case EXEC_OMP_ORDERED
:
9459 case EXEC_OMP_SECTIONS
:
9460 case EXEC_OMP_SINGLE
:
9461 case EXEC_OMP_TASKWAIT
:
9462 case EXEC_OMP_TASKYIELD
:
9463 case EXEC_OMP_WORKSHARE
:
9464 gfc_resolve_omp_directive (code
, ns
);
9467 case EXEC_OMP_PARALLEL
:
9468 case EXEC_OMP_PARALLEL_DO
:
9469 case EXEC_OMP_PARALLEL_SECTIONS
:
9470 case EXEC_OMP_PARALLEL_WORKSHARE
:
9472 omp_workshare_save
= omp_workshare_flag
;
9473 omp_workshare_flag
= 0;
9474 gfc_resolve_omp_directive (code
, ns
);
9475 omp_workshare_flag
= omp_workshare_save
;
9479 gfc_internal_error ("resolve_code(): Bad statement code");
9483 cs_base
= frame
.prev
;
9487 /* Resolve initial values and make sure they are compatible with
9491 resolve_values (gfc_symbol
*sym
)
9495 if (sym
->value
== NULL
)
9498 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9499 t
= resolve_structure_cons (sym
->value
, 1);
9501 t
= gfc_resolve_expr (sym
->value
);
9506 gfc_check_assign_symbol (sym
, sym
->value
);
9510 /* Verify the binding labels for common blocks that are BIND(C). The label
9511 for a BIND(C) common block must be identical in all scoping units in which
9512 the common block is declared. Further, the binding label can not collide
9513 with any other global entity in the program. */
9516 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9518 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9520 gfc_gsymbol
*binding_label_gsym
;
9521 gfc_gsymbol
*comm_name_gsym
;
9523 /* See if a global symbol exists by the common block's name. It may
9524 be NULL if the common block is use-associated. */
9525 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9526 comm_block_tree
->n
.common
->name
);
9527 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9528 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9529 "with the global entity '%s' at %L",
9530 comm_block_tree
->n
.common
->binding_label
,
9531 comm_block_tree
->n
.common
->name
,
9532 &(comm_block_tree
->n
.common
->where
),
9533 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9534 else if (comm_name_gsym
!= NULL
9535 && strcmp (comm_name_gsym
->name
,
9536 comm_block_tree
->n
.common
->name
) == 0)
9538 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9540 if (comm_name_gsym
->binding_label
== NULL
)
9541 /* No binding label for common block stored yet; save this one. */
9542 comm_name_gsym
->binding_label
=
9543 comm_block_tree
->n
.common
->binding_label
;
9545 if (strcmp (comm_name_gsym
->binding_label
,
9546 comm_block_tree
->n
.common
->binding_label
) != 0)
9548 /* Common block names match but binding labels do not. */
9549 gfc_error ("Binding label '%s' for common block '%s' at %L "
9550 "does not match the binding label '%s' for common "
9552 comm_block_tree
->n
.common
->binding_label
,
9553 comm_block_tree
->n
.common
->name
,
9554 &(comm_block_tree
->n
.common
->where
),
9555 comm_name_gsym
->binding_label
,
9556 comm_name_gsym
->name
,
9557 &(comm_name_gsym
->where
));
9562 /* There is no binding label (NAME="") so we have nothing further to
9563 check and nothing to add as a global symbol for the label. */
9564 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
9567 binding_label_gsym
=
9568 gfc_find_gsymbol (gfc_gsym_root
,
9569 comm_block_tree
->n
.common
->binding_label
);
9570 if (binding_label_gsym
== NULL
)
9572 /* Need to make a global symbol for the binding label to prevent
9573 it from colliding with another. */
9574 binding_label_gsym
=
9575 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9576 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9577 binding_label_gsym
->type
= GSYM_COMMON
;
9581 /* If comm_name_gsym is NULL, the name common block is use
9582 associated and the name could be colliding. */
9583 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9584 gfc_error ("Binding label '%s' for common block '%s' at %L "
9585 "collides with the global entity '%s' at %L",
9586 comm_block_tree
->n
.common
->binding_label
,
9587 comm_block_tree
->n
.common
->name
,
9588 &(comm_block_tree
->n
.common
->where
),
9589 binding_label_gsym
->name
,
9590 &(binding_label_gsym
->where
));
9591 else if (comm_name_gsym
!= NULL
9592 && (strcmp (binding_label_gsym
->name
,
9593 comm_name_gsym
->binding_label
) != 0)
9594 && (strcmp (binding_label_gsym
->sym_name
,
9595 comm_name_gsym
->name
) != 0))
9596 gfc_error ("Binding label '%s' for common block '%s' at %L "
9597 "collides with global entity '%s' at %L",
9598 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9599 &(comm_block_tree
->n
.common
->where
),
9600 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9608 /* Verify any BIND(C) derived types in the namespace so we can report errors
9609 for them once, rather than for each variable declared of that type. */
9612 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9614 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9615 && derived_sym
->attr
.is_bind_c
== 1)
9616 verify_bind_c_derived_type (derived_sym
);
9622 /* Verify that any binding labels used in a given namespace do not collide
9623 with the names or binding labels of any global symbols. */
9626 gfc_verify_binding_labels (gfc_symbol
*sym
)
9630 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9631 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
9633 gfc_gsymbol
*bind_c_sym
;
9635 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9636 if (bind_c_sym
!= NULL
9637 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9639 if (sym
->attr
.if_source
== IFSRC_DECL
9640 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9641 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9642 && ((sym
->attr
.contained
== 1
9643 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9644 || (sym
->attr
.use_assoc
== 1
9645 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9647 /* Make sure global procedures don't collide with anything. */
9648 gfc_error ("Binding label '%s' at %L collides with the global "
9649 "entity '%s' at %L", sym
->binding_label
,
9650 &(sym
->declared_at
), bind_c_sym
->name
,
9651 &(bind_c_sym
->where
));
9654 else if (sym
->attr
.contained
== 0
9655 && (sym
->attr
.if_source
== IFSRC_IFBODY
9656 && sym
->attr
.flavor
== FL_PROCEDURE
)
9657 && (bind_c_sym
->sym_name
!= NULL
9658 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9660 /* Make sure procedures in interface bodies don't collide. */
9661 gfc_error ("Binding label '%s' in interface body at %L collides "
9662 "with the global entity '%s' at %L",
9664 &(sym
->declared_at
), bind_c_sym
->name
,
9665 &(bind_c_sym
->where
));
9668 else if (sym
->attr
.contained
== 0
9669 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9670 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9671 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9672 || sym
->attr
.use_assoc
== 0)
9674 gfc_error ("Binding label '%s' at %L collides with global "
9675 "entity '%s' at %L", sym
->binding_label
,
9676 &(sym
->declared_at
), bind_c_sym
->name
,
9677 &(bind_c_sym
->where
));
9682 /* Clear the binding label to prevent checking multiple times. */
9683 sym
->binding_label
[0] = '\0';
9685 else if (bind_c_sym
== NULL
)
9687 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9688 bind_c_sym
->where
= sym
->declared_at
;
9689 bind_c_sym
->sym_name
= sym
->name
;
9691 if (sym
->attr
.use_assoc
== 1)
9692 bind_c_sym
->mod_name
= sym
->module
;
9694 if (sym
->ns
->proc_name
!= NULL
)
9695 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9697 if (sym
->attr
.contained
== 0)
9699 if (sym
->attr
.subroutine
)
9700 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9701 else if (sym
->attr
.function
)
9702 bind_c_sym
->type
= GSYM_FUNCTION
;
9710 /* Resolve an index expression. */
9713 resolve_index_expr (gfc_expr
*e
)
9715 if (gfc_resolve_expr (e
) == FAILURE
)
9718 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9721 if (gfc_specification_expr (e
) == FAILURE
)
9728 /* Resolve a charlen structure. */
9731 resolve_charlen (gfc_charlen
*cl
)
9740 specification_expr
= 1;
9742 if (resolve_index_expr (cl
->length
) == FAILURE
)
9744 specification_expr
= 0;
9748 /* "If the character length parameter value evaluates to a negative
9749 value, the length of character entities declared is zero." */
9750 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9752 if (gfc_option
.warn_surprising
)
9753 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9754 " the length has been set to zero",
9755 &cl
->length
->where
, i
);
9756 gfc_replace_expr (cl
->length
,
9757 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9760 /* Check that the character length is not too large. */
9761 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9762 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9763 && cl
->length
->ts
.type
== BT_INTEGER
9764 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9766 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9774 /* Test for non-constant shape arrays. */
9777 is_non_constant_shape_array (gfc_symbol
*sym
)
9783 not_constant
= false;
9784 if (sym
->as
!= NULL
)
9786 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9787 has not been simplified; parameter array references. Do the
9788 simplification now. */
9789 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
9791 e
= sym
->as
->lower
[i
];
9792 if (e
&& (resolve_index_expr (e
) == FAILURE
9793 || !gfc_is_constant_expr (e
)))
9794 not_constant
= true;
9795 e
= sym
->as
->upper
[i
];
9796 if (e
&& (resolve_index_expr (e
) == FAILURE
9797 || !gfc_is_constant_expr (e
)))
9798 not_constant
= true;
9801 return not_constant
;
9804 /* Given a symbol and an initialization expression, add code to initialize
9805 the symbol to the function entry. */
9807 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
9811 gfc_namespace
*ns
= sym
->ns
;
9813 /* Search for the function namespace if this is a contained
9814 function without an explicit result. */
9815 if (sym
->attr
.function
&& sym
== sym
->result
9816 && sym
->name
!= sym
->ns
->proc_name
->name
)
9819 for (;ns
; ns
= ns
->sibling
)
9820 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
9826 gfc_free_expr (init
);
9830 /* Build an l-value expression for the result. */
9831 lval
= gfc_lval_expr_from_sym (sym
);
9833 /* Add the code at scope entry. */
9834 init_st
= gfc_get_code ();
9835 init_st
->next
= ns
->code
;
9838 /* Assign the default initializer to the l-value. */
9839 init_st
->loc
= sym
->declared_at
;
9840 init_st
->op
= EXEC_INIT_ASSIGN
;
9841 init_st
->expr1
= lval
;
9842 init_st
->expr2
= init
;
9845 /* Assign the default initializer to a derived type variable or result. */
9848 apply_default_init (gfc_symbol
*sym
)
9850 gfc_expr
*init
= NULL
;
9852 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9855 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
9856 init
= gfc_default_initializer (&sym
->ts
);
9858 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
9861 build_init_assign (sym
, init
);
9862 sym
->attr
.referenced
= 1;
9865 /* Build an initializer for a local integer, real, complex, logical, or
9866 character variable, based on the command line flags finit-local-zero,
9867 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9868 null if the symbol should not have a default initialization. */
9870 build_default_init_expr (gfc_symbol
*sym
)
9873 gfc_expr
*init_expr
;
9876 /* These symbols should never have a default initialization. */
9877 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
9878 || sym
->attr
.external
9880 || sym
->attr
.pointer
9881 || sym
->attr
.in_equivalence
9882 || sym
->attr
.in_common
9885 || sym
->attr
.cray_pointee
9886 || sym
->attr
.cray_pointer
)
9889 /* Now we'll try to build an initializer expression. */
9890 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
9893 /* We will only initialize integers, reals, complex, logicals, and
9894 characters, and only if the corresponding command-line flags
9895 were set. Otherwise, we free init_expr and return null. */
9896 switch (sym
->ts
.type
)
9899 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
9900 mpz_set_si (init_expr
->value
.integer
,
9901 gfc_option
.flag_init_integer_value
);
9904 gfc_free_expr (init_expr
);
9910 switch (gfc_option
.flag_init_real
)
9912 case GFC_INIT_REAL_SNAN
:
9913 init_expr
->is_snan
= 1;
9915 case GFC_INIT_REAL_NAN
:
9916 mpfr_set_nan (init_expr
->value
.real
);
9919 case GFC_INIT_REAL_INF
:
9920 mpfr_set_inf (init_expr
->value
.real
, 1);
9923 case GFC_INIT_REAL_NEG_INF
:
9924 mpfr_set_inf (init_expr
->value
.real
, -1);
9927 case GFC_INIT_REAL_ZERO
:
9928 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
9932 gfc_free_expr (init_expr
);
9939 switch (gfc_option
.flag_init_real
)
9941 case GFC_INIT_REAL_SNAN
:
9942 init_expr
->is_snan
= 1;
9944 case GFC_INIT_REAL_NAN
:
9945 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
9946 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
9949 case GFC_INIT_REAL_INF
:
9950 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
9951 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
9954 case GFC_INIT_REAL_NEG_INF
:
9955 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
9956 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
9959 case GFC_INIT_REAL_ZERO
:
9960 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
9964 gfc_free_expr (init_expr
);
9971 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
9972 init_expr
->value
.logical
= 0;
9973 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
9974 init_expr
->value
.logical
= 1;
9977 gfc_free_expr (init_expr
);
9983 /* For characters, the length must be constant in order to
9984 create a default initializer. */
9985 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
9986 && sym
->ts
.u
.cl
->length
9987 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9989 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
9990 init_expr
->value
.character
.length
= char_len
;
9991 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
9992 for (i
= 0; i
< char_len
; i
++)
9993 init_expr
->value
.character
.string
[i
]
9994 = (unsigned char) gfc_option
.flag_init_character_value
;
9998 gfc_free_expr (init_expr
);
10004 gfc_free_expr (init_expr
);
10010 /* Add an initialization expression to a local variable. */
10012 apply_default_init_local (gfc_symbol
*sym
)
10014 gfc_expr
*init
= NULL
;
10016 /* The symbol should be a variable or a function return value. */
10017 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10018 || (sym
->attr
.function
&& sym
->result
!= sym
))
10021 /* Try to build the initializer expression. If we can't initialize
10022 this symbol, then init will be NULL. */
10023 init
= build_default_init_expr (sym
);
10027 /* For saved variables, we don't want to add an initializer at
10028 function entry, so we just add a static initializer. */
10029 if (sym
->attr
.save
|| sym
->ns
->save_all
10030 || gfc_option
.flag_max_stack_var_size
== 0)
10032 /* Don't clobber an existing initializer! */
10033 gcc_assert (sym
->value
== NULL
);
10038 build_init_assign (sym
, init
);
10042 /* Resolution of common features of flavors variable and procedure. */
10045 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10047 /* Avoid double diagnostics for function result symbols. */
10048 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10049 && (sym
->ns
!= gfc_current_ns
))
10052 /* Constraints on deferred shape variable. */
10053 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
10055 if (sym
->attr
.allocatable
)
10057 if (sym
->attr
.dimension
)
10059 gfc_error ("Allocatable array '%s' at %L must have "
10060 "a deferred shape", sym
->name
, &sym
->declared_at
);
10063 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
10064 "may not be ALLOCATABLE", sym
->name
,
10065 &sym
->declared_at
) == FAILURE
)
10069 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
10071 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10072 sym
->name
, &sym
->declared_at
);
10078 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10079 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10081 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10082 sym
->name
, &sym
->declared_at
);
10087 /* Constraints on polymorphic variables. */
10088 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10091 if (sym
->attr
.class_ok
10092 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10094 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10095 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10096 &sym
->declared_at
);
10101 /* Assume that use associated symbols were checked in the module ns.
10102 Class-variables that are associate-names are also something special
10103 and excepted from the test. */
10104 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10106 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10107 "or pointer", sym
->name
, &sym
->declared_at
);
10116 /* Additional checks for symbols with flavor variable and derived
10117 type. To be called from resolve_fl_variable. */
10120 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10122 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10124 /* Check to see if a derived type is blocked from being host
10125 associated by the presence of another class I symbol in the same
10126 namespace. 14.6.1.3 of the standard and the discussion on
10127 comp.lang.fortran. */
10128 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10129 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10132 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10133 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10135 gfc_error ("The type '%s' cannot be host associated at %L "
10136 "because it is blocked by an incompatible object "
10137 "of the same name declared at %L",
10138 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10144 /* 4th constraint in section 11.3: "If an object of a type for which
10145 component-initialization is specified (R429) appears in the
10146 specification-part of a module and does not have the ALLOCATABLE
10147 or POINTER attribute, the object shall have the SAVE attribute."
10149 The check for initializers is performed with
10150 gfc_has_default_initializer because gfc_default_initializer generates
10151 a hidden default for allocatable components. */
10152 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10153 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10154 && !sym
->ns
->save_all
&& !sym
->attr
.save
10155 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10156 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10157 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
10158 "module variable '%s' at %L, needed due to "
10159 "the default initialization", sym
->name
,
10160 &sym
->declared_at
) == FAILURE
)
10163 /* Assign default initializer. */
10164 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10165 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10167 sym
->value
= gfc_default_initializer (&sym
->ts
);
10174 /* Resolve symbols with flavor variable. */
10177 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10179 int no_init_flag
, automatic_flag
;
10181 const char *auto_save_msg
;
10183 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10186 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10189 /* Set this flag to check that variables are parameters of all entries.
10190 This check is effected by the call to gfc_resolve_expr through
10191 is_non_constant_shape_array. */
10192 specification_expr
= 1;
10194 if (sym
->ns
->proc_name
10195 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10196 || sym
->ns
->proc_name
->attr
.is_main_program
)
10197 && !sym
->attr
.use_assoc
10198 && !sym
->attr
.allocatable
10199 && !sym
->attr
.pointer
10200 && is_non_constant_shape_array (sym
))
10202 /* The shape of a main program or module array needs to be
10204 gfc_error ("The module or main program array '%s' at %L must "
10205 "have constant shape", sym
->name
, &sym
->declared_at
);
10206 specification_expr
= 0;
10210 /* Constraints on deferred type parameter. */
10211 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10213 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10214 "requires either the pointer or allocatable attribute",
10215 sym
->name
, &sym
->declared_at
);
10219 if (sym
->ts
.type
== BT_CHARACTER
)
10221 /* Make sure that character string variables with assumed length are
10222 dummy arguments. */
10223 e
= sym
->ts
.u
.cl
->length
;
10224 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10225 && !sym
->ts
.deferred
)
10227 gfc_error ("Entity with assumed character length at %L must be a "
10228 "dummy argument or a PARAMETER", &sym
->declared_at
);
10232 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10234 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10238 if (!gfc_is_constant_expr (e
)
10239 && !(e
->expr_type
== EXPR_VARIABLE
10240 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10242 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10243 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10244 || sym
->ns
->proc_name
->attr
.is_main_program
))
10246 gfc_error ("'%s' at %L must have constant character length "
10247 "in this context", sym
->name
, &sym
->declared_at
);
10250 if (sym
->attr
.in_common
)
10252 gfc_error ("COMMON variable '%s' at %L must have constant "
10253 "character length", sym
->name
, &sym
->declared_at
);
10259 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10260 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10262 /* Determine if the symbol may not have an initializer. */
10263 no_init_flag
= automatic_flag
= 0;
10264 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10265 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10267 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10268 && is_non_constant_shape_array (sym
))
10270 no_init_flag
= automatic_flag
= 1;
10272 /* Also, they must not have the SAVE attribute.
10273 SAVE_IMPLICIT is checked below. */
10274 if (sym
->as
&& sym
->attr
.codimension
)
10276 int corank
= sym
->as
->corank
;
10277 sym
->as
->corank
= 0;
10278 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10279 sym
->as
->corank
= corank
;
10281 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10283 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10288 /* Ensure that any initializer is simplified. */
10290 gfc_simplify_expr (sym
->value
, 1);
10292 /* Reject illegal initializers. */
10293 if (!sym
->mark
&& sym
->value
)
10295 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10296 && CLASS_DATA (sym
)->attr
.allocatable
))
10297 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10298 sym
->name
, &sym
->declared_at
);
10299 else if (sym
->attr
.external
)
10300 gfc_error ("External '%s' at %L cannot have an initializer",
10301 sym
->name
, &sym
->declared_at
);
10302 else if (sym
->attr
.dummy
10303 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10304 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10305 sym
->name
, &sym
->declared_at
);
10306 else if (sym
->attr
.intrinsic
)
10307 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10308 sym
->name
, &sym
->declared_at
);
10309 else if (sym
->attr
.result
)
10310 gfc_error ("Function result '%s' at %L cannot have an initializer",
10311 sym
->name
, &sym
->declared_at
);
10312 else if (automatic_flag
)
10313 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10314 sym
->name
, &sym
->declared_at
);
10316 goto no_init_error
;
10321 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10322 return resolve_fl_variable_derived (sym
, no_init_flag
);
10328 /* Resolve a procedure. */
10331 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10333 gfc_formal_arglist
*arg
;
10335 if (sym
->attr
.function
10336 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10339 if (sym
->ts
.type
== BT_CHARACTER
)
10341 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10343 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10344 && resolve_charlen (cl
) == FAILURE
)
10347 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10348 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10350 gfc_error ("Character-valued statement function '%s' at %L must "
10351 "have constant length", sym
->name
, &sym
->declared_at
);
10356 /* Ensure that derived type for are not of a private type. Internal
10357 module procedures are excluded by 2.2.3.3 - i.e., they are not
10358 externally accessible and can access all the objects accessible in
10360 if (!(sym
->ns
->parent
10361 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10362 && gfc_check_symbol_access (sym
))
10364 gfc_interface
*iface
;
10366 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10369 && arg
->sym
->ts
.type
== BT_DERIVED
10370 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10371 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10372 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10373 "PRIVATE type and cannot be a dummy argument"
10374 " of '%s', which is PUBLIC at %L",
10375 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10378 /* Stop this message from recurring. */
10379 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10384 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10385 PRIVATE to the containing module. */
10386 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10388 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10391 && arg
->sym
->ts
.type
== BT_DERIVED
10392 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10393 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10394 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10395 "'%s' in PUBLIC interface '%s' at %L "
10396 "takes dummy arguments of '%s' which is "
10397 "PRIVATE", iface
->sym
->name
, sym
->name
,
10398 &iface
->sym
->declared_at
,
10399 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10401 /* Stop this message from recurring. */
10402 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10408 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10409 PRIVATE to the containing module. */
10410 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10412 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10415 && arg
->sym
->ts
.type
== BT_DERIVED
10416 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10417 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10418 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10419 "'%s' in PUBLIC interface '%s' at %L "
10420 "takes dummy arguments of '%s' which is "
10421 "PRIVATE", iface
->sym
->name
, sym
->name
,
10422 &iface
->sym
->declared_at
,
10423 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10425 /* Stop this message from recurring. */
10426 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10433 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10434 && !sym
->attr
.proc_pointer
)
10436 gfc_error ("Function '%s' at %L cannot have an initializer",
10437 sym
->name
, &sym
->declared_at
);
10441 /* An external symbol may not have an initializer because it is taken to be
10442 a procedure. Exception: Procedure Pointers. */
10443 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10445 gfc_error ("External object '%s' at %L may not have an initializer",
10446 sym
->name
, &sym
->declared_at
);
10450 /* An elemental function is required to return a scalar 12.7.1 */
10451 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10453 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10454 "result", sym
->name
, &sym
->declared_at
);
10455 /* Reset so that the error only occurs once. */
10456 sym
->attr
.elemental
= 0;
10460 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10461 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10463 gfc_error ("Statement function '%s' at %L may not have pointer or "
10464 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10468 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10469 char-len-param shall not be array-valued, pointer-valued, recursive
10470 or pure. ....snip... A character value of * may only be used in the
10471 following ways: (i) Dummy arg of procedure - dummy associates with
10472 actual length; (ii) To declare a named constant; or (iii) External
10473 function - but length must be declared in calling scoping unit. */
10474 if (sym
->attr
.function
10475 && sym
->ts
.type
== BT_CHARACTER
10476 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10478 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10479 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10481 if (sym
->as
&& sym
->as
->rank
)
10482 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10483 "array-valued", sym
->name
, &sym
->declared_at
);
10485 if (sym
->attr
.pointer
)
10486 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10487 "pointer-valued", sym
->name
, &sym
->declared_at
);
10489 if (sym
->attr
.pure
)
10490 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10491 "pure", sym
->name
, &sym
->declared_at
);
10493 if (sym
->attr
.recursive
)
10494 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10495 "recursive", sym
->name
, &sym
->declared_at
);
10500 /* Appendix B.2 of the standard. Contained functions give an
10501 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10502 character length is an F2003 feature. */
10503 if (!sym
->attr
.contained
10504 && gfc_current_form
!= FORM_FIXED
10505 && !sym
->ts
.deferred
)
10506 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10507 "CHARACTER(*) function '%s' at %L",
10508 sym
->name
, &sym
->declared_at
);
10511 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10513 gfc_formal_arglist
*curr_arg
;
10514 int has_non_interop_arg
= 0;
10516 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10517 sym
->common_block
) == FAILURE
)
10519 /* Clear these to prevent looking at them again if there was an
10521 sym
->attr
.is_bind_c
= 0;
10522 sym
->attr
.is_c_interop
= 0;
10523 sym
->ts
.is_c_interop
= 0;
10527 /* So far, no errors have been found. */
10528 sym
->attr
.is_c_interop
= 1;
10529 sym
->ts
.is_c_interop
= 1;
10532 curr_arg
= sym
->formal
;
10533 while (curr_arg
!= NULL
)
10535 /* Skip implicitly typed dummy args here. */
10536 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10537 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10538 /* If something is found to fail, record the fact so we
10539 can mark the symbol for the procedure as not being
10540 BIND(C) to try and prevent multiple errors being
10542 has_non_interop_arg
= 1;
10544 curr_arg
= curr_arg
->next
;
10547 /* See if any of the arguments were not interoperable and if so, clear
10548 the procedure symbol to prevent duplicate error messages. */
10549 if (has_non_interop_arg
!= 0)
10551 sym
->attr
.is_c_interop
= 0;
10552 sym
->ts
.is_c_interop
= 0;
10553 sym
->attr
.is_bind_c
= 0;
10557 if (!sym
->attr
.proc_pointer
)
10559 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10561 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10562 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10565 if (sym
->attr
.intent
)
10567 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10568 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10571 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10573 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10574 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10577 if (sym
->attr
.external
&& sym
->attr
.function
10578 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10579 || sym
->attr
.contained
))
10581 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10582 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10585 if (strcmp ("ppr@", sym
->name
) == 0)
10587 gfc_error ("Procedure pointer result '%s' at %L "
10588 "is missing the pointer attribute",
10589 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10598 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10599 been defined and we now know their defined arguments, check that they fulfill
10600 the requirements of the standard for procedures used as finalizers. */
10603 gfc_resolve_finalizers (gfc_symbol
* derived
)
10605 gfc_finalizer
* list
;
10606 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10607 gfc_try result
= SUCCESS
;
10608 bool seen_scalar
= false;
10610 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10613 /* Walk over the list of finalizer-procedures, check them, and if any one
10614 does not fit in with the standard's definition, print an error and remove
10615 it from the list. */
10616 prev_link
= &derived
->f2k_derived
->finalizers
;
10617 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10623 /* Skip this finalizer if we already resolved it. */
10624 if (list
->proc_tree
)
10626 prev_link
= &(list
->next
);
10630 /* Check this exists and is a SUBROUTINE. */
10631 if (!list
->proc_sym
->attr
.subroutine
)
10633 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10634 list
->proc_sym
->name
, &list
->where
);
10638 /* We should have exactly one argument. */
10639 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10641 gfc_error ("FINAL procedure at %L must have exactly one argument",
10645 arg
= list
->proc_sym
->formal
->sym
;
10647 /* This argument must be of our type. */
10648 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10650 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10651 &arg
->declared_at
, derived
->name
);
10655 /* It must neither be a pointer nor allocatable nor optional. */
10656 if (arg
->attr
.pointer
)
10658 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10659 &arg
->declared_at
);
10662 if (arg
->attr
.allocatable
)
10664 gfc_error ("Argument of FINAL procedure at %L must not be"
10665 " ALLOCATABLE", &arg
->declared_at
);
10668 if (arg
->attr
.optional
)
10670 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10671 &arg
->declared_at
);
10675 /* It must not be INTENT(OUT). */
10676 if (arg
->attr
.intent
== INTENT_OUT
)
10678 gfc_error ("Argument of FINAL procedure at %L must not be"
10679 " INTENT(OUT)", &arg
->declared_at
);
10683 /* Warn if the procedure is non-scalar and not assumed shape. */
10684 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10685 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10686 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10687 " shape argument", &arg
->declared_at
);
10689 /* Check that it does not match in kind and rank with a FINAL procedure
10690 defined earlier. To really loop over the *earlier* declarations,
10691 we need to walk the tail of the list as new ones were pushed at the
10693 /* TODO: Handle kind parameters once they are implemented. */
10694 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10695 for (i
= list
->next
; i
; i
= i
->next
)
10697 /* Argument list might be empty; that is an error signalled earlier,
10698 but we nevertheless continued resolving. */
10699 if (i
->proc_sym
->formal
)
10701 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10702 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10703 if (i_rank
== my_rank
)
10705 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10706 " rank (%d) as '%s'",
10707 list
->proc_sym
->name
, &list
->where
, my_rank
,
10708 i
->proc_sym
->name
);
10714 /* Is this the/a scalar finalizer procedure? */
10715 if (!arg
->as
|| arg
->as
->rank
== 0)
10716 seen_scalar
= true;
10718 /* Find the symtree for this procedure. */
10719 gcc_assert (!list
->proc_tree
);
10720 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10722 prev_link
= &list
->next
;
10725 /* Remove wrong nodes immediately from the list so we don't risk any
10726 troubles in the future when they might fail later expectations. */
10730 *prev_link
= list
->next
;
10731 gfc_free_finalizer (i
);
10734 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10735 were nodes in the list, must have been for arrays. It is surely a good
10736 idea to have a scalar version there if there's something to finalize. */
10737 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10738 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10739 " defined at %L, suggest also scalar one",
10740 derived
->name
, &derived
->declared_at
);
10742 /* TODO: Remove this error when finalization is finished. */
10743 gfc_error ("Finalization at %L is not yet implemented",
10744 &derived
->declared_at
);
10750 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10753 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
10754 const char* generic_name
, locus where
)
10759 gcc_assert (t1
->specific
&& t2
->specific
);
10760 gcc_assert (!t1
->specific
->is_generic
);
10761 gcc_assert (!t2
->specific
->is_generic
);
10763 sym1
= t1
->specific
->u
.specific
->n
.sym
;
10764 sym2
= t2
->specific
->u
.specific
->n
.sym
;
10769 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10770 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
10771 || sym1
->attr
.function
!= sym2
->attr
.function
)
10773 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10774 " GENERIC '%s' at %L",
10775 sym1
->name
, sym2
->name
, generic_name
, &where
);
10779 /* Compare the interfaces. */
10780 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, 1, 0, NULL
, 0))
10782 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10783 sym1
->name
, sym2
->name
, generic_name
, &where
);
10791 /* Worker function for resolving a generic procedure binding; this is used to
10792 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10794 The difference between those cases is finding possible inherited bindings
10795 that are overridden, as one has to look for them in tb_sym_root,
10796 tb_uop_root or tb_op, respectively. Thus the caller must already find
10797 the super-type and set p->overridden correctly. */
10800 resolve_tb_generic_targets (gfc_symbol
* super_type
,
10801 gfc_typebound_proc
* p
, const char* name
)
10803 gfc_tbp_generic
* target
;
10804 gfc_symtree
* first_target
;
10805 gfc_symtree
* inherited
;
10807 gcc_assert (p
&& p
->is_generic
);
10809 /* Try to find the specific bindings for the symtrees in our target-list. */
10810 gcc_assert (p
->u
.generic
);
10811 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10812 if (!target
->specific
)
10814 gfc_typebound_proc
* overridden_tbp
;
10815 gfc_tbp_generic
* g
;
10816 const char* target_name
;
10818 target_name
= target
->specific_st
->name
;
10820 /* Defined for this type directly. */
10821 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
10823 target
->specific
= target
->specific_st
->n
.tb
;
10824 goto specific_found
;
10827 /* Look for an inherited specific binding. */
10830 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
10835 gcc_assert (inherited
->n
.tb
);
10836 target
->specific
= inherited
->n
.tb
;
10837 goto specific_found
;
10841 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10842 " at %L", target_name
, name
, &p
->where
);
10845 /* Once we've found the specific binding, check it is not ambiguous with
10846 other specifics already found or inherited for the same GENERIC. */
10848 gcc_assert (target
->specific
);
10850 /* This must really be a specific binding! */
10851 if (target
->specific
->is_generic
)
10853 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10854 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
10858 /* Check those already resolved on this type directly. */
10859 for (g
= p
->u
.generic
; g
; g
= g
->next
)
10860 if (g
!= target
&& g
->specific
10861 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
10865 /* Check for ambiguity with inherited specific targets. */
10866 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
10867 overridden_tbp
= overridden_tbp
->overridden
)
10868 if (overridden_tbp
->is_generic
)
10870 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
10872 gcc_assert (g
->specific
);
10873 if (check_generic_tbp_ambiguity (target
, g
,
10874 name
, p
->where
) == FAILURE
)
10880 /* If we attempt to "overwrite" a specific binding, this is an error. */
10881 if (p
->overridden
&& !p
->overridden
->is_generic
)
10883 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10884 " the same name", name
, &p
->where
);
10888 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10889 all must have the same attributes here. */
10890 first_target
= p
->u
.generic
->specific
->u
.specific
;
10891 gcc_assert (first_target
);
10892 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
10893 p
->function
= first_target
->n
.sym
->attr
.function
;
10899 /* Resolve a GENERIC procedure binding for a derived type. */
10902 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
10904 gfc_symbol
* super_type
;
10906 /* Find the overridden binding if any. */
10907 st
->n
.tb
->overridden
= NULL
;
10908 super_type
= gfc_get_derived_super_type (derived
);
10911 gfc_symtree
* overridden
;
10912 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
10915 if (overridden
&& overridden
->n
.tb
)
10916 st
->n
.tb
->overridden
= overridden
->n
.tb
;
10919 /* Resolve using worker function. */
10920 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
10924 /* Retrieve the target-procedure of an operator binding and do some checks in
10925 common for intrinsic and user-defined type-bound operators. */
10928 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
10930 gfc_symbol
* target_proc
;
10932 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
10933 target_proc
= target
->specific
->u
.specific
->n
.sym
;
10934 gcc_assert (target_proc
);
10936 /* All operator bindings must have a passed-object dummy argument. */
10937 if (target
->specific
->nopass
)
10939 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
10943 return target_proc
;
10947 /* Resolve a type-bound intrinsic operator. */
10950 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
10951 gfc_typebound_proc
* p
)
10953 gfc_symbol
* super_type
;
10954 gfc_tbp_generic
* target
;
10956 /* If there's already an error here, do nothing (but don't fail again). */
10960 /* Operators should always be GENERIC bindings. */
10961 gcc_assert (p
->is_generic
);
10963 /* Look for an overridden binding. */
10964 super_type
= gfc_get_derived_super_type (derived
);
10965 if (super_type
&& super_type
->f2k_derived
)
10966 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
10969 p
->overridden
= NULL
;
10971 /* Resolve general GENERIC properties using worker function. */
10972 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
10975 /* Check the targets to be procedures of correct interface. */
10976 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10978 gfc_symbol
* target_proc
;
10980 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
10984 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
10996 /* Resolve a type-bound user operator (tree-walker callback). */
10998 static gfc_symbol
* resolve_bindings_derived
;
10999 static gfc_try resolve_bindings_result
;
11001 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11004 resolve_typebound_user_op (gfc_symtree
* stree
)
11006 gfc_symbol
* super_type
;
11007 gfc_tbp_generic
* target
;
11009 gcc_assert (stree
&& stree
->n
.tb
);
11011 if (stree
->n
.tb
->error
)
11014 /* Operators should always be GENERIC bindings. */
11015 gcc_assert (stree
->n
.tb
->is_generic
);
11017 /* Find overridden procedure, if any. */
11018 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11019 if (super_type
&& super_type
->f2k_derived
)
11021 gfc_symtree
* overridden
;
11022 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11023 stree
->name
, true, NULL
);
11025 if (overridden
&& overridden
->n
.tb
)
11026 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11029 stree
->n
.tb
->overridden
= NULL
;
11031 /* Resolve basically using worker function. */
11032 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11036 /* Check the targets to be functions of correct interface. */
11037 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11039 gfc_symbol
* target_proc
;
11041 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11045 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11052 resolve_bindings_result
= FAILURE
;
11053 stree
->n
.tb
->error
= 1;
11057 /* Resolve the type-bound procedures for a derived type. */
11060 resolve_typebound_procedure (gfc_symtree
* stree
)
11064 gfc_symbol
* me_arg
;
11065 gfc_symbol
* super_type
;
11066 gfc_component
* comp
;
11068 gcc_assert (stree
);
11070 /* Undefined specific symbol from GENERIC target definition. */
11074 if (stree
->n
.tb
->error
)
11077 /* If this is a GENERIC binding, use that routine. */
11078 if (stree
->n
.tb
->is_generic
)
11080 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11086 /* Get the target-procedure to check it. */
11087 gcc_assert (!stree
->n
.tb
->is_generic
);
11088 gcc_assert (stree
->n
.tb
->u
.specific
);
11089 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11090 where
= stree
->n
.tb
->where
;
11092 /* Default access should already be resolved from the parser. */
11093 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11095 /* It should be a module procedure or an external procedure with explicit
11096 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11097 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11098 || (proc
->attr
.proc
!= PROC_MODULE
11099 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11100 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11102 gfc_error ("'%s' must be a module procedure or an external procedure with"
11103 " an explicit interface at %L", proc
->name
, &where
);
11106 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11107 stree
->n
.tb
->function
= proc
->attr
.function
;
11109 /* Find the super-type of the current derived type. We could do this once and
11110 store in a global if speed is needed, but as long as not I believe this is
11111 more readable and clearer. */
11112 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11114 /* If PASS, resolve and check arguments if not already resolved / loaded
11115 from a .mod file. */
11116 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11118 if (stree
->n
.tb
->pass_arg
)
11120 gfc_formal_arglist
* i
;
11122 /* If an explicit passing argument name is given, walk the arg-list
11123 and look for it. */
11126 stree
->n
.tb
->pass_arg_num
= 1;
11127 for (i
= proc
->formal
; i
; i
= i
->next
)
11129 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11134 ++stree
->n
.tb
->pass_arg_num
;
11139 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11141 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11142 stree
->n
.tb
->pass_arg
);
11148 /* Otherwise, take the first one; there should in fact be at least
11150 stree
->n
.tb
->pass_arg_num
= 1;
11153 gfc_error ("Procedure '%s' with PASS at %L must have at"
11154 " least one argument", proc
->name
, &where
);
11157 me_arg
= proc
->formal
->sym
;
11160 /* Now check that the argument-type matches and the passed-object
11161 dummy argument is generally fine. */
11163 gcc_assert (me_arg
);
11165 if (me_arg
->ts
.type
!= BT_CLASS
)
11167 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11168 " at %L", proc
->name
, &where
);
11172 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11173 != resolve_bindings_derived
)
11175 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11176 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11177 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11181 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11182 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11184 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11185 " scalar", proc
->name
, &where
);
11188 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11190 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11191 " be ALLOCATABLE", proc
->name
, &where
);
11194 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11196 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11197 " be POINTER", proc
->name
, &where
);
11202 /* If we are extending some type, check that we don't override a procedure
11203 flagged NON_OVERRIDABLE. */
11204 stree
->n
.tb
->overridden
= NULL
;
11207 gfc_symtree
* overridden
;
11208 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11209 stree
->name
, true, NULL
);
11213 if (overridden
->n
.tb
)
11214 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11216 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11221 /* See if there's a name collision with a component directly in this type. */
11222 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11223 if (!strcmp (comp
->name
, stree
->name
))
11225 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11227 stree
->name
, &where
, resolve_bindings_derived
->name
);
11231 /* Try to find a name collision with an inherited component. */
11232 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11234 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11235 " component of '%s'",
11236 stree
->name
, &where
, resolve_bindings_derived
->name
);
11240 stree
->n
.tb
->error
= 0;
11244 resolve_bindings_result
= FAILURE
;
11245 stree
->n
.tb
->error
= 1;
11250 resolve_typebound_procedures (gfc_symbol
* derived
)
11253 gfc_symbol
* super_type
;
11255 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11258 super_type
= gfc_get_derived_super_type (derived
);
11260 resolve_typebound_procedures (super_type
);
11262 resolve_bindings_derived
= derived
;
11263 resolve_bindings_result
= SUCCESS
;
11265 /* Make sure the vtab has been generated. */
11266 gfc_find_derived_vtab (derived
);
11268 if (derived
->f2k_derived
->tb_sym_root
)
11269 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11270 &resolve_typebound_procedure
);
11272 if (derived
->f2k_derived
->tb_uop_root
)
11273 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11274 &resolve_typebound_user_op
);
11276 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11278 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11279 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11281 resolve_bindings_result
= FAILURE
;
11284 return resolve_bindings_result
;
11288 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11289 to give all identical derived types the same backend_decl. */
11291 add_dt_to_dt_list (gfc_symbol
*derived
)
11293 gfc_dt_list
*dt_list
;
11295 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11296 if (derived
== dt_list
->derived
)
11299 dt_list
= gfc_get_dt_list ();
11300 dt_list
->next
= gfc_derived_types
;
11301 dt_list
->derived
= derived
;
11302 gfc_derived_types
= dt_list
;
11306 /* Ensure that a derived-type is really not abstract, meaning that every
11307 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11310 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11315 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11317 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11320 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11322 gfc_symtree
* overriding
;
11323 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11326 gcc_assert (overriding
->n
.tb
);
11327 if (overriding
->n
.tb
->deferred
)
11329 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11330 " '%s' is DEFERRED and not overridden",
11331 sub
->name
, &sub
->declared_at
, st
->name
);
11340 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11342 /* The algorithm used here is to recursively travel up the ancestry of sub
11343 and for each ancestor-type, check all bindings. If any of them is
11344 DEFERRED, look it up starting from sub and see if the found (overriding)
11345 binding is not DEFERRED.
11346 This is not the most efficient way to do this, but it should be ok and is
11347 clearer than something sophisticated. */
11349 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11351 if (!ancestor
->attr
.abstract
)
11354 /* Walk bindings of this ancestor. */
11355 if (ancestor
->f2k_derived
)
11358 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11363 /* Find next ancestor type and recurse on it. */
11364 ancestor
= gfc_get_derived_super_type (ancestor
);
11366 return ensure_not_abstract (sub
, ancestor
);
11372 /* Resolve the components of a derived type. This does not have to wait until
11373 resolution stage, but can be done as soon as the dt declaration has been
11377 resolve_fl_derived0 (gfc_symbol
*sym
)
11379 gfc_symbol
* super_type
;
11382 super_type
= gfc_get_derived_super_type (sym
);
11385 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11387 gfc_error ("As extending type '%s' at %L has a coarray component, "
11388 "parent type '%s' shall also have one", sym
->name
,
11389 &sym
->declared_at
, super_type
->name
);
11393 /* Ensure the extended type gets resolved before we do. */
11394 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11397 /* An ABSTRACT type must be extensible. */
11398 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11400 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11401 sym
->name
, &sym
->declared_at
);
11405 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
11408 if (c
->attr
.codimension
/* FIXME: c->as check due to PR 43412. */
11409 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11411 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11412 "deferred shape", c
->name
, &c
->loc
);
11417 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11418 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11420 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11421 "shall not be a coarray", c
->name
, &c
->loc
);
11426 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11427 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11428 || c
->attr
.allocatable
))
11430 gfc_error ("Component '%s' at %L with coarray component "
11431 "shall be a nonpointer, nonallocatable scalar",
11437 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11439 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11440 "is not an array pointer", c
->name
, &c
->loc
);
11444 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11446 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11447 gfc_error ("Interface '%s', used by procedure pointer component "
11448 "'%s' at %L, is declared in a later PROCEDURE statement",
11449 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11451 /* Get the attributes from the interface (now resolved). */
11452 if (c
->ts
.interface
->attr
.if_source
11453 || c
->ts
.interface
->attr
.intrinsic
)
11455 gfc_symbol
*ifc
= c
->ts
.interface
;
11457 if (ifc
->formal
&& !ifc
->formal_ns
)
11458 resolve_symbol (ifc
);
11460 if (ifc
->attr
.intrinsic
)
11461 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11465 c
->ts
= ifc
->result
->ts
;
11466 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11467 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11468 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11469 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11474 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11475 c
->attr
.pointer
= ifc
->attr
.pointer
;
11476 c
->attr
.dimension
= ifc
->attr
.dimension
;
11477 c
->as
= gfc_copy_array_spec (ifc
->as
);
11479 c
->ts
.interface
= ifc
;
11480 c
->attr
.function
= ifc
->attr
.function
;
11481 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11482 gfc_copy_formal_args_ppc (c
, ifc
);
11484 c
->attr
.pure
= ifc
->attr
.pure
;
11485 c
->attr
.elemental
= ifc
->attr
.elemental
;
11486 c
->attr
.recursive
= ifc
->attr
.recursive
;
11487 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11488 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11489 /* Replace symbols in array spec. */
11493 for (i
= 0; i
< c
->as
->rank
; i
++)
11495 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11496 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11499 /* Copy char length. */
11500 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11502 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11503 gfc_expr_replace_comp (cl
->length
, c
);
11504 if (cl
->length
&& !cl
->resolved
11505 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11510 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11512 gfc_error ("Interface '%s' of procedure pointer component "
11513 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11518 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11520 /* Since PPCs are not implicitly typed, a PPC without an explicit
11521 interface must be a subroutine. */
11522 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11525 /* Procedure pointer components: Check PASS arg. */
11526 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11527 && !sym
->attr
.vtype
)
11529 gfc_symbol
* me_arg
;
11531 if (c
->tb
->pass_arg
)
11533 gfc_formal_arglist
* i
;
11535 /* If an explicit passing argument name is given, walk the arg-list
11536 and look for it. */
11539 c
->tb
->pass_arg_num
= 1;
11540 for (i
= c
->formal
; i
; i
= i
->next
)
11542 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11547 c
->tb
->pass_arg_num
++;
11552 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11553 "at %L has no argument '%s'", c
->name
,
11554 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11561 /* Otherwise, take the first one; there should in fact be at least
11563 c
->tb
->pass_arg_num
= 1;
11566 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11567 "must have at least one argument",
11572 me_arg
= c
->formal
->sym
;
11575 /* Now check that the argument-type matches. */
11576 gcc_assert (me_arg
);
11577 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11578 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11579 || (me_arg
->ts
.type
== BT_CLASS
11580 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11582 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11583 " the derived type '%s'", me_arg
->name
, c
->name
,
11584 me_arg
->name
, &c
->loc
, sym
->name
);
11589 /* Check for C453. */
11590 if (me_arg
->attr
.dimension
)
11592 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11593 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11599 if (me_arg
->attr
.pointer
)
11601 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11602 "may not have the POINTER attribute", me_arg
->name
,
11603 c
->name
, me_arg
->name
, &c
->loc
);
11608 if (me_arg
->attr
.allocatable
)
11610 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11611 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11612 me_arg
->name
, &c
->loc
);
11617 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11618 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11619 " at %L", c
->name
, &c
->loc
);
11623 /* Check type-spec if this is not the parent-type component. */
11624 if ((!sym
->attr
.extension
|| c
!= sym
->components
) && !sym
->attr
.vtype
11625 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11628 /* If this type is an extension, set the accessibility of the parent
11630 if (super_type
&& c
== sym
->components
11631 && strcmp (super_type
->name
, c
->name
) == 0)
11632 c
->attr
.access
= super_type
->attr
.access
;
11634 /* If this type is an extension, see if this component has the same name
11635 as an inherited type-bound procedure. */
11636 if (super_type
&& !sym
->attr
.is_class
11637 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11639 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11640 " inherited type-bound procedure",
11641 c
->name
, sym
->name
, &c
->loc
);
11645 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11646 && !c
->ts
.deferred
)
11648 if (c
->ts
.u
.cl
->length
== NULL
11649 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11650 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11652 gfc_error ("Character length of component '%s' needs to "
11653 "be a constant specification expression at %L",
11655 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11660 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11661 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11663 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11664 "length must be a POINTER or ALLOCATABLE",
11665 c
->name
, sym
->name
, &c
->loc
);
11669 if (c
->ts
.type
== BT_DERIVED
11670 && sym
->component_access
!= ACCESS_PRIVATE
11671 && gfc_check_symbol_access (sym
)
11672 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11673 && !c
->ts
.u
.derived
->attr
.use_assoc
11674 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
11675 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11676 "is a PRIVATE type and cannot be a component of "
11677 "'%s', which is PUBLIC at %L", c
->name
,
11678 sym
->name
, &sym
->declared_at
) == FAILURE
)
11681 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11683 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11684 "type %s", c
->name
, &c
->loc
, sym
->name
);
11688 if (sym
->attr
.sequence
)
11690 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11692 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11693 "not have the SEQUENCE attribute",
11694 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11699 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11700 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11701 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11703 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11704 "that has not been declared", c
->name
, sym
->name
,
11709 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11710 && CLASS_DATA (c
)->attr
.class_pointer
11711 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11712 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11714 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11715 "that has not been declared", c
->name
, sym
->name
,
11721 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
11722 && (!c
->attr
.class_ok
11723 || !(CLASS_DATA (c
)->attr
.class_pointer
11724 || CLASS_DATA (c
)->attr
.allocatable
)))
11726 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11727 "or pointer", c
->name
, &c
->loc
);
11731 /* Ensure that all the derived type components are put on the
11732 derived type list; even in formal namespaces, where derived type
11733 pointer components might not have been declared. */
11734 if (c
->ts
.type
== BT_DERIVED
11736 && c
->ts
.u
.derived
->components
11738 && sym
!= c
->ts
.u
.derived
)
11739 add_dt_to_dt_list (c
->ts
.u
.derived
);
11741 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
11742 || c
->attr
.proc_pointer
11743 || c
->attr
.allocatable
)) == FAILURE
)
11747 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11748 all DEFERRED bindings are overridden. */
11749 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
11750 && !sym
->attr
.is_class
11751 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
11754 /* Add derived type to the derived type list. */
11755 add_dt_to_dt_list (sym
);
11761 /* The following procedure does the full resolution of a derived type,
11762 including resolution of all type-bound procedures (if present). In contrast
11763 to 'resolve_fl_derived0' this can only be done after the module has been
11764 parsed completely. */
11767 resolve_fl_derived (gfc_symbol
*sym
)
11769 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
11771 /* Fix up incomplete CLASS symbols. */
11772 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
11773 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
11774 if (vptr
->ts
.u
.derived
== NULL
)
11776 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
11778 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
11782 if (resolve_fl_derived0 (sym
) == FAILURE
)
11785 /* Resolve the type-bound procedures. */
11786 if (resolve_typebound_procedures (sym
) == FAILURE
)
11789 /* Resolve the finalizer procedures. */
11790 if (gfc_resolve_finalizers (sym
) == FAILURE
)
11798 resolve_fl_namelist (gfc_symbol
*sym
)
11803 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11805 /* Check again, the check in match only works if NAMELIST comes
11807 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
11809 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11810 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11814 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
11815 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11816 "object '%s' with assumed shape in namelist "
11817 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11818 &sym
->declared_at
) == FAILURE
)
11821 if (is_non_constant_shape_array (nl
->sym
)
11822 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11823 "object '%s' with nonconstant shape in namelist "
11824 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11825 &sym
->declared_at
) == FAILURE
)
11828 if (nl
->sym
->ts
.type
== BT_CHARACTER
11829 && (nl
->sym
->ts
.u
.cl
->length
== NULL
11830 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
11831 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11832 "'%s' with nonconstant character length in "
11833 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
11834 &sym
->declared_at
) == FAILURE
)
11837 /* FIXME: Once UDDTIO is implemented, the following can be
11839 if (nl
->sym
->ts
.type
== BT_CLASS
)
11841 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11842 "polymorphic and requires a defined input/output "
11843 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11847 if (nl
->sym
->ts
.type
== BT_DERIVED
11848 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
11849 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
11851 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11852 "'%s' in namelist '%s' at %L with ALLOCATABLE "
11853 "or POINTER components", nl
->sym
->name
,
11854 sym
->name
, &sym
->declared_at
) == FAILURE
)
11857 /* FIXME: Once UDDTIO is implemented, the following can be
11859 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11860 "ALLOCATABLE or POINTER components and thus requires "
11861 "a defined input/output procedure", nl
->sym
->name
,
11862 sym
->name
, &sym
->declared_at
);
11867 /* Reject PRIVATE objects in a PUBLIC namelist. */
11868 if (gfc_check_symbol_access (sym
))
11870 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11872 if (!nl
->sym
->attr
.use_assoc
11873 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
11874 && !gfc_check_symbol_access (nl
->sym
))
11876 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11877 "cannot be member of PUBLIC namelist '%s' at %L",
11878 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11882 /* Types with private components that came here by USE-association. */
11883 if (nl
->sym
->ts
.type
== BT_DERIVED
11884 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
11886 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11887 "components and cannot be member of namelist '%s' at %L",
11888 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11892 /* Types with private components that are defined in the same module. */
11893 if (nl
->sym
->ts
.type
== BT_DERIVED
11894 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
11895 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
11897 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11898 "cannot be a member of PUBLIC namelist '%s' at %L",
11899 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11906 /* 14.1.2 A module or internal procedure represent local entities
11907 of the same type as a namelist member and so are not allowed. */
11908 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11910 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
11913 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
11914 if ((nl
->sym
== sym
->ns
->proc_name
)
11916 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
11920 if (nl
->sym
&& nl
->sym
->name
)
11921 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
11922 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
11924 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11925 "attribute in '%s' at %L", nlsym
->name
,
11926 &sym
->declared_at
);
11936 resolve_fl_parameter (gfc_symbol
*sym
)
11938 /* A parameter array's shape needs to be constant. */
11939 if (sym
->as
!= NULL
11940 && (sym
->as
->type
== AS_DEFERRED
11941 || is_non_constant_shape_array (sym
)))
11943 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11944 "or of deferred shape", sym
->name
, &sym
->declared_at
);
11948 /* Make sure a parameter that has been implicitly typed still
11949 matches the implicit type, since PARAMETER statements can precede
11950 IMPLICIT statements. */
11951 if (sym
->attr
.implicit_type
11952 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
11955 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11956 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
11960 /* Make sure the types of derived parameters are consistent. This
11961 type checking is deferred until resolution because the type may
11962 refer to a derived type from the host. */
11963 if (sym
->ts
.type
== BT_DERIVED
11964 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
11966 gfc_error ("Incompatible derived type in PARAMETER at %L",
11967 &sym
->value
->where
);
11974 /* Do anything necessary to resolve a symbol. Right now, we just
11975 assume that an otherwise unknown symbol is a variable. This sort
11976 of thing commonly happens for symbols in module. */
11979 resolve_symbol (gfc_symbol
*sym
)
11981 int check_constant
, mp_flag
;
11982 gfc_symtree
*symtree
;
11983 gfc_symtree
*this_symtree
;
11987 if (sym
->attr
.flavor
== FL_UNKNOWN
)
11990 /* If we find that a flavorless symbol is an interface in one of the
11991 parent namespaces, find its symtree in this namespace, free the
11992 symbol and set the symtree to point to the interface symbol. */
11993 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
11995 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
11996 if (symtree
&& (symtree
->n
.sym
->generic
||
11997 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
11998 && sym
->ns
->construct_entities
)))
12000 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12002 gfc_release_symbol (sym
);
12003 symtree
->n
.sym
->refs
++;
12004 this_symtree
->n
.sym
= symtree
->n
.sym
;
12009 /* Otherwise give it a flavor according to such attributes as
12011 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
12012 sym
->attr
.flavor
= FL_VARIABLE
;
12015 sym
->attr
.flavor
= FL_PROCEDURE
;
12016 if (sym
->attr
.dimension
)
12017 sym
->attr
.function
= 1;
12021 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12022 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12024 if (sym
->attr
.procedure
&& sym
->ts
.interface
12025 && sym
->attr
.if_source
!= IFSRC_DECL
12026 && resolve_procedure_interface (sym
) == FAILURE
)
12029 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12030 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12032 if (sym
->attr
.external
)
12033 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12034 "at %L", &sym
->declared_at
);
12036 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12037 "at %L", &sym
->declared_at
);
12044 if (sym
->attr
.contiguous
12045 && (!sym
->attr
.dimension
|| (sym
->as
->type
!= AS_ASSUMED_SHAPE
12046 && !sym
->attr
.pointer
)))
12048 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12049 "array pointer or an assumed-shape array", sym
->name
,
12050 &sym
->declared_at
);
12054 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12057 /* Symbols that are module procedures with results (functions) have
12058 the types and array specification copied for type checking in
12059 procedures that call them, as well as for saving to a module
12060 file. These symbols can't stand the scrutiny that their results
12062 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12064 /* Make sure that the intrinsic is consistent with its internal
12065 representation. This needs to be done before assigning a default
12066 type to avoid spurious warnings. */
12067 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12068 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12071 /* Resolve associate names. */
12073 resolve_assoc_var (sym
, true);
12075 /* Assign default type to symbols that need one and don't have one. */
12076 if (sym
->ts
.type
== BT_UNKNOWN
)
12078 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12079 gfc_set_default_type (sym
, 1, NULL
);
12081 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12082 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12083 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12084 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12086 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12088 /* The specific case of an external procedure should emit an error
12089 in the case that there is no implicit type. */
12091 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12094 /* Result may be in another namespace. */
12095 resolve_symbol (sym
->result
);
12097 if (!sym
->result
->attr
.proc_pointer
)
12099 sym
->ts
= sym
->result
->ts
;
12100 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12101 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12102 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12103 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12104 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12109 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12110 gfc_resolve_array_spec (sym
->result
->as
, false);
12112 /* Assumed size arrays and assumed shape arrays must be dummy
12113 arguments. Array-spec's of implied-shape should have been resolved to
12114 AS_EXPLICIT already. */
12118 gcc_assert (sym
->as
->type
!= AS_IMPLIED_SHAPE
);
12119 if (((sym
->as
->type
== AS_ASSUMED_SIZE
&& !sym
->as
->cp_was_assumed
)
12120 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
12121 && sym
->attr
.dummy
== 0)
12123 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
12124 gfc_error ("Assumed size array at %L must be a dummy argument",
12125 &sym
->declared_at
);
12127 gfc_error ("Assumed shape array at %L must be a dummy argument",
12128 &sym
->declared_at
);
12133 /* Make sure symbols with known intent or optional are really dummy
12134 variable. Because of ENTRY statement, this has to be deferred
12135 until resolution time. */
12137 if (!sym
->attr
.dummy
12138 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12140 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12144 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12146 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12147 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12151 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12153 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12154 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12156 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12157 "attribute must have constant length",
12158 sym
->name
, &sym
->declared_at
);
12162 if (sym
->ts
.is_c_interop
12163 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12165 gfc_error ("C interoperable character dummy variable '%s' at %L "
12166 "with VALUE attribute must have length one",
12167 sym
->name
, &sym
->declared_at
);
12172 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12173 do this for something that was implicitly typed because that is handled
12174 in gfc_set_default_type. Handle dummy arguments and procedure
12175 definitions separately. Also, anything that is use associated is not
12176 handled here but instead is handled in the module it is declared in.
12177 Finally, derived type definitions are allowed to be BIND(C) since that
12178 only implies that they're interoperable, and they are checked fully for
12179 interoperability when a variable is declared of that type. */
12180 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12181 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12182 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12184 gfc_try t
= SUCCESS
;
12186 /* First, make sure the variable is declared at the
12187 module-level scope (J3/04-007, Section 15.3). */
12188 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12189 sym
->attr
.in_common
== 0)
12191 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12192 "is neither a COMMON block nor declared at the "
12193 "module level scope", sym
->name
, &(sym
->declared_at
));
12196 else if (sym
->common_head
!= NULL
)
12198 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12202 /* If type() declaration, we need to verify that the components
12203 of the given type are all C interoperable, etc. */
12204 if (sym
->ts
.type
== BT_DERIVED
&&
12205 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12207 /* Make sure the user marked the derived type as BIND(C). If
12208 not, call the verify routine. This could print an error
12209 for the derived type more than once if multiple variables
12210 of that type are declared. */
12211 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12212 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12216 /* Verify the variable itself as C interoperable if it
12217 is BIND(C). It is not possible for this to succeed if
12218 the verify_bind_c_derived_type failed, so don't have to handle
12219 any error returned by verify_bind_c_derived_type. */
12220 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12221 sym
->common_block
);
12226 /* clear the is_bind_c flag to prevent reporting errors more than
12227 once if something failed. */
12228 sym
->attr
.is_bind_c
= 0;
12233 /* If a derived type symbol has reached this point, without its
12234 type being declared, we have an error. Notice that most
12235 conditions that produce undefined derived types have already
12236 been dealt with. However, the likes of:
12237 implicit type(t) (t) ..... call foo (t) will get us here if
12238 the type is not declared in the scope of the implicit
12239 statement. Change the type to BT_UNKNOWN, both because it is so
12240 and to prevent an ICE. */
12241 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->components
== NULL
12242 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12244 gfc_error ("The derived type '%s' at %L is of type '%s', "
12245 "which has not been defined", sym
->name
,
12246 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12247 sym
->ts
.type
= BT_UNKNOWN
;
12251 /* Make sure that the derived type has been resolved and that the
12252 derived type is visible in the symbol's namespace, if it is a
12253 module function and is not PRIVATE. */
12254 if (sym
->ts
.type
== BT_DERIVED
12255 && sym
->ts
.u
.derived
->attr
.use_assoc
12256 && sym
->ns
->proc_name
12257 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12261 if (resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12264 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 1, &ds
);
12265 if (!ds
&& sym
->attr
.function
&& gfc_check_symbol_access (sym
))
12267 symtree
= gfc_new_symtree (&sym
->ns
->sym_root
,
12268 sym
->ts
.u
.derived
->name
);
12269 symtree
->n
.sym
= sym
->ts
.u
.derived
;
12270 sym
->ts
.u
.derived
->refs
++;
12274 /* Unless the derived-type declaration is use associated, Fortran 95
12275 does not allow public entries of private derived types.
12276 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12277 161 in 95-006r3. */
12278 if (sym
->ts
.type
== BT_DERIVED
12279 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12280 && !sym
->ts
.u
.derived
->attr
.use_assoc
12281 && gfc_check_symbol_access (sym
)
12282 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12283 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12284 "of PRIVATE derived type '%s'",
12285 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12286 : "variable", sym
->name
, &sym
->declared_at
,
12287 sym
->ts
.u
.derived
->name
) == FAILURE
)
12290 /* F2008, C1302. */
12291 if (sym
->ts
.type
== BT_DERIVED
12292 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12293 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12294 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12295 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12297 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12298 "type LOCK_TYPE must be a coarray", sym
->name
,
12299 &sym
->declared_at
);
12303 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12304 default initialization is defined (5.1.2.4.4). */
12305 if (sym
->ts
.type
== BT_DERIVED
12307 && sym
->attr
.intent
== INTENT_OUT
12309 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12311 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12313 if (c
->initializer
)
12315 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12316 "ASSUMED SIZE and so cannot have a default initializer",
12317 sym
->name
, &sym
->declared_at
);
12324 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12325 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12327 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12328 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12333 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12334 || sym
->attr
.codimension
)
12335 && (sym
->attr
.result
|| sym
->result
== sym
))
12337 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12338 "a coarray component", sym
->name
, &sym
->declared_at
);
12343 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12344 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12346 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12347 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12352 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
12353 && (sym
->attr
.codimension
|| sym
->attr
.pointer
|| sym
->attr
.dimension
12354 || sym
->attr
.allocatable
))
12356 gfc_error ("Variable '%s' at %L with coarray component "
12357 "shall be a nonpointer, nonallocatable scalar",
12358 sym
->name
, &sym
->declared_at
);
12362 /* F2008, C526. The function-result case was handled above. */
12363 if (sym
->attr
.codimension
12364 && !(sym
->attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12365 || sym
->ns
->save_all
12366 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12367 || sym
->ns
->proc_name
->attr
.is_main_program
12368 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12370 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12371 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12374 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12375 else if (sym
->attr
.codimension
&& !sym
->attr
.allocatable
12376 && sym
->as
&& sym
->as
->cotype
== AS_DEFERRED
)
12378 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12379 "deferred shape", sym
->name
, &sym
->declared_at
);
12382 else if (sym
->attr
.codimension
&& sym
->attr
.allocatable
12383 && (sym
->as
->type
!= AS_DEFERRED
|| sym
->as
->cotype
!= AS_DEFERRED
))
12385 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12386 "deferred shape", sym
->name
, &sym
->declared_at
);
12391 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12392 || (sym
->attr
.codimension
&& sym
->attr
.allocatable
))
12393 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12395 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12396 "allocatable coarray or have coarray components",
12397 sym
->name
, &sym
->declared_at
);
12401 if (sym
->attr
.codimension
&& sym
->attr
.dummy
12402 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12404 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12405 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12406 sym
->ns
->proc_name
->name
);
12410 switch (sym
->attr
.flavor
)
12413 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12418 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12423 if (resolve_fl_namelist (sym
) == FAILURE
)
12428 if (resolve_fl_parameter (sym
) == FAILURE
)
12436 /* Resolve array specifier. Check as well some constraints
12437 on COMMON blocks. */
12439 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12441 /* Set the formal_arg_flag so that check_conflict will not throw
12442 an error for host associated variables in the specification
12443 expression for an array_valued function. */
12444 if (sym
->attr
.function
&& sym
->as
)
12445 formal_arg_flag
= 1;
12447 gfc_resolve_array_spec (sym
->as
, check_constant
);
12449 formal_arg_flag
= 0;
12451 /* Resolve formal namespaces. */
12452 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12453 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12454 gfc_resolve (sym
->formal_ns
);
12456 /* Make sure the formal namespace is present. */
12457 if (sym
->formal
&& !sym
->formal_ns
)
12459 gfc_formal_arglist
*formal
= sym
->formal
;
12460 while (formal
&& !formal
->sym
)
12461 formal
= formal
->next
;
12465 sym
->formal_ns
= formal
->sym
->ns
;
12466 sym
->formal_ns
->refs
++;
12470 /* Check threadprivate restrictions. */
12471 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12472 && (!sym
->attr
.in_common
12473 && sym
->module
== NULL
12474 && (sym
->ns
->proc_name
== NULL
12475 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12476 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12478 /* If we have come this far we can apply default-initializers, as
12479 described in 14.7.5, to those variables that have not already
12480 been assigned one. */
12481 if (sym
->ts
.type
== BT_DERIVED
12482 && sym
->ns
== gfc_current_ns
12484 && !sym
->attr
.allocatable
12485 && !sym
->attr
.alloc_comp
)
12487 symbol_attribute
*a
= &sym
->attr
;
12489 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12490 && !a
->in_common
&& !a
->use_assoc
12491 && (a
->referenced
|| a
->result
)
12492 && !(a
->function
&& sym
!= sym
->result
))
12493 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12494 apply_default_init (sym
);
12497 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12498 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12499 && !CLASS_DATA (sym
)->attr
.class_pointer
12500 && !CLASS_DATA (sym
)->attr
.allocatable
)
12501 apply_default_init (sym
);
12503 /* If this symbol has a type-spec, check it. */
12504 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12505 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12506 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12512 /************* Resolve DATA statements *************/
12516 gfc_data_value
*vnode
;
12522 /* Advance the values structure to point to the next value in the data list. */
12525 next_data_value (void)
12527 while (mpz_cmp_ui (values
.left
, 0) == 0)
12530 if (values
.vnode
->next
== NULL
)
12533 values
.vnode
= values
.vnode
->next
;
12534 mpz_set (values
.left
, values
.vnode
->repeat
);
12542 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12548 ar_type mark
= AR_UNKNOWN
;
12550 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12556 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12560 mpz_init_set_si (offset
, 0);
12563 if (e
->expr_type
!= EXPR_VARIABLE
)
12564 gfc_internal_error ("check_data_variable(): Bad expression");
12566 sym
= e
->symtree
->n
.sym
;
12568 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12570 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12571 sym
->name
, &sym
->declared_at
);
12574 if (e
->ref
== NULL
&& sym
->as
)
12576 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12577 " declaration", sym
->name
, where
);
12581 has_pointer
= sym
->attr
.pointer
;
12583 if (gfc_is_coindexed (e
))
12585 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
12590 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12592 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12596 && ref
->type
== REF_ARRAY
12597 && ref
->u
.ar
.type
!= AR_FULL
)
12599 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12600 "be a full array", sym
->name
, where
);
12605 if (e
->rank
== 0 || has_pointer
)
12607 mpz_init_set_ui (size
, 1);
12614 /* Find the array section reference. */
12615 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12617 if (ref
->type
!= REF_ARRAY
)
12619 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12625 /* Set marks according to the reference pattern. */
12626 switch (ref
->u
.ar
.type
)
12634 /* Get the start position of array section. */
12635 gfc_get_section_index (ar
, section_index
, &offset
);
12640 gcc_unreachable ();
12643 if (gfc_array_size (e
, &size
) == FAILURE
)
12645 gfc_error ("Nonconstant array section at %L in DATA statement",
12647 mpz_clear (offset
);
12654 while (mpz_cmp_ui (size
, 0) > 0)
12656 if (next_data_value () == FAILURE
)
12658 gfc_error ("DATA statement at %L has more variables than values",
12664 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
12668 /* If we have more than one element left in the repeat count,
12669 and we have more than one element left in the target variable,
12670 then create a range assignment. */
12671 /* FIXME: Only done for full arrays for now, since array sections
12673 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
12674 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
12678 if (mpz_cmp (size
, values
.left
) >= 0)
12680 mpz_init_set (range
, values
.left
);
12681 mpz_sub (size
, size
, values
.left
);
12682 mpz_set_ui (values
.left
, 0);
12686 mpz_init_set (range
, size
);
12687 mpz_sub (values
.left
, values
.left
, size
);
12688 mpz_set_ui (size
, 0);
12691 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
12694 mpz_add (offset
, offset
, range
);
12701 /* Assign initial value to symbol. */
12704 mpz_sub_ui (values
.left
, values
.left
, 1);
12705 mpz_sub_ui (size
, size
, 1);
12707 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
12712 if (mark
== AR_FULL
)
12713 mpz_add_ui (offset
, offset
, 1);
12715 /* Modify the array section indexes and recalculate the offset
12716 for next element. */
12717 else if (mark
== AR_SECTION
)
12718 gfc_advance_section (section_index
, ar
, &offset
);
12722 if (mark
== AR_SECTION
)
12724 for (i
= 0; i
< ar
->dimen
; i
++)
12725 mpz_clear (section_index
[i
]);
12729 mpz_clear (offset
);
12735 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
12737 /* Iterate over a list of elements in a DATA statement. */
12740 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
12743 iterator_stack frame
;
12744 gfc_expr
*e
, *start
, *end
, *step
;
12745 gfc_try retval
= SUCCESS
;
12747 mpz_init (frame
.value
);
12750 start
= gfc_copy_expr (var
->iter
.start
);
12751 end
= gfc_copy_expr (var
->iter
.end
);
12752 step
= gfc_copy_expr (var
->iter
.step
);
12754 if (gfc_simplify_expr (start
, 1) == FAILURE
12755 || start
->expr_type
!= EXPR_CONSTANT
)
12757 gfc_error ("start of implied-do loop at %L could not be "
12758 "simplified to a constant value", &start
->where
);
12762 if (gfc_simplify_expr (end
, 1) == FAILURE
12763 || end
->expr_type
!= EXPR_CONSTANT
)
12765 gfc_error ("end of implied-do loop at %L could not be "
12766 "simplified to a constant value", &start
->where
);
12770 if (gfc_simplify_expr (step
, 1) == FAILURE
12771 || step
->expr_type
!= EXPR_CONSTANT
)
12773 gfc_error ("step of implied-do loop at %L could not be "
12774 "simplified to a constant value", &start
->where
);
12779 mpz_set (trip
, end
->value
.integer
);
12780 mpz_sub (trip
, trip
, start
->value
.integer
);
12781 mpz_add (trip
, trip
, step
->value
.integer
);
12783 mpz_div (trip
, trip
, step
->value
.integer
);
12785 mpz_set (frame
.value
, start
->value
.integer
);
12787 frame
.prev
= iter_stack
;
12788 frame
.variable
= var
->iter
.var
->symtree
;
12789 iter_stack
= &frame
;
12791 while (mpz_cmp_ui (trip
, 0) > 0)
12793 if (traverse_data_var (var
->list
, where
) == FAILURE
)
12799 e
= gfc_copy_expr (var
->expr
);
12800 if (gfc_simplify_expr (e
, 1) == FAILURE
)
12807 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
12809 mpz_sub_ui (trip
, trip
, 1);
12813 mpz_clear (frame
.value
);
12816 gfc_free_expr (start
);
12817 gfc_free_expr (end
);
12818 gfc_free_expr (step
);
12820 iter_stack
= frame
.prev
;
12825 /* Type resolve variables in the variable list of a DATA statement. */
12828 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
12832 for (; var
; var
= var
->next
)
12834 if (var
->expr
== NULL
)
12835 t
= traverse_data_list (var
, where
);
12837 t
= check_data_variable (var
, where
);
12847 /* Resolve the expressions and iterators associated with a data statement.
12848 This is separate from the assignment checking because data lists should
12849 only be resolved once. */
12852 resolve_data_variables (gfc_data_variable
*d
)
12854 for (; d
; d
= d
->next
)
12856 if (d
->list
== NULL
)
12858 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
12863 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
12866 if (resolve_data_variables (d
->list
) == FAILURE
)
12875 /* Resolve a single DATA statement. We implement this by storing a pointer to
12876 the value list into static variables, and then recursively traversing the
12877 variables list, expanding iterators and such. */
12880 resolve_data (gfc_data
*d
)
12883 if (resolve_data_variables (d
->var
) == FAILURE
)
12886 values
.vnode
= d
->value
;
12887 if (d
->value
== NULL
)
12888 mpz_set_ui (values
.left
, 0);
12890 mpz_set (values
.left
, d
->value
->repeat
);
12892 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
12895 /* At this point, we better not have any values left. */
12897 if (next_data_value () == SUCCESS
)
12898 gfc_error ("DATA statement at %L has more values than variables",
12903 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12904 accessed by host or use association, is a dummy argument to a pure function,
12905 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12906 is storage associated with any such variable, shall not be used in the
12907 following contexts: (clients of this function). */
12909 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12910 procedure. Returns zero if assignment is OK, nonzero if there is a
12913 gfc_impure_variable (gfc_symbol
*sym
)
12918 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
12921 /* Check if the symbol's ns is inside the pure procedure. */
12922 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
12926 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
12930 proc
= sym
->ns
->proc_name
;
12931 if (sym
->attr
.dummy
&& gfc_pure (proc
)
12932 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
12934 proc
->attr
.function
))
12937 /* TODO: Sort out what can be storage associated, if anything, and include
12938 it here. In principle equivalences should be scanned but it does not
12939 seem to be possible to storage associate an impure variable this way. */
12944 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12945 current namespace is inside a pure procedure. */
12948 gfc_pure (gfc_symbol
*sym
)
12950 symbol_attribute attr
;
12955 /* Check if the current namespace or one of its parents
12956 belongs to a pure procedure. */
12957 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
12959 sym
= ns
->proc_name
;
12963 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
12971 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
12975 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
12976 checks if the current namespace is implicitly pure. Note that this
12977 function returns false for a PURE procedure. */
12980 gfc_implicit_pure (gfc_symbol
*sym
)
12982 symbol_attribute attr
;
12986 /* Check if the current namespace is implicit_pure. */
12987 sym
= gfc_current_ns
->proc_name
;
12991 if (attr
.flavor
== FL_PROCEDURE
12992 && attr
.implicit_pure
&& !attr
.pure
)
12999 return attr
.flavor
== FL_PROCEDURE
&& attr
.implicit_pure
&& !attr
.pure
;
13003 /* Test whether the current procedure is elemental or not. */
13006 gfc_elemental (gfc_symbol
*sym
)
13008 symbol_attribute attr
;
13011 sym
= gfc_current_ns
->proc_name
;
13016 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13020 /* Warn about unused labels. */
13023 warn_unused_fortran_label (gfc_st_label
*label
)
13028 warn_unused_fortran_label (label
->left
);
13030 if (label
->defined
== ST_LABEL_UNKNOWN
)
13033 switch (label
->referenced
)
13035 case ST_LABEL_UNKNOWN
:
13036 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13040 case ST_LABEL_BAD_TARGET
:
13041 gfc_warning ("Label %d at %L defined but cannot be used",
13042 label
->value
, &label
->where
);
13049 warn_unused_fortran_label (label
->right
);
13053 /* Returns the sequence type of a symbol or sequence. */
13056 sequence_type (gfc_typespec ts
)
13065 if (ts
.u
.derived
->components
== NULL
)
13066 return SEQ_NONDEFAULT
;
13068 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13069 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13070 if (sequence_type (c
->ts
) != result
)
13076 if (ts
.kind
!= gfc_default_character_kind
)
13077 return SEQ_NONDEFAULT
;
13079 return SEQ_CHARACTER
;
13082 if (ts
.kind
!= gfc_default_integer_kind
)
13083 return SEQ_NONDEFAULT
;
13085 return SEQ_NUMERIC
;
13088 if (!(ts
.kind
== gfc_default_real_kind
13089 || ts
.kind
== gfc_default_double_kind
))
13090 return SEQ_NONDEFAULT
;
13092 return SEQ_NUMERIC
;
13095 if (ts
.kind
!= gfc_default_complex_kind
)
13096 return SEQ_NONDEFAULT
;
13098 return SEQ_NUMERIC
;
13101 if (ts
.kind
!= gfc_default_logical_kind
)
13102 return SEQ_NONDEFAULT
;
13104 return SEQ_NUMERIC
;
13107 return SEQ_NONDEFAULT
;
13112 /* Resolve derived type EQUIVALENCE object. */
13115 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13117 gfc_component
*c
= derived
->components
;
13122 /* Shall not be an object of nonsequence derived type. */
13123 if (!derived
->attr
.sequence
)
13125 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13126 "attribute to be an EQUIVALENCE object", sym
->name
,
13131 /* Shall not have allocatable components. */
13132 if (derived
->attr
.alloc_comp
)
13134 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13135 "components to be an EQUIVALENCE object",sym
->name
,
13140 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13142 gfc_error ("Derived type variable '%s' at %L with default "
13143 "initialization cannot be in EQUIVALENCE with a variable "
13144 "in COMMON", sym
->name
, &e
->where
);
13148 for (; c
; c
= c
->next
)
13150 if (c
->ts
.type
== BT_DERIVED
13151 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13154 /* Shall not be an object of sequence derived type containing a pointer
13155 in the structure. */
13156 if (c
->attr
.pointer
)
13158 gfc_error ("Derived type variable '%s' at %L with pointer "
13159 "component(s) cannot be an EQUIVALENCE object",
13160 sym
->name
, &e
->where
);
13168 /* Resolve equivalence object.
13169 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13170 an allocatable array, an object of nonsequence derived type, an object of
13171 sequence derived type containing a pointer at any level of component
13172 selection, an automatic object, a function name, an entry name, a result
13173 name, a named constant, a structure component, or a subobject of any of
13174 the preceding objects. A substring shall not have length zero. A
13175 derived type shall not have components with default initialization nor
13176 shall two objects of an equivalence group be initialized.
13177 Either all or none of the objects shall have an protected attribute.
13178 The simple constraints are done in symbol.c(check_conflict) and the rest
13179 are implemented here. */
13182 resolve_equivalence (gfc_equiv
*eq
)
13185 gfc_symbol
*first_sym
;
13188 locus
*last_where
= NULL
;
13189 seq_type eq_type
, last_eq_type
;
13190 gfc_typespec
*last_ts
;
13191 int object
, cnt_protected
;
13194 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13196 first_sym
= eq
->expr
->symtree
->n
.sym
;
13200 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13204 e
->ts
= e
->symtree
->n
.sym
->ts
;
13205 /* match_varspec might not know yet if it is seeing
13206 array reference or substring reference, as it doesn't
13208 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13210 gfc_ref
*ref
= e
->ref
;
13211 sym
= e
->symtree
->n
.sym
;
13213 if (sym
->attr
.dimension
)
13215 ref
->u
.ar
.as
= sym
->as
;
13219 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13220 if (e
->ts
.type
== BT_CHARACTER
13222 && ref
->type
== REF_ARRAY
13223 && ref
->u
.ar
.dimen
== 1
13224 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13225 && ref
->u
.ar
.stride
[0] == NULL
)
13227 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13228 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13231 /* Optimize away the (:) reference. */
13232 if (start
== NULL
&& end
== NULL
)
13235 e
->ref
= ref
->next
;
13237 e
->ref
->next
= ref
->next
;
13242 ref
->type
= REF_SUBSTRING
;
13244 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13246 ref
->u
.ss
.start
= start
;
13247 if (end
== NULL
&& e
->ts
.u
.cl
)
13248 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13249 ref
->u
.ss
.end
= end
;
13250 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13257 /* Any further ref is an error. */
13260 gcc_assert (ref
->type
== REF_ARRAY
);
13261 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13267 if (gfc_resolve_expr (e
) == FAILURE
)
13270 sym
= e
->symtree
->n
.sym
;
13272 if (sym
->attr
.is_protected
)
13274 if (cnt_protected
> 0 && cnt_protected
!= object
)
13276 gfc_error ("Either all or none of the objects in the "
13277 "EQUIVALENCE set at %L shall have the "
13278 "PROTECTED attribute",
13283 /* Shall not equivalence common block variables in a PURE procedure. */
13284 if (sym
->ns
->proc_name
13285 && sym
->ns
->proc_name
->attr
.pure
13286 && sym
->attr
.in_common
)
13288 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13289 "object in the pure procedure '%s'",
13290 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13294 /* Shall not be a named constant. */
13295 if (e
->expr_type
== EXPR_CONSTANT
)
13297 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13298 "object", sym
->name
, &e
->where
);
13302 if (e
->ts
.type
== BT_DERIVED
13303 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13306 /* Check that the types correspond correctly:
13308 A numeric sequence structure may be equivalenced to another sequence
13309 structure, an object of default integer type, default real type, double
13310 precision real type, default logical type such that components of the
13311 structure ultimately only become associated to objects of the same
13312 kind. A character sequence structure may be equivalenced to an object
13313 of default character kind or another character sequence structure.
13314 Other objects may be equivalenced only to objects of the same type and
13315 kind parameters. */
13317 /* Identical types are unconditionally OK. */
13318 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13319 goto identical_types
;
13321 last_eq_type
= sequence_type (*last_ts
);
13322 eq_type
= sequence_type (sym
->ts
);
13324 /* Since the pair of objects is not of the same type, mixed or
13325 non-default sequences can be rejected. */
13327 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13328 "statement at %L with different type objects";
13330 && last_eq_type
== SEQ_MIXED
13331 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13333 || (eq_type
== SEQ_MIXED
13334 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13335 &e
->where
) == FAILURE
))
13338 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13339 "statement at %L with objects of different type";
13341 && last_eq_type
== SEQ_NONDEFAULT
13342 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13343 last_where
) == FAILURE
)
13344 || (eq_type
== SEQ_NONDEFAULT
13345 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13346 &e
->where
) == FAILURE
))
13349 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13350 "EQUIVALENCE statement at %L";
13351 if (last_eq_type
== SEQ_CHARACTER
13352 && eq_type
!= SEQ_CHARACTER
13353 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13354 &e
->where
) == FAILURE
)
13357 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13358 "EQUIVALENCE statement at %L";
13359 if (last_eq_type
== SEQ_NUMERIC
13360 && eq_type
!= SEQ_NUMERIC
13361 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13362 &e
->where
) == FAILURE
)
13367 last_where
= &e
->where
;
13372 /* Shall not be an automatic array. */
13373 if (e
->ref
->type
== REF_ARRAY
13374 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13376 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13377 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13384 /* Shall not be a structure component. */
13385 if (r
->type
== REF_COMPONENT
)
13387 gfc_error ("Structure component '%s' at %L cannot be an "
13388 "EQUIVALENCE object",
13389 r
->u
.c
.component
->name
, &e
->where
);
13393 /* A substring shall not have length zero. */
13394 if (r
->type
== REF_SUBSTRING
)
13396 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13398 gfc_error ("Substring at %L has length zero",
13399 &r
->u
.ss
.start
->where
);
13409 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13412 resolve_fntype (gfc_namespace
*ns
)
13414 gfc_entry_list
*el
;
13417 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13420 /* If there are any entries, ns->proc_name is the entry master
13421 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13423 sym
= ns
->entries
->sym
;
13425 sym
= ns
->proc_name
;
13426 if (sym
->result
== sym
13427 && sym
->ts
.type
== BT_UNKNOWN
13428 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13429 && !sym
->attr
.untyped
)
13431 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13432 sym
->name
, &sym
->declared_at
);
13433 sym
->attr
.untyped
= 1;
13436 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13437 && !sym
->attr
.contained
13438 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13439 && gfc_check_symbol_access (sym
))
13441 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13442 "%L of PRIVATE type '%s'", sym
->name
,
13443 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13447 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13449 if (el
->sym
->result
== el
->sym
13450 && el
->sym
->ts
.type
== BT_UNKNOWN
13451 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13452 && !el
->sym
->attr
.untyped
)
13454 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13455 el
->sym
->name
, &el
->sym
->declared_at
);
13456 el
->sym
->attr
.untyped
= 1;
13462 /* 12.3.2.1.1 Defined operators. */
13465 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13467 gfc_formal_arglist
*formal
;
13469 if (!sym
->attr
.function
)
13471 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13472 sym
->name
, &where
);
13476 if (sym
->ts
.type
== BT_CHARACTER
13477 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13478 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13479 && sym
->result
->ts
.u
.cl
->length
))
13481 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13482 "character length", sym
->name
, &where
);
13486 formal
= sym
->formal
;
13487 if (!formal
|| !formal
->sym
)
13489 gfc_error ("User operator procedure '%s' at %L must have at least "
13490 "one argument", sym
->name
, &where
);
13494 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13496 gfc_error ("First argument of operator interface at %L must be "
13497 "INTENT(IN)", &where
);
13501 if (formal
->sym
->attr
.optional
)
13503 gfc_error ("First argument of operator interface at %L cannot be "
13504 "optional", &where
);
13508 formal
= formal
->next
;
13509 if (!formal
|| !formal
->sym
)
13512 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13514 gfc_error ("Second argument of operator interface at %L must be "
13515 "INTENT(IN)", &where
);
13519 if (formal
->sym
->attr
.optional
)
13521 gfc_error ("Second argument of operator interface at %L cannot be "
13522 "optional", &where
);
13528 gfc_error ("Operator interface at %L must have, at most, two "
13529 "arguments", &where
);
13537 gfc_resolve_uops (gfc_symtree
*symtree
)
13539 gfc_interface
*itr
;
13541 if (symtree
== NULL
)
13544 gfc_resolve_uops (symtree
->left
);
13545 gfc_resolve_uops (symtree
->right
);
13547 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13548 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13552 /* Examine all of the expressions associated with a program unit,
13553 assign types to all intermediate expressions, make sure that all
13554 assignments are to compatible types and figure out which names
13555 refer to which functions or subroutines. It doesn't check code
13556 block, which is handled by resolve_code. */
13559 resolve_types (gfc_namespace
*ns
)
13565 gfc_namespace
* old_ns
= gfc_current_ns
;
13567 /* Check that all IMPLICIT types are ok. */
13568 if (!ns
->seen_implicit_none
)
13571 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13572 if (ns
->set_flag
[letter
]
13573 && resolve_typespec_used (&ns
->default_type
[letter
],
13574 &ns
->implicit_loc
[letter
],
13579 gfc_current_ns
= ns
;
13581 resolve_entries (ns
);
13583 resolve_common_vars (ns
->blank_common
.head
, false);
13584 resolve_common_blocks (ns
->common_root
);
13586 resolve_contained_functions (ns
);
13588 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
13589 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
13590 resolve_formal_arglist (ns
->proc_name
);
13592 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13594 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13595 resolve_charlen (cl
);
13597 gfc_traverse_ns (ns
, resolve_symbol
);
13599 resolve_fntype (ns
);
13601 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13603 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13604 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13605 "also be PURE", n
->proc_name
->name
,
13606 &n
->proc_name
->declared_at
);
13612 do_concurrent_flag
= 0;
13613 gfc_check_interfaces (ns
);
13615 gfc_traverse_ns (ns
, resolve_values
);
13621 for (d
= ns
->data
; d
; d
= d
->next
)
13625 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13627 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13629 if (ns
->common_root
!= NULL
)
13630 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13632 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13633 resolve_equivalence (eq
);
13635 /* Warn about unused labels. */
13636 if (warn_unused_label
)
13637 warn_unused_fortran_label (ns
->st_labels
);
13639 gfc_resolve_uops (ns
->uop_root
);
13641 gfc_current_ns
= old_ns
;
13645 /* Call resolve_code recursively. */
13648 resolve_codes (gfc_namespace
*ns
)
13651 bitmap_obstack old_obstack
;
13653 if (ns
->resolved
== 1)
13656 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13659 gfc_current_ns
= ns
;
13661 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13662 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
13665 /* Set to an out of range value. */
13666 current_entry_id
= -1;
13668 old_obstack
= labels_obstack
;
13669 bitmap_obstack_initialize (&labels_obstack
);
13671 resolve_code (ns
->code
, ns
);
13673 bitmap_obstack_release (&labels_obstack
);
13674 labels_obstack
= old_obstack
;
13678 /* This function is called after a complete program unit has been compiled.
13679 Its purpose is to examine all of the expressions associated with a program
13680 unit, assign types to all intermediate expressions, make sure that all
13681 assignments are to compatible types and figure out which names refer to
13682 which functions or subroutines. */
13685 gfc_resolve (gfc_namespace
*ns
)
13687 gfc_namespace
*old_ns
;
13688 code_stack
*old_cs_base
;
13694 old_ns
= gfc_current_ns
;
13695 old_cs_base
= cs_base
;
13697 resolve_types (ns
);
13698 resolve_codes (ns
);
13700 gfc_current_ns
= old_ns
;
13701 cs_base
= old_cs_base
;
13704 gfc_run_passes (ns
);