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
)
274 if (sym
->attr
.flavor
== FL_UNKNOWN
)
275 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
279 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
280 && (!sym
->attr
.function
|| sym
->result
== sym
))
281 gfc_set_default_type (sym
, 1, sym
->ns
);
284 gfc_resolve_array_spec (sym
->as
, 0);
286 /* We can't tell if an array with dimension (:) is assumed or deferred
287 shape until we know if it has the pointer or allocatable attributes.
289 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
290 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
)
291 && sym
->attr
.flavor
!= FL_PROCEDURE
)
293 sym
->as
->type
= AS_ASSUMED_SHAPE
;
294 for (i
= 0; i
< sym
->as
->rank
; i
++)
295 sym
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
299 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
300 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
301 || sym
->attr
.optional
)
303 proc
->attr
.always_explicit
= 1;
305 proc
->result
->attr
.always_explicit
= 1;
308 /* If the flavor is unknown at this point, it has to be a variable.
309 A procedure specification would have already set the type. */
311 if (sym
->attr
.flavor
== FL_UNKNOWN
)
312 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
316 if (sym
->attr
.flavor
== FL_PROCEDURE
)
321 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
322 "also be PURE", sym
->name
, &sym
->declared_at
);
326 else if (!sym
->attr
.pointer
)
328 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
331 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s'"
332 " of pure function '%s' at %L with VALUE "
333 "attribute but without INTENT(IN)",
334 sym
->name
, proc
->name
, &sym
->declared_at
);
336 gfc_error ("Argument '%s' of pure function '%s' at %L must "
337 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
341 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
344 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s'"
345 " of pure subroutine '%s' at %L with VALUE "
346 "attribute but without INTENT", sym
->name
,
347 proc
->name
, &sym
->declared_at
);
349 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
350 "must have its INTENT specified or have the "
351 "VALUE attribute", sym
->name
, proc
->name
,
357 if (proc
->attr
.implicit_pure
)
359 if (sym
->attr
.flavor
== FL_PROCEDURE
)
362 proc
->attr
.implicit_pure
= 0;
364 else if (!sym
->attr
.pointer
)
366 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
367 proc
->attr
.implicit_pure
= 0;
369 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
370 proc
->attr
.implicit_pure
= 0;
374 if (gfc_elemental (proc
))
377 if (sym
->attr
.codimension
)
379 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
380 "procedure", sym
->name
, &sym
->declared_at
);
386 gfc_error ("Argument '%s' of elemental procedure at %L must "
387 "be scalar", sym
->name
, &sym
->declared_at
);
391 if (sym
->attr
.allocatable
)
393 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
394 "have the ALLOCATABLE attribute", sym
->name
,
399 if (sym
->attr
.pointer
)
401 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
402 "have the POINTER attribute", sym
->name
,
407 if (sym
->attr
.flavor
== FL_PROCEDURE
)
409 gfc_error ("Dummy procedure '%s' not allowed in elemental "
410 "procedure '%s' at %L", sym
->name
, proc
->name
,
415 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
417 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
418 "have its INTENT specified", sym
->name
, proc
->name
,
424 /* Each dummy shall be specified to be scalar. */
425 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
429 gfc_error ("Argument '%s' of statement function at %L must "
430 "be scalar", sym
->name
, &sym
->declared_at
);
434 if (sym
->ts
.type
== BT_CHARACTER
)
436 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
437 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
439 gfc_error ("Character-valued argument '%s' of statement "
440 "function at %L must have constant length",
441 sym
->name
, &sym
->declared_at
);
451 /* Work function called when searching for symbols that have argument lists
452 associated with them. */
455 find_arglists (gfc_symbol
*sym
)
457 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
458 || sym
->attr
.flavor
== FL_DERIVED
)
461 resolve_formal_arglist (sym
);
465 /* Given a namespace, resolve all formal argument lists within the namespace.
469 resolve_formal_arglists (gfc_namespace
*ns
)
474 gfc_traverse_ns (ns
, find_arglists
);
479 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
483 /* If this namespace is not a function or an entry master function,
485 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
486 || sym
->attr
.entry_master
)
489 /* Try to find out of what the return type is. */
490 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
492 t
= gfc_set_default_type (sym
->result
, 0, ns
);
494 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
496 if (sym
->result
== sym
)
497 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
498 sym
->name
, &sym
->declared_at
);
499 else if (!sym
->result
->attr
.proc_pointer
)
500 gfc_error ("Result '%s' of contained function '%s' at %L has "
501 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
502 &sym
->result
->declared_at
);
503 sym
->result
->attr
.untyped
= 1;
507 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
508 type, lists the only ways a character length value of * can be used:
509 dummy arguments of procedures, named constants, and function results
510 in external functions. Internal function results and results of module
511 procedures are not on this list, ergo, not permitted. */
513 if (sym
->result
->ts
.type
== BT_CHARACTER
)
515 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
516 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
518 /* See if this is a module-procedure and adapt error message
521 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
522 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
524 gfc_error ("Character-valued %s '%s' at %L must not be"
526 module_proc
? _("module procedure")
527 : _("internal function"),
528 sym
->name
, &sym
->declared_at
);
534 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
535 introduce duplicates. */
538 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
540 gfc_formal_arglist
*f
, *new_arglist
;
543 for (; new_args
!= NULL
; new_args
= new_args
->next
)
545 new_sym
= new_args
->sym
;
546 /* See if this arg is already in the formal argument list. */
547 for (f
= proc
->formal
; f
; f
= f
->next
)
549 if (new_sym
== f
->sym
)
556 /* Add a new argument. Argument order is not important. */
557 new_arglist
= gfc_get_formal_arglist ();
558 new_arglist
->sym
= new_sym
;
559 new_arglist
->next
= proc
->formal
;
560 proc
->formal
= new_arglist
;
565 /* Flag the arguments that are not present in all entries. */
568 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
570 gfc_formal_arglist
*f
, *head
;
573 for (f
= proc
->formal
; f
; f
= f
->next
)
578 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
580 if (new_args
->sym
== f
->sym
)
587 f
->sym
->attr
.not_always_present
= 1;
592 /* Resolve alternate entry points. If a symbol has multiple entry points we
593 create a new master symbol for the main routine, and turn the existing
594 symbol into an entry point. */
597 resolve_entries (gfc_namespace
*ns
)
599 gfc_namespace
*old_ns
;
603 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
604 static int master_count
= 0;
606 if (ns
->proc_name
== NULL
)
609 /* No need to do anything if this procedure doesn't have alternate entry
614 /* We may already have resolved alternate entry points. */
615 if (ns
->proc_name
->attr
.entry_master
)
618 /* If this isn't a procedure something has gone horribly wrong. */
619 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
621 /* Remember the current namespace. */
622 old_ns
= gfc_current_ns
;
626 /* Add the main entry point to the list of entry points. */
627 el
= gfc_get_entry_list ();
628 el
->sym
= ns
->proc_name
;
630 el
->next
= ns
->entries
;
632 ns
->proc_name
->attr
.entry
= 1;
634 /* If it is a module function, it needs to be in the right namespace
635 so that gfc_get_fake_result_decl can gather up the results. The
636 need for this arose in get_proc_name, where these beasts were
637 left in their own namespace, to keep prior references linked to
638 the entry declaration.*/
639 if (ns
->proc_name
->attr
.function
640 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
643 /* Do the same for entries where the master is not a module
644 procedure. These are retained in the module namespace because
645 of the module procedure declaration. */
646 for (el
= el
->next
; el
; el
= el
->next
)
647 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
648 && el
->sym
->attr
.mod_proc
)
652 /* Add an entry statement for it. */
659 /* Create a new symbol for the master function. */
660 /* Give the internal function a unique name (within this file).
661 Also include the function name so the user has some hope of figuring
662 out what is going on. */
663 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
664 master_count
++, ns
->proc_name
->name
);
665 gfc_get_ha_symbol (name
, &proc
);
666 gcc_assert (proc
!= NULL
);
668 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
669 if (ns
->proc_name
->attr
.subroutine
)
670 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
674 gfc_typespec
*ts
, *fts
;
675 gfc_array_spec
*as
, *fas
;
676 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
678 fas
= ns
->entries
->sym
->as
;
679 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
680 fts
= &ns
->entries
->sym
->result
->ts
;
681 if (fts
->type
== BT_UNKNOWN
)
682 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
683 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
685 ts
= &el
->sym
->result
->ts
;
687 as
= as
? as
: el
->sym
->result
->as
;
688 if (ts
->type
== BT_UNKNOWN
)
689 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
691 if (! gfc_compare_types (ts
, fts
)
692 || (el
->sym
->result
->attr
.dimension
693 != ns
->entries
->sym
->result
->attr
.dimension
)
694 || (el
->sym
->result
->attr
.pointer
695 != ns
->entries
->sym
->result
->attr
.pointer
))
697 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
698 && gfc_compare_array_spec (as
, fas
) == 0)
699 gfc_error ("Function %s at %L has entries with mismatched "
700 "array specifications", ns
->entries
->sym
->name
,
701 &ns
->entries
->sym
->declared_at
);
702 /* The characteristics need to match and thus both need to have
703 the same string length, i.e. both len=*, or both len=4.
704 Having both len=<variable> is also possible, but difficult to
705 check at compile time. */
706 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
707 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
708 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
710 && ts
->u
.cl
->length
->expr_type
711 != fts
->u
.cl
->length
->expr_type
)
713 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
714 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
715 fts
->u
.cl
->length
->value
.integer
) != 0)))
716 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
717 "entries returning variables of different "
718 "string lengths", ns
->entries
->sym
->name
,
719 &ns
->entries
->sym
->declared_at
);
724 sym
= ns
->entries
->sym
->result
;
725 /* All result types the same. */
727 if (sym
->attr
.dimension
)
728 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
729 if (sym
->attr
.pointer
)
730 gfc_add_pointer (&proc
->attr
, NULL
);
734 /* Otherwise the result will be passed through a union by
736 proc
->attr
.mixed_entry_master
= 1;
737 for (el
= ns
->entries
; el
; el
= el
->next
)
739 sym
= el
->sym
->result
;
740 if (sym
->attr
.dimension
)
742 if (el
== ns
->entries
)
743 gfc_error ("FUNCTION result %s can't be an array in "
744 "FUNCTION %s at %L", sym
->name
,
745 ns
->entries
->sym
->name
, &sym
->declared_at
);
747 gfc_error ("ENTRY result %s can't be an array in "
748 "FUNCTION %s at %L", sym
->name
,
749 ns
->entries
->sym
->name
, &sym
->declared_at
);
751 else if (sym
->attr
.pointer
)
753 if (el
== ns
->entries
)
754 gfc_error ("FUNCTION result %s can't be a POINTER in "
755 "FUNCTION %s at %L", sym
->name
,
756 ns
->entries
->sym
->name
, &sym
->declared_at
);
758 gfc_error ("ENTRY result %s can't be a POINTER in "
759 "FUNCTION %s at %L", sym
->name
,
760 ns
->entries
->sym
->name
, &sym
->declared_at
);
765 if (ts
->type
== BT_UNKNOWN
)
766 ts
= gfc_get_default_type (sym
->name
, NULL
);
770 if (ts
->kind
== gfc_default_integer_kind
)
774 if (ts
->kind
== gfc_default_real_kind
775 || ts
->kind
== gfc_default_double_kind
)
779 if (ts
->kind
== gfc_default_complex_kind
)
783 if (ts
->kind
== gfc_default_logical_kind
)
787 /* We will issue error elsewhere. */
795 if (el
== ns
->entries
)
796 gfc_error ("FUNCTION result %s can't be of type %s "
797 "in FUNCTION %s at %L", sym
->name
,
798 gfc_typename (ts
), ns
->entries
->sym
->name
,
801 gfc_error ("ENTRY result %s can't be of type %s "
802 "in FUNCTION %s at %L", sym
->name
,
803 gfc_typename (ts
), ns
->entries
->sym
->name
,
810 proc
->attr
.access
= ACCESS_PRIVATE
;
811 proc
->attr
.entry_master
= 1;
813 /* Merge all the entry point arguments. */
814 for (el
= ns
->entries
; el
; el
= el
->next
)
815 merge_argument_lists (proc
, el
->sym
->formal
);
817 /* Check the master formal arguments for any that are not
818 present in all entry points. */
819 for (el
= ns
->entries
; el
; el
= el
->next
)
820 check_argument_lists (proc
, el
->sym
->formal
);
822 /* Use the master function for the function body. */
823 ns
->proc_name
= proc
;
825 /* Finalize the new symbols. */
826 gfc_commit_symbols ();
828 /* Restore the original namespace. */
829 gfc_current_ns
= old_ns
;
833 /* Resolve common variables. */
835 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
837 gfc_symbol
*csym
= sym
;
839 for (; csym
; csym
= csym
->common_next
)
841 if (csym
->value
|| csym
->attr
.data
)
843 if (!csym
->ns
->is_block_data
)
844 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
845 "but only in BLOCK DATA initialization is "
846 "allowed", csym
->name
, &csym
->declared_at
);
847 else if (!named_common
)
848 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
849 "in a blank COMMON but initialization is only "
850 "allowed in named common blocks", csym
->name
,
854 if (csym
->ts
.type
!= BT_DERIVED
)
857 if (!(csym
->ts
.u
.derived
->attr
.sequence
858 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
859 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
860 "has neither the SEQUENCE nor the BIND(C) "
861 "attribute", csym
->name
, &csym
->declared_at
);
862 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
863 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
864 "has an ultimate component that is "
865 "allocatable", csym
->name
, &csym
->declared_at
);
866 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
867 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
868 "may not have default initializer", csym
->name
,
871 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
872 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
876 /* Resolve common blocks. */
878 resolve_common_blocks (gfc_symtree
*common_root
)
882 if (common_root
== NULL
)
885 if (common_root
->left
)
886 resolve_common_blocks (common_root
->left
);
887 if (common_root
->right
)
888 resolve_common_blocks (common_root
->right
);
890 resolve_common_vars (common_root
->n
.common
->head
, true);
892 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
896 if (sym
->attr
.flavor
== FL_PARAMETER
)
897 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
898 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
900 if (sym
->attr
.external
)
901 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
902 sym
->name
, &common_root
->n
.common
->where
);
904 if (sym
->attr
.intrinsic
)
905 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
906 sym
->name
, &common_root
->n
.common
->where
);
907 else if (sym
->attr
.result
908 || gfc_is_function_return_value (sym
, gfc_current_ns
))
909 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
910 "that is also a function result", sym
->name
,
911 &common_root
->n
.common
->where
);
912 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
913 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
914 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
915 "that is also a global procedure", sym
->name
,
916 &common_root
->n
.common
->where
);
920 /* Resolve contained function types. Because contained functions can call one
921 another, they have to be worked out before any of the contained procedures
924 The good news is that if a function doesn't already have a type, the only
925 way it can get one is through an IMPLICIT type or a RESULT variable, because
926 by definition contained functions are contained namespace they're contained
927 in, not in a sibling or parent namespace. */
930 resolve_contained_functions (gfc_namespace
*ns
)
932 gfc_namespace
*child
;
935 resolve_formal_arglists (ns
);
937 for (child
= ns
->contained
; child
; child
= child
->sibling
)
939 /* Resolve alternate entry points first. */
940 resolve_entries (child
);
942 /* Then check function return types. */
943 resolve_contained_fntype (child
->proc_name
, child
);
944 for (el
= child
->entries
; el
; el
= el
->next
)
945 resolve_contained_fntype (el
->sym
, child
);
950 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
953 /* Resolve all of the elements of a structure constructor and make sure that
954 the types are correct. The 'init' flag indicates that the given
955 constructor is an initializer. */
958 resolve_structure_cons (gfc_expr
*expr
, int init
)
960 gfc_constructor
*cons
;
967 if (expr
->ts
.type
== BT_DERIVED
)
968 resolve_fl_derived0 (expr
->ts
.u
.derived
);
970 cons
= gfc_constructor_first (expr
->value
.constructor
);
972 /* See if the user is trying to invoke a structure constructor for one of
973 the iso_c_binding derived types. */
974 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
975 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
976 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
978 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
979 expr
->ts
.u
.derived
->name
, &(expr
->where
));
983 /* Return if structure constructor is c_null_(fun)prt. */
984 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
985 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
986 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
989 /* A constructor may have references if it is the result of substituting a
990 parameter variable. In this case we just pull out the component we
993 comp
= expr
->ref
->u
.c
.sym
->components
;
995 comp
= expr
->ts
.u
.derived
->components
;
997 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1004 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1010 rank
= comp
->as
? comp
->as
->rank
: 0;
1011 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1012 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1014 gfc_error ("The rank of the element in the structure "
1015 "constructor at %L does not match that of the "
1016 "component (%d/%d)", &cons
->expr
->where
,
1017 cons
->expr
->rank
, rank
);
1021 /* If we don't have the right type, try to convert it. */
1023 if (!comp
->attr
.proc_pointer
&&
1024 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1027 if (strcmp (comp
->name
, "_extends") == 0)
1029 /* Can afford to be brutal with the _extends initializer.
1030 The derived type can get lost because it is PRIVATE
1031 but it is not usage constrained by the standard. */
1032 cons
->expr
->ts
= comp
->ts
;
1035 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1036 gfc_error ("The element in the structure constructor at %L, "
1037 "for pointer component '%s', is %s but should be %s",
1038 &cons
->expr
->where
, comp
->name
,
1039 gfc_basic_typename (cons
->expr
->ts
.type
),
1040 gfc_basic_typename (comp
->ts
.type
));
1042 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1045 /* For strings, the length of the constructor should be the same as
1046 the one of the structure, ensure this if the lengths are known at
1047 compile time and when we are dealing with PARAMETER or structure
1049 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1050 && comp
->ts
.u
.cl
->length
1051 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1052 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1053 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1054 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1055 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1057 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1058 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1060 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1061 to make use of the gfc_resolve_character_array_constructor
1062 machinery. The expression is later simplified away to
1063 an array of string literals. */
1064 gfc_expr
*para
= cons
->expr
;
1065 cons
->expr
= gfc_get_expr ();
1066 cons
->expr
->ts
= para
->ts
;
1067 cons
->expr
->where
= para
->where
;
1068 cons
->expr
->expr_type
= EXPR_ARRAY
;
1069 cons
->expr
->rank
= para
->rank
;
1070 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1071 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1072 para
, &cons
->expr
->where
);
1074 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1077 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1078 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1080 gfc_charlen
*cl
, *cl2
;
1083 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1085 if (cl
== cons
->expr
->ts
.u
.cl
)
1093 cl2
->next
= cl
->next
;
1095 gfc_free_expr (cl
->length
);
1099 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1100 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1101 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1102 gfc_resolve_character_array_constructor (cons
->expr
);
1106 if (cons
->expr
->expr_type
== EXPR_NULL
1107 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1108 || comp
->attr
.proc_pointer
1109 || (comp
->ts
.type
== BT_CLASS
1110 && (CLASS_DATA (comp
)->attr
.class_pointer
1111 || CLASS_DATA (comp
)->attr
.allocatable
))))
1114 gfc_error ("The NULL in the structure constructor at %L is "
1115 "being applied to component '%s', which is neither "
1116 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1120 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1122 /* Check procedure pointer interface. */
1123 gfc_symbol
*s2
= NULL
;
1128 if (gfc_is_proc_ptr_comp (cons
->expr
, &c2
))
1130 s2
= c2
->ts
.interface
;
1133 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1135 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1136 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1138 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1140 s2
= cons
->expr
->symtree
->n
.sym
;
1141 name
= cons
->expr
->symtree
->n
.sym
->name
;
1144 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1147 gfc_error ("Interface mismatch for procedure-pointer component "
1148 "'%s' in structure constructor at %L: %s",
1149 comp
->name
, &cons
->expr
->where
, err
);
1154 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1155 || cons
->expr
->expr_type
== EXPR_NULL
)
1158 a
= gfc_expr_attr (cons
->expr
);
1160 if (!a
.pointer
&& !a
.target
)
1163 gfc_error ("The element in the structure constructor at %L, "
1164 "for pointer component '%s' should be a POINTER or "
1165 "a TARGET", &cons
->expr
->where
, comp
->name
);
1170 /* F08:C461. Additional checks for pointer initialization. */
1174 gfc_error ("Pointer initialization target at %L "
1175 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1180 gfc_error ("Pointer initialization target at %L "
1181 "must have the SAVE attribute", &cons
->expr
->where
);
1185 /* F2003, C1272 (3). */
1186 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1187 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1188 || gfc_is_coindexed (cons
->expr
)))
1191 gfc_error ("Invalid expression in the structure constructor for "
1192 "pointer component '%s' at %L in PURE procedure",
1193 comp
->name
, &cons
->expr
->where
);
1196 if (gfc_implicit_pure (NULL
)
1197 && cons
->expr
->expr_type
== EXPR_VARIABLE
1198 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1199 || gfc_is_coindexed (cons
->expr
)))
1200 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1208 /****************** Expression name resolution ******************/
1210 /* Returns 0 if a symbol was not declared with a type or
1211 attribute declaration statement, nonzero otherwise. */
1214 was_declared (gfc_symbol
*sym
)
1220 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1223 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1224 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1225 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1226 || a
.asynchronous
|| a
.codimension
)
1233 /* Determine if a symbol is generic or not. */
1236 generic_sym (gfc_symbol
*sym
)
1240 if (sym
->attr
.generic
||
1241 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1244 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1247 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1254 return generic_sym (s
);
1261 /* Determine if a symbol is specific or not. */
1264 specific_sym (gfc_symbol
*sym
)
1268 if (sym
->attr
.if_source
== IFSRC_IFBODY
1269 || sym
->attr
.proc
== PROC_MODULE
1270 || sym
->attr
.proc
== PROC_INTERNAL
1271 || sym
->attr
.proc
== PROC_ST_FUNCTION
1272 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1273 || sym
->attr
.external
)
1276 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1279 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1281 return (s
== NULL
) ? 0 : specific_sym (s
);
1285 /* Figure out if the procedure is specific, generic or unknown. */
1288 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1292 procedure_kind (gfc_symbol
*sym
)
1294 if (generic_sym (sym
))
1295 return PTYPE_GENERIC
;
1297 if (specific_sym (sym
))
1298 return PTYPE_SPECIFIC
;
1300 return PTYPE_UNKNOWN
;
1303 /* Check references to assumed size arrays. The flag need_full_assumed_size
1304 is nonzero when matching actual arguments. */
1306 static int need_full_assumed_size
= 0;
1309 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1311 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1314 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1315 What should it be? */
1316 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1317 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1318 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1320 gfc_error ("The upper bound in the last dimension must "
1321 "appear in the reference to the assumed size "
1322 "array '%s' at %L", sym
->name
, &e
->where
);
1329 /* Look for bad assumed size array references in argument expressions
1330 of elemental and array valued intrinsic procedures. Since this is
1331 called from procedure resolution functions, it only recurses at
1335 resolve_assumed_size_actual (gfc_expr
*e
)
1340 switch (e
->expr_type
)
1343 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1348 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1349 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1360 /* Check a generic procedure, passed as an actual argument, to see if
1361 there is a matching specific name. If none, it is an error, and if
1362 more than one, the reference is ambiguous. */
1364 count_specific_procs (gfc_expr
*e
)
1371 sym
= e
->symtree
->n
.sym
;
1373 for (p
= sym
->generic
; p
; p
= p
->next
)
1374 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1376 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1382 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1386 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1387 "argument at %L", sym
->name
, &e
->where
);
1393 /* See if a call to sym could possibly be a not allowed RECURSION because of
1394 a missing RECURIVE declaration. This means that either sym is the current
1395 context itself, or sym is the parent of a contained procedure calling its
1396 non-RECURSIVE containing procedure.
1397 This also works if sym is an ENTRY. */
1400 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1402 gfc_symbol
* proc_sym
;
1403 gfc_symbol
* context_proc
;
1404 gfc_namespace
* real_context
;
1406 if (sym
->attr
.flavor
== FL_PROGRAM
1407 || sym
->attr
.flavor
== FL_DERIVED
)
1410 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1412 /* If we've got an ENTRY, find real procedure. */
1413 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1414 proc_sym
= sym
->ns
->entries
->sym
;
1418 /* If sym is RECURSIVE, all is well of course. */
1419 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1422 /* Find the context procedure's "real" symbol if it has entries.
1423 We look for a procedure symbol, so recurse on the parents if we don't
1424 find one (like in case of a BLOCK construct). */
1425 for (real_context
= context
; ; real_context
= real_context
->parent
)
1427 /* We should find something, eventually! */
1428 gcc_assert (real_context
);
1430 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1431 : real_context
->proc_name
);
1433 /* In some special cases, there may not be a proc_name, like for this
1435 real(bad_kind()) function foo () ...
1436 when checking the call to bad_kind ().
1437 In these cases, we simply return here and assume that the
1442 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1446 /* A call from sym's body to itself is recursion, of course. */
1447 if (context_proc
== proc_sym
)
1450 /* The same is true if context is a contained procedure and sym the
1452 if (context_proc
->attr
.contained
)
1454 gfc_symbol
* parent_proc
;
1456 gcc_assert (context
->parent
);
1457 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1458 : context
->parent
->proc_name
);
1460 if (parent_proc
== proc_sym
)
1468 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1469 its typespec and formal argument list. */
1472 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1474 gfc_intrinsic_sym
* isym
= NULL
;
1480 /* Already resolved. */
1481 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1484 /* We already know this one is an intrinsic, so we don't call
1485 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1486 gfc_find_subroutine directly to check whether it is a function or
1489 if (sym
->intmod_sym_id
)
1490 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1492 isym
= gfc_find_function (sym
->name
);
1496 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1497 && !sym
->attr
.implicit_type
)
1498 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1499 " ignored", sym
->name
, &sym
->declared_at
);
1501 if (!sym
->attr
.function
&&
1502 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1507 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1509 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1511 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1512 " specifier", sym
->name
, &sym
->declared_at
);
1516 if (!sym
->attr
.subroutine
&&
1517 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1522 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1527 gfc_copy_formal_args_intr (sym
, isym
);
1529 /* Check it is actually available in the standard settings. */
1530 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1533 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1534 " available in the current standard settings but %s. Use"
1535 " an appropriate -std=* option or enable -fall-intrinsics"
1536 " in order to use it.",
1537 sym
->name
, &sym
->declared_at
, symstd
);
1545 /* Resolve a procedure expression, like passing it to a called procedure or as
1546 RHS for a procedure pointer assignment. */
1549 resolve_procedure_expression (gfc_expr
* expr
)
1553 if (expr
->expr_type
!= EXPR_VARIABLE
)
1555 gcc_assert (expr
->symtree
);
1557 sym
= expr
->symtree
->n
.sym
;
1559 if (sym
->attr
.intrinsic
)
1560 resolve_intrinsic (sym
, &expr
->where
);
1562 if (sym
->attr
.flavor
!= FL_PROCEDURE
1563 || (sym
->attr
.function
&& sym
->result
== sym
))
1566 /* A non-RECURSIVE procedure that is used as procedure expression within its
1567 own body is in danger of being called recursively. */
1568 if (is_illegal_recursion (sym
, gfc_current_ns
))
1569 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1570 " itself recursively. Declare it RECURSIVE or use"
1571 " -frecursive", sym
->name
, &expr
->where
);
1577 /* Resolve an actual argument list. Most of the time, this is just
1578 resolving the expressions in the list.
1579 The exception is that we sometimes have to decide whether arguments
1580 that look like procedure arguments are really simple variable
1584 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1585 bool no_formal_args
)
1588 gfc_symtree
*parent_st
;
1590 int save_need_full_assumed_size
;
1592 for (; arg
; arg
= arg
->next
)
1597 /* Check the label is a valid branching target. */
1600 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1602 gfc_error ("Label %d referenced at %L is never defined",
1603 arg
->label
->value
, &arg
->label
->where
);
1610 if (e
->expr_type
== EXPR_VARIABLE
1611 && e
->symtree
->n
.sym
->attr
.generic
1613 && count_specific_procs (e
) != 1)
1616 if (e
->ts
.type
!= BT_PROCEDURE
)
1618 save_need_full_assumed_size
= need_full_assumed_size
;
1619 if (e
->expr_type
!= EXPR_VARIABLE
)
1620 need_full_assumed_size
= 0;
1621 if (gfc_resolve_expr (e
) != SUCCESS
)
1623 need_full_assumed_size
= save_need_full_assumed_size
;
1627 /* See if the expression node should really be a variable reference. */
1629 sym
= e
->symtree
->n
.sym
;
1631 if (sym
->attr
.flavor
== FL_PROCEDURE
1632 || sym
->attr
.intrinsic
1633 || sym
->attr
.external
)
1637 /* If a procedure is not already determined to be something else
1638 check if it is intrinsic. */
1639 if (!sym
->attr
.intrinsic
1640 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1641 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1642 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1643 sym
->attr
.intrinsic
= 1;
1645 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1647 gfc_error ("Statement function '%s' at %L is not allowed as an "
1648 "actual argument", sym
->name
, &e
->where
);
1651 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1652 sym
->attr
.subroutine
);
1653 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1655 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1656 "actual argument", sym
->name
, &e
->where
);
1659 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1660 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1662 if (gfc_notify_std (GFC_STD_F2008
,
1663 "Fortran 2008: Internal procedure '%s' is"
1664 " used as actual argument at %L",
1665 sym
->name
, &e
->where
) == FAILURE
)
1669 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1671 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1672 "allowed as an actual argument at %L", sym
->name
,
1676 /* Check if a generic interface has a specific procedure
1677 with the same name before emitting an error. */
1678 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1681 /* Just in case a specific was found for the expression. */
1682 sym
= e
->symtree
->n
.sym
;
1684 /* If the symbol is the function that names the current (or
1685 parent) scope, then we really have a variable reference. */
1687 if (gfc_is_function_return_value (sym
, sym
->ns
))
1690 /* If all else fails, see if we have a specific intrinsic. */
1691 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1693 gfc_intrinsic_sym
*isym
;
1695 isym
= gfc_find_function (sym
->name
);
1696 if (isym
== NULL
|| !isym
->specific
)
1698 gfc_error ("Unable to find a specific INTRINSIC procedure "
1699 "for the reference '%s' at %L", sym
->name
,
1704 sym
->attr
.intrinsic
= 1;
1705 sym
->attr
.function
= 1;
1708 if (gfc_resolve_expr (e
) == FAILURE
)
1713 /* See if the name is a module procedure in a parent unit. */
1715 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1718 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1720 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1724 if (parent_st
== NULL
)
1727 sym
= parent_st
->n
.sym
;
1728 e
->symtree
= parent_st
; /* Point to the right thing. */
1730 if (sym
->attr
.flavor
== FL_PROCEDURE
1731 || sym
->attr
.intrinsic
1732 || sym
->attr
.external
)
1734 if (gfc_resolve_expr (e
) == FAILURE
)
1740 e
->expr_type
= EXPR_VARIABLE
;
1742 if (sym
->as
!= NULL
)
1744 e
->rank
= sym
->as
->rank
;
1745 e
->ref
= gfc_get_ref ();
1746 e
->ref
->type
= REF_ARRAY
;
1747 e
->ref
->u
.ar
.type
= AR_FULL
;
1748 e
->ref
->u
.ar
.as
= sym
->as
;
1751 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1752 primary.c (match_actual_arg). If above code determines that it
1753 is a variable instead, it needs to be resolved as it was not
1754 done at the beginning of this function. */
1755 save_need_full_assumed_size
= need_full_assumed_size
;
1756 if (e
->expr_type
!= EXPR_VARIABLE
)
1757 need_full_assumed_size
= 0;
1758 if (gfc_resolve_expr (e
) != SUCCESS
)
1760 need_full_assumed_size
= save_need_full_assumed_size
;
1763 /* Check argument list functions %VAL, %LOC and %REF. There is
1764 nothing to do for %REF. */
1765 if (arg
->name
&& arg
->name
[0] == '%')
1767 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1769 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1771 gfc_error ("By-value argument at %L is not of numeric "
1778 gfc_error ("By-value argument at %L cannot be an array or "
1779 "an array section", &e
->where
);
1783 /* Intrinsics are still PROC_UNKNOWN here. However,
1784 since same file external procedures are not resolvable
1785 in gfortran, it is a good deal easier to leave them to
1787 if (ptype
!= PROC_UNKNOWN
1788 && ptype
!= PROC_DUMMY
1789 && ptype
!= PROC_EXTERNAL
1790 && ptype
!= PROC_MODULE
)
1792 gfc_error ("By-value argument at %L is not allowed "
1793 "in this context", &e
->where
);
1798 /* Statement functions have already been excluded above. */
1799 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1800 && e
->ts
.type
== BT_PROCEDURE
)
1802 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1804 gfc_error ("Passing internal procedure at %L by location "
1805 "not allowed", &e
->where
);
1811 /* Fortran 2008, C1237. */
1812 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1813 && gfc_has_ultimate_pointer (e
))
1815 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1816 "component", &e
->where
);
1825 /* Do the checks of the actual argument list that are specific to elemental
1826 procedures. If called with c == NULL, we have a function, otherwise if
1827 expr == NULL, we have a subroutine. */
1830 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1832 gfc_actual_arglist
*arg0
;
1833 gfc_actual_arglist
*arg
;
1834 gfc_symbol
*esym
= NULL
;
1835 gfc_intrinsic_sym
*isym
= NULL
;
1837 gfc_intrinsic_arg
*iformal
= NULL
;
1838 gfc_formal_arglist
*eformal
= NULL
;
1839 bool formal_optional
= false;
1840 bool set_by_optional
= false;
1844 /* Is this an elemental procedure? */
1845 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1847 if (expr
->value
.function
.esym
!= NULL
1848 && expr
->value
.function
.esym
->attr
.elemental
)
1850 arg0
= expr
->value
.function
.actual
;
1851 esym
= expr
->value
.function
.esym
;
1853 else if (expr
->value
.function
.isym
!= NULL
1854 && expr
->value
.function
.isym
->elemental
)
1856 arg0
= expr
->value
.function
.actual
;
1857 isym
= expr
->value
.function
.isym
;
1862 else if (c
&& c
->ext
.actual
!= NULL
)
1864 arg0
= c
->ext
.actual
;
1866 if (c
->resolved_sym
)
1867 esym
= c
->resolved_sym
;
1869 esym
= c
->symtree
->n
.sym
;
1872 if (!esym
->attr
.elemental
)
1878 /* The rank of an elemental is the rank of its array argument(s). */
1879 for (arg
= arg0
; arg
; arg
= arg
->next
)
1881 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1883 rank
= arg
->expr
->rank
;
1884 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1885 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1886 set_by_optional
= true;
1888 /* Function specific; set the result rank and shape. */
1892 if (!expr
->shape
&& arg
->expr
->shape
)
1894 expr
->shape
= gfc_get_shape (rank
);
1895 for (i
= 0; i
< rank
; i
++)
1896 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1903 /* If it is an array, it shall not be supplied as an actual argument
1904 to an elemental procedure unless an array of the same rank is supplied
1905 as an actual argument corresponding to a nonoptional dummy argument of
1906 that elemental procedure(12.4.1.5). */
1907 formal_optional
= false;
1909 iformal
= isym
->formal
;
1911 eformal
= esym
->formal
;
1913 for (arg
= arg0
; arg
; arg
= arg
->next
)
1917 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1918 formal_optional
= true;
1919 eformal
= eformal
->next
;
1921 else if (isym
&& iformal
)
1923 if (iformal
->optional
)
1924 formal_optional
= true;
1925 iformal
= iformal
->next
;
1928 formal_optional
= true;
1930 if (pedantic
&& arg
->expr
!= NULL
1931 && arg
->expr
->expr_type
== EXPR_VARIABLE
1932 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1935 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1936 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1938 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1939 "MISSING, it cannot be the actual argument of an "
1940 "ELEMENTAL procedure unless there is a non-optional "
1941 "argument with the same rank (12.4.1.5)",
1942 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1947 for (arg
= arg0
; arg
; arg
= arg
->next
)
1949 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1952 /* Being elemental, the last upper bound of an assumed size array
1953 argument must be present. */
1954 if (resolve_assumed_size_actual (arg
->expr
))
1957 /* Elemental procedure's array actual arguments must conform. */
1960 if (gfc_check_conformance (arg
->expr
, e
,
1961 "elemental procedure") == FAILURE
)
1968 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1969 is an array, the intent inout/out variable needs to be also an array. */
1970 if (rank
> 0 && esym
&& expr
== NULL
)
1971 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1972 arg
= arg
->next
, eformal
= eformal
->next
)
1973 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1974 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1975 && arg
->expr
&& arg
->expr
->rank
== 0)
1977 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1978 "ELEMENTAL subroutine '%s' is a scalar, but another "
1979 "actual argument is an array", &arg
->expr
->where
,
1980 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1981 : "INOUT", eformal
->sym
->name
, esym
->name
);
1988 /* This function does the checking of references to global procedures
1989 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1990 77 and 95 standards. It checks for a gsymbol for the name, making
1991 one if it does not already exist. If it already exists, then the
1992 reference being resolved must correspond to the type of gsymbol.
1993 Otherwise, the new symbol is equipped with the attributes of the
1994 reference. The corresponding code that is called in creating
1995 global entities is parse.c.
1997 In addition, for all but -std=legacy, the gsymbols are used to
1998 check the interfaces of external procedures from the same file.
1999 The namespace of the gsymbol is resolved and then, once this is
2000 done the interface is checked. */
2004 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2006 if (!gsym_ns
->proc_name
->attr
.recursive
)
2009 if (sym
->ns
== gsym_ns
)
2012 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2019 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2021 if (gsym_ns
->entries
)
2023 gfc_entry_list
*entry
= gsym_ns
->entries
;
2025 for (; entry
; entry
= entry
->next
)
2027 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2029 if (strcmp (gsym_ns
->proc_name
->name
,
2030 sym
->ns
->proc_name
->name
) == 0)
2034 && strcmp (gsym_ns
->proc_name
->name
,
2035 sym
->ns
->parent
->proc_name
->name
) == 0)
2044 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2045 gfc_actual_arglist
**actual
, int sub
)
2049 enum gfc_symbol_type type
;
2051 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2053 gsym
= gfc_get_gsymbol (sym
->name
);
2055 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2056 gfc_global_used (gsym
, where
);
2058 if (gfc_option
.flag_whole_file
2059 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2060 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2061 && gsym
->type
!= GSYM_UNKNOWN
2063 && gsym
->ns
->resolved
!= -1
2064 && gsym
->ns
->proc_name
2065 && not_in_recursive (sym
, gsym
->ns
)
2066 && not_entry_self_reference (sym
, gsym
->ns
))
2068 gfc_symbol
*def_sym
;
2070 /* Resolve the gsymbol namespace if needed. */
2071 if (!gsym
->ns
->resolved
)
2073 gfc_dt_list
*old_dt_list
;
2074 struct gfc_omp_saved_state old_omp_state
;
2076 /* Stash away derived types so that the backend_decls do not
2078 old_dt_list
= gfc_derived_types
;
2079 gfc_derived_types
= NULL
;
2080 /* And stash away openmp state. */
2081 gfc_omp_save_and_clear_state (&old_omp_state
);
2083 gfc_resolve (gsym
->ns
);
2085 /* Store the new derived types with the global namespace. */
2086 if (gfc_derived_types
)
2087 gsym
->ns
->derived_types
= gfc_derived_types
;
2089 /* Restore the derived types of this namespace. */
2090 gfc_derived_types
= old_dt_list
;
2091 /* And openmp state. */
2092 gfc_omp_restore_state (&old_omp_state
);
2095 /* Make sure that translation for the gsymbol occurs before
2096 the procedure currently being resolved. */
2097 ns
= gfc_global_ns_list
;
2098 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2100 if (ns
->sibling
== gsym
->ns
)
2102 ns
->sibling
= gsym
->ns
->sibling
;
2103 gsym
->ns
->sibling
= gfc_global_ns_list
;
2104 gfc_global_ns_list
= gsym
->ns
;
2109 def_sym
= gsym
->ns
->proc_name
;
2110 if (def_sym
->attr
.entry_master
)
2112 gfc_entry_list
*entry
;
2113 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2114 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2116 def_sym
= entry
->sym
;
2121 /* Differences in constant character lengths. */
2122 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2124 long int l1
= 0, l2
= 0;
2125 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2126 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2129 && cl1
->length
!= NULL
2130 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2131 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2134 && cl2
->length
!= NULL
2135 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2136 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2138 if (l1
&& l2
&& l1
!= l2
)
2139 gfc_error ("Character length mismatch in return type of "
2140 "function '%s' at %L (%ld/%ld)", sym
->name
,
2141 &sym
->declared_at
, l1
, l2
);
2144 /* Type mismatch of function return type and expected type. */
2145 if (sym
->attr
.function
2146 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2147 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2148 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2149 gfc_typename (&def_sym
->ts
));
2151 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2153 gfc_formal_arglist
*arg
= def_sym
->formal
;
2154 for ( ; arg
; arg
= arg
->next
)
2157 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2158 else if (arg
->sym
->attr
.allocatable
2159 || arg
->sym
->attr
.asynchronous
2160 || arg
->sym
->attr
.optional
2161 || arg
->sym
->attr
.pointer
2162 || arg
->sym
->attr
.target
2163 || arg
->sym
->attr
.value
2164 || arg
->sym
->attr
.volatile_
)
2166 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2167 "has an attribute that requires an explicit "
2168 "interface for this procedure", arg
->sym
->name
,
2169 sym
->name
, &sym
->declared_at
);
2172 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2173 else if (arg
->sym
&& arg
->sym
->as
2174 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2176 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2177 "argument '%s' must have an explicit interface",
2178 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2181 /* F2008, 12.4.2.2 (2c) */
2182 else if (arg
->sym
->attr
.codimension
)
2184 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2185 "'%s' must have an explicit interface",
2186 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2189 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2190 else if (false) /* TODO: is a parametrized derived type */
2192 gfc_error ("Procedure '%s' at %L with parametrized derived "
2193 "type argument '%s' must have an explicit "
2194 "interface", sym
->name
, &sym
->declared_at
,
2198 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2199 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2201 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2202 "argument '%s' must have an explicit interface",
2203 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2208 if (def_sym
->attr
.function
)
2210 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2211 if (def_sym
->as
&& def_sym
->as
->rank
2212 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2213 gfc_error ("The reference to function '%s' at %L either needs an "
2214 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2217 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2218 if ((def_sym
->result
->attr
.pointer
2219 || def_sym
->result
->attr
.allocatable
)
2220 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2221 || def_sym
->result
->attr
.pointer
2222 != sym
->result
->attr
.pointer
2223 || def_sym
->result
->attr
.allocatable
2224 != sym
->result
->attr
.allocatable
))
2225 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2226 "result must have an explicit interface", sym
->name
,
2229 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2230 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2231 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2233 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2235 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2236 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2238 gfc_error ("Nonconstant character-length function '%s' at %L "
2239 "must have an explicit interface", sym
->name
,
2245 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2246 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2248 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2249 "interface", sym
->name
, &sym
->declared_at
);
2252 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2253 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2255 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2256 "an explicit interface", sym
->name
, &sym
->declared_at
);
2259 if (gfc_option
.flag_whole_file
== 1
2260 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2261 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2262 gfc_errors_to_warnings (1);
2264 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2265 gfc_procedure_use (def_sym
, actual
, where
);
2267 gfc_errors_to_warnings (0);
2270 if (gsym
->type
== GSYM_UNKNOWN
)
2273 gsym
->where
= *where
;
2280 /************* Function resolution *************/
2282 /* Resolve a function call known to be generic.
2283 Section 14.1.2.4.1. */
2286 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2290 if (sym
->attr
.generic
)
2292 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2295 expr
->value
.function
.name
= s
->name
;
2296 expr
->value
.function
.esym
= s
;
2298 if (s
->ts
.type
!= BT_UNKNOWN
)
2300 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2301 expr
->ts
= s
->result
->ts
;
2304 expr
->rank
= s
->as
->rank
;
2305 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2306 expr
->rank
= s
->result
->as
->rank
;
2308 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2313 /* TODO: Need to search for elemental references in generic
2317 if (sym
->attr
.intrinsic
)
2318 return gfc_intrinsic_func_interface (expr
, 0);
2325 resolve_generic_f (gfc_expr
*expr
)
2329 gfc_interface
*intr
= NULL
;
2331 sym
= expr
->symtree
->n
.sym
;
2335 m
= resolve_generic_f0 (expr
, sym
);
2338 else if (m
== MATCH_ERROR
)
2343 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2344 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2347 if (sym
->ns
->parent
== NULL
)
2349 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2353 if (!generic_sym (sym
))
2357 /* Last ditch attempt. See if the reference is to an intrinsic
2358 that possesses a matching interface. 14.1.2.4 */
2359 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2361 gfc_error ("There is no specific function for the generic '%s' "
2362 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2368 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2371 return resolve_structure_cons (expr
, 0);
2374 m
= gfc_intrinsic_func_interface (expr
, 0);
2379 gfc_error ("Generic function '%s' at %L is not consistent with a "
2380 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2387 /* Resolve a function call known to be specific. */
2390 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2394 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2396 if (sym
->attr
.dummy
)
2398 sym
->attr
.proc
= PROC_DUMMY
;
2402 sym
->attr
.proc
= PROC_EXTERNAL
;
2406 if (sym
->attr
.proc
== PROC_MODULE
2407 || sym
->attr
.proc
== PROC_ST_FUNCTION
2408 || sym
->attr
.proc
== PROC_INTERNAL
)
2411 if (sym
->attr
.intrinsic
)
2413 m
= gfc_intrinsic_func_interface (expr
, 1);
2417 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2418 "with an intrinsic", sym
->name
, &expr
->where
);
2426 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2429 expr
->ts
= sym
->result
->ts
;
2432 expr
->value
.function
.name
= sym
->name
;
2433 expr
->value
.function
.esym
= sym
;
2434 if (sym
->as
!= NULL
)
2435 expr
->rank
= sym
->as
->rank
;
2442 resolve_specific_f (gfc_expr
*expr
)
2447 sym
= expr
->symtree
->n
.sym
;
2451 m
= resolve_specific_f0 (sym
, expr
);
2454 if (m
== MATCH_ERROR
)
2457 if (sym
->ns
->parent
== NULL
)
2460 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2466 gfc_error ("Unable to resolve the specific function '%s' at %L",
2467 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2473 /* Resolve a procedure call not known to be generic nor specific. */
2476 resolve_unknown_f (gfc_expr
*expr
)
2481 sym
= expr
->symtree
->n
.sym
;
2483 if (sym
->attr
.dummy
)
2485 sym
->attr
.proc
= PROC_DUMMY
;
2486 expr
->value
.function
.name
= sym
->name
;
2490 /* See if we have an intrinsic function reference. */
2492 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2494 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2499 /* The reference is to an external name. */
2501 sym
->attr
.proc
= PROC_EXTERNAL
;
2502 expr
->value
.function
.name
= sym
->name
;
2503 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2505 if (sym
->as
!= NULL
)
2506 expr
->rank
= sym
->as
->rank
;
2508 /* Type of the expression is either the type of the symbol or the
2509 default type of the symbol. */
2512 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2514 if (sym
->ts
.type
!= BT_UNKNOWN
)
2518 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2520 if (ts
->type
== BT_UNKNOWN
)
2522 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2523 sym
->name
, &expr
->where
);
2534 /* Return true, if the symbol is an external procedure. */
2536 is_external_proc (gfc_symbol
*sym
)
2538 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2539 && !(sym
->attr
.intrinsic
2540 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2541 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2542 && !sym
->attr
.proc_pointer
2543 && !sym
->attr
.use_assoc
2551 /* Figure out if a function reference is pure or not. Also set the name
2552 of the function for a potential error message. Return nonzero if the
2553 function is PURE, zero if not. */
2555 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2558 pure_function (gfc_expr
*e
, const char **name
)
2564 if (e
->symtree
!= NULL
2565 && e
->symtree
->n
.sym
!= NULL
2566 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2567 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2569 if (e
->value
.function
.esym
)
2571 pure
= gfc_pure (e
->value
.function
.esym
);
2572 *name
= e
->value
.function
.esym
->name
;
2574 else if (e
->value
.function
.isym
)
2576 pure
= e
->value
.function
.isym
->pure
2577 || e
->value
.function
.isym
->elemental
;
2578 *name
= e
->value
.function
.isym
->name
;
2582 /* Implicit functions are not pure. */
2584 *name
= e
->value
.function
.name
;
2592 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2593 int *f ATTRIBUTE_UNUSED
)
2597 /* Don't bother recursing into other statement functions
2598 since they will be checked individually for purity. */
2599 if (e
->expr_type
!= EXPR_FUNCTION
2601 || e
->symtree
->n
.sym
== sym
2602 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2605 return pure_function (e
, &name
) ? false : true;
2610 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2612 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2617 is_scalar_expr_ptr (gfc_expr
*expr
)
2619 gfc_try retval
= SUCCESS
;
2624 /* See if we have a gfc_ref, which means we have a substring, array
2625 reference, or a component. */
2626 if (expr
->ref
!= NULL
)
2629 while (ref
->next
!= NULL
)
2635 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2636 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2641 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2643 else if (ref
->u
.ar
.type
== AR_FULL
)
2645 /* The user can give a full array if the array is of size 1. */
2646 if (ref
->u
.ar
.as
!= NULL
2647 && ref
->u
.ar
.as
->rank
== 1
2648 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2649 && ref
->u
.ar
.as
->lower
[0] != NULL
2650 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2651 && ref
->u
.ar
.as
->upper
[0] != NULL
2652 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2654 /* If we have a character string, we need to check if
2655 its length is one. */
2656 if (expr
->ts
.type
== BT_CHARACTER
)
2658 if (expr
->ts
.u
.cl
== NULL
2659 || expr
->ts
.u
.cl
->length
== NULL
2660 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2666 /* We have constant lower and upper bounds. If the
2667 difference between is 1, it can be considered a
2669 FIXME: Use gfc_dep_compare_expr instead. */
2670 start
= (int) mpz_get_si
2671 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2672 end
= (int) mpz_get_si
2673 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2674 if (end
- start
+ 1 != 1)
2689 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2691 /* Character string. Make sure it's of length 1. */
2692 if (expr
->ts
.u
.cl
== NULL
2693 || expr
->ts
.u
.cl
->length
== NULL
2694 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2697 else if (expr
->rank
!= 0)
2704 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2705 and, in the case of c_associated, set the binding label based on
2709 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2710 gfc_symbol
**new_sym
)
2712 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2713 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2714 int optional_arg
= 0;
2715 gfc_try retval
= SUCCESS
;
2716 gfc_symbol
*args_sym
;
2717 gfc_typespec
*arg_ts
;
2718 symbol_attribute arg_attr
;
2720 if (args
->expr
->expr_type
== EXPR_CONSTANT
2721 || args
->expr
->expr_type
== EXPR_OP
2722 || args
->expr
->expr_type
== EXPR_NULL
)
2724 gfc_error ("Argument to '%s' at %L is not a variable",
2725 sym
->name
, &(args
->expr
->where
));
2729 args_sym
= args
->expr
->symtree
->n
.sym
;
2731 /* The typespec for the actual arg should be that stored in the expr
2732 and not necessarily that of the expr symbol (args_sym), because
2733 the actual expression could be a part-ref of the expr symbol. */
2734 arg_ts
= &(args
->expr
->ts
);
2735 arg_attr
= gfc_expr_attr (args
->expr
);
2737 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2739 /* If the user gave two args then they are providing something for
2740 the optional arg (the second cptr). Therefore, set the name and
2741 binding label to the c_associated for two cptrs. Otherwise,
2742 set c_associated to expect one cptr. */
2746 sprintf (name
, "%s_2", sym
->name
);
2747 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2753 sprintf (name
, "%s_1", sym
->name
);
2754 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2758 /* Get a new symbol for the version of c_associated that
2760 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2762 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2763 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2765 sprintf (name
, "%s", sym
->name
);
2766 sprintf (binding_label
, "%s", sym
->binding_label
);
2768 /* Error check the call. */
2769 if (args
->next
!= NULL
)
2771 gfc_error_now ("More actual than formal arguments in '%s' "
2772 "call at %L", name
, &(args
->expr
->where
));
2775 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2780 /* Make sure we have either the target or pointer attribute. */
2781 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2783 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2784 "a TARGET or an associated pointer",
2786 sym
->name
, &(args
->expr
->where
));
2790 if (gfc_is_coindexed (args
->expr
))
2792 gfc_error_now ("Coindexed argument not permitted"
2793 " in '%s' call at %L", name
,
2794 &(args
->expr
->where
));
2798 /* Follow references to make sure there are no array
2800 seen_section
= false;
2802 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2804 if (ref
->type
== REF_ARRAY
)
2806 if (ref
->u
.ar
.type
== AR_SECTION
)
2807 seen_section
= true;
2809 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2812 for (r
= ref
->next
; r
; r
=r
->next
)
2813 if (r
->type
== REF_COMPONENT
)
2815 gfc_error_now ("Array section not permitted"
2816 " in '%s' call at %L", name
,
2817 &(args
->expr
->where
));
2825 if (seen_section
&& retval
== SUCCESS
)
2826 gfc_warning ("Array section in '%s' call at %L", name
,
2827 &(args
->expr
->where
));
2829 /* See if we have interoperable type and type param. */
2830 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2831 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2833 if (args_sym
->attr
.target
== 1)
2835 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2836 has the target attribute and is interoperable. */
2837 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2838 allocatable variable that has the TARGET attribute and
2839 is not an array of zero size. */
2840 if (args_sym
->attr
.allocatable
== 1)
2842 if (args_sym
->attr
.dimension
!= 0
2843 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2845 gfc_error_now ("Allocatable variable '%s' used as a "
2846 "parameter to '%s' at %L must not be "
2847 "an array of zero size",
2848 args_sym
->name
, sym
->name
,
2849 &(args
->expr
->where
));
2855 /* A non-allocatable target variable with C
2856 interoperable type and type parameters must be
2858 if (args_sym
&& args_sym
->attr
.dimension
)
2860 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2862 gfc_error ("Assumed-shape array '%s' at %L "
2863 "cannot be an argument to the "
2864 "procedure '%s' because "
2865 "it is not C interoperable",
2867 &(args
->expr
->where
), sym
->name
);
2870 else if (args_sym
->as
->type
== AS_DEFERRED
)
2872 gfc_error ("Deferred-shape array '%s' at %L "
2873 "cannot be an argument to the "
2874 "procedure '%s' because "
2875 "it is not C interoperable",
2877 &(args
->expr
->where
), sym
->name
);
2882 /* Make sure it's not a character string. Arrays of
2883 any type should be ok if the variable is of a C
2884 interoperable type. */
2885 if (arg_ts
->type
== BT_CHARACTER
)
2886 if (arg_ts
->u
.cl
!= NULL
2887 && (arg_ts
->u
.cl
->length
== NULL
2888 || arg_ts
->u
.cl
->length
->expr_type
2891 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2893 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2895 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2896 "at %L must have a length of 1",
2897 args_sym
->name
, sym
->name
,
2898 &(args
->expr
->where
));
2903 else if (arg_attr
.pointer
2904 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2906 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2908 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2909 "associated scalar POINTER", args_sym
->name
,
2910 sym
->name
, &(args
->expr
->where
));
2916 /* The parameter is not required to be C interoperable. If it
2917 is not C interoperable, it must be a nonpolymorphic scalar
2918 with no length type parameters. It still must have either
2919 the pointer or target attribute, and it can be
2920 allocatable (but must be allocated when c_loc is called). */
2921 if (args
->expr
->rank
!= 0
2922 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2924 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2925 "scalar", args_sym
->name
, sym
->name
,
2926 &(args
->expr
->where
));
2929 else if (arg_ts
->type
== BT_CHARACTER
2930 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2932 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2933 "%L must have a length of 1",
2934 args_sym
->name
, sym
->name
,
2935 &(args
->expr
->where
));
2938 else if (arg_ts
->type
== BT_CLASS
)
2940 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2941 "polymorphic", args_sym
->name
, sym
->name
,
2942 &(args
->expr
->where
));
2947 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2949 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2951 /* TODO: Update this error message to allow for procedure
2952 pointers once they are implemented. */
2953 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2955 args_sym
->name
, sym
->name
,
2956 &(args
->expr
->where
));
2959 else if (args_sym
->attr
.is_bind_c
!= 1)
2961 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2963 args_sym
->name
, sym
->name
,
2964 &(args
->expr
->where
));
2969 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2974 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2975 "iso_c_binding function: '%s'!\n", sym
->name
);
2982 /* Resolve a function call, which means resolving the arguments, then figuring
2983 out which entity the name refers to. */
2986 resolve_function (gfc_expr
*expr
)
2988 gfc_actual_arglist
*arg
;
2993 procedure_type p
= PROC_INTRINSIC
;
2994 bool no_formal_args
;
2998 sym
= expr
->symtree
->n
.sym
;
3000 /* If this is a procedure pointer component, it has already been resolved. */
3001 if (gfc_is_proc_ptr_comp (expr
, NULL
))
3004 if (sym
&& sym
->attr
.intrinsic
3005 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3008 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3010 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3014 /* If this ia a deferred TBP with an abstract interface (which may
3015 of course be referenced), expr->value.function.esym will be set. */
3016 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3018 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3019 sym
->name
, &expr
->where
);
3023 /* Switch off assumed size checking and do this again for certain kinds
3024 of procedure, once the procedure itself is resolved. */
3025 need_full_assumed_size
++;
3027 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3028 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3030 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3031 inquiry_argument
= true;
3032 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3034 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3035 p
, no_formal_args
) == FAILURE
)
3037 inquiry_argument
= false;
3041 inquiry_argument
= false;
3043 /* Need to setup the call to the correct c_associated, depending on
3044 the number of cptrs to user gives to compare. */
3045 if (sym
&& sym
->attr
.is_iso_c
== 1)
3047 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3051 /* Get the symtree for the new symbol (resolved func).
3052 the old one will be freed later, when it's no longer used. */
3053 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3056 /* Resume assumed_size checking. */
3057 need_full_assumed_size
--;
3059 /* If the procedure is external, check for usage. */
3060 if (sym
&& is_external_proc (sym
))
3061 resolve_global_procedure (sym
, &expr
->where
,
3062 &expr
->value
.function
.actual
, 0);
3064 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3066 && sym
->ts
.u
.cl
->length
== NULL
3068 && !sym
->ts
.deferred
3069 && expr
->value
.function
.esym
== NULL
3070 && !sym
->attr
.contained
)
3072 /* Internal procedures are taken care of in resolve_contained_fntype. */
3073 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3074 "be used at %L since it is not a dummy argument",
3075 sym
->name
, &expr
->where
);
3079 /* See if function is already resolved. */
3081 if (expr
->value
.function
.name
!= NULL
)
3083 if (expr
->ts
.type
== BT_UNKNOWN
)
3089 /* Apply the rules of section 14.1.2. */
3091 switch (procedure_kind (sym
))
3094 t
= resolve_generic_f (expr
);
3097 case PTYPE_SPECIFIC
:
3098 t
= resolve_specific_f (expr
);
3102 t
= resolve_unknown_f (expr
);
3106 gfc_internal_error ("resolve_function(): bad function type");
3110 /* If the expression is still a function (it might have simplified),
3111 then we check to see if we are calling an elemental function. */
3113 if (expr
->expr_type
!= EXPR_FUNCTION
)
3116 temp
= need_full_assumed_size
;
3117 need_full_assumed_size
= 0;
3119 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3122 if (omp_workshare_flag
3123 && expr
->value
.function
.esym
3124 && ! gfc_elemental (expr
->value
.function
.esym
))
3126 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3127 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3132 #define GENERIC_ID expr->value.function.isym->id
3133 else if (expr
->value
.function
.actual
!= NULL
3134 && expr
->value
.function
.isym
!= NULL
3135 && GENERIC_ID
!= GFC_ISYM_LBOUND
3136 && GENERIC_ID
!= GFC_ISYM_LEN
3137 && GENERIC_ID
!= GFC_ISYM_LOC
3138 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3140 /* Array intrinsics must also have the last upper bound of an
3141 assumed size array argument. UBOUND and SIZE have to be
3142 excluded from the check if the second argument is anything
3145 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3147 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3148 && arg
->next
!= NULL
&& arg
->next
->expr
)
3150 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3153 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3156 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3161 if (arg
->expr
!= NULL
3162 && arg
->expr
->rank
> 0
3163 && resolve_assumed_size_actual (arg
->expr
))
3169 need_full_assumed_size
= temp
;
3172 if (!pure_function (expr
, &name
) && name
)
3176 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3177 "FORALL %s", name
, &expr
->where
,
3178 forall_flag
== 2 ? "mask" : "block");
3181 else if (do_concurrent_flag
)
3183 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3184 "DO CONCURRENT %s", name
, &expr
->where
,
3185 do_concurrent_flag
== 2 ? "mask" : "block");
3188 else if (gfc_pure (NULL
))
3190 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3191 "procedure within a PURE procedure", name
, &expr
->where
);
3195 if (gfc_implicit_pure (NULL
))
3196 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3199 /* Functions without the RECURSIVE attribution are not allowed to
3200 * call themselves. */
3201 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3204 esym
= expr
->value
.function
.esym
;
3206 if (is_illegal_recursion (esym
, gfc_current_ns
))
3208 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3209 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3210 " function '%s' is not RECURSIVE",
3211 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3213 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3214 " is not RECURSIVE", esym
->name
, &expr
->where
);
3220 /* Character lengths of use associated functions may contains references to
3221 symbols not referenced from the current program unit otherwise. Make sure
3222 those symbols are marked as referenced. */
3224 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3225 && expr
->value
.function
.esym
->attr
.use_assoc
)
3227 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3230 /* Make sure that the expression has a typespec that works. */
3231 if (expr
->ts
.type
== BT_UNKNOWN
)
3233 if (expr
->symtree
->n
.sym
->result
3234 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3235 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3236 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3243 /************* Subroutine resolution *************/
3246 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3252 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3253 sym
->name
, &c
->loc
);
3254 else if (do_concurrent_flag
)
3255 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3256 "PURE", sym
->name
, &c
->loc
);
3257 else if (gfc_pure (NULL
))
3258 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3261 if (gfc_implicit_pure (NULL
))
3262 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3267 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3271 if (sym
->attr
.generic
)
3273 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3276 c
->resolved_sym
= s
;
3277 pure_subroutine (c
, s
);
3281 /* TODO: Need to search for elemental references in generic interface. */
3284 if (sym
->attr
.intrinsic
)
3285 return gfc_intrinsic_sub_interface (c
, 0);
3292 resolve_generic_s (gfc_code
*c
)
3297 sym
= c
->symtree
->n
.sym
;
3301 m
= resolve_generic_s0 (c
, sym
);
3304 else if (m
== MATCH_ERROR
)
3308 if (sym
->ns
->parent
== NULL
)
3310 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3314 if (!generic_sym (sym
))
3318 /* Last ditch attempt. See if the reference is to an intrinsic
3319 that possesses a matching interface. 14.1.2.4 */
3320 sym
= c
->symtree
->n
.sym
;
3322 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3324 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3325 sym
->name
, &c
->loc
);
3329 m
= gfc_intrinsic_sub_interface (c
, 0);
3333 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3334 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3340 /* Set the name and binding label of the subroutine symbol in the call
3341 expression represented by 'c' to include the type and kind of the
3342 second parameter. This function is for resolving the appropriate
3343 version of c_f_pointer() and c_f_procpointer(). For example, a
3344 call to c_f_pointer() for a default integer pointer could have a
3345 name of c_f_pointer_i4. If no second arg exists, which is an error
3346 for these two functions, it defaults to the generic symbol's name
3347 and binding label. */
3350 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3351 char *name
, char *binding_label
)
3353 gfc_expr
*arg
= NULL
;
3357 /* The second arg of c_f_pointer and c_f_procpointer determines
3358 the type and kind for the procedure name. */
3359 arg
= c
->ext
.actual
->next
->expr
;
3363 /* Set up the name to have the given symbol's name,
3364 plus the type and kind. */
3365 /* a derived type is marked with the type letter 'u' */
3366 if (arg
->ts
.type
== BT_DERIVED
)
3369 kind
= 0; /* set the kind as 0 for now */
3373 type
= gfc_type_letter (arg
->ts
.type
);
3374 kind
= arg
->ts
.kind
;
3377 if (arg
->ts
.type
== BT_CHARACTER
)
3378 /* Kind info for character strings not needed. */
3381 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3382 /* Set up the binding label as the given symbol's label plus
3383 the type and kind. */
3384 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
3388 /* If the second arg is missing, set the name and label as
3389 was, cause it should at least be found, and the missing
3390 arg error will be caught by compare_parameters(). */
3391 sprintf (name
, "%s", sym
->name
);
3392 sprintf (binding_label
, "%s", sym
->binding_label
);
3399 /* Resolve a generic version of the iso_c_binding procedure given
3400 (sym) to the specific one based on the type and kind of the
3401 argument(s). Currently, this function resolves c_f_pointer() and
3402 c_f_procpointer based on the type and kind of the second argument
3403 (FPTR). Other iso_c_binding procedures aren't specially handled.
3404 Upon successfully exiting, c->resolved_sym will hold the resolved
3405 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3409 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3411 gfc_symbol
*new_sym
;
3412 /* this is fine, since we know the names won't use the max */
3413 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3414 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
3415 /* default to success; will override if find error */
3416 match m
= MATCH_YES
;
3418 /* Make sure the actual arguments are in the necessary order (based on the
3419 formal args) before resolving. */
3420 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3422 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3423 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3425 set_name_and_label (c
, sym
, name
, binding_label
);
3427 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3429 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3431 /* Make sure we got a third arg if the second arg has non-zero
3432 rank. We must also check that the type and rank are
3433 correct since we short-circuit this check in
3434 gfc_procedure_use() (called above to sort actual args). */
3435 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3437 if(c
->ext
.actual
->next
->next
== NULL
3438 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3441 gfc_error ("Missing SHAPE parameter for call to %s "
3442 "at %L", sym
->name
, &(c
->loc
));
3444 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3446 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3449 gfc_error ("SHAPE parameter for call to %s at %L must "
3450 "be a rank 1 INTEGER array", sym
->name
,
3457 if (m
!= MATCH_ERROR
)
3459 /* the 1 means to add the optional arg to formal list */
3460 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3462 /* for error reporting, say it's declared where the original was */
3463 new_sym
->declared_at
= sym
->declared_at
;
3468 /* no differences for c_loc or c_funloc */
3472 /* set the resolved symbol */
3473 if (m
!= MATCH_ERROR
)
3474 c
->resolved_sym
= new_sym
;
3476 c
->resolved_sym
= sym
;
3482 /* Resolve a subroutine call known to be specific. */
3485 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3489 if(sym
->attr
.is_iso_c
)
3491 m
= gfc_iso_c_sub_interface (c
,sym
);
3495 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3497 if (sym
->attr
.dummy
)
3499 sym
->attr
.proc
= PROC_DUMMY
;
3503 sym
->attr
.proc
= PROC_EXTERNAL
;
3507 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3510 if (sym
->attr
.intrinsic
)
3512 m
= gfc_intrinsic_sub_interface (c
, 1);
3516 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3517 "with an intrinsic", sym
->name
, &c
->loc
);
3525 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3527 c
->resolved_sym
= sym
;
3528 pure_subroutine (c
, sym
);
3535 resolve_specific_s (gfc_code
*c
)
3540 sym
= c
->symtree
->n
.sym
;
3544 m
= resolve_specific_s0 (c
, sym
);
3547 if (m
== MATCH_ERROR
)
3550 if (sym
->ns
->parent
== NULL
)
3553 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3559 sym
= c
->symtree
->n
.sym
;
3560 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3561 sym
->name
, &c
->loc
);
3567 /* Resolve a subroutine call not known to be generic nor specific. */
3570 resolve_unknown_s (gfc_code
*c
)
3574 sym
= c
->symtree
->n
.sym
;
3576 if (sym
->attr
.dummy
)
3578 sym
->attr
.proc
= PROC_DUMMY
;
3582 /* See if we have an intrinsic function reference. */
3584 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3586 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3591 /* The reference is to an external name. */
3594 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3596 c
->resolved_sym
= sym
;
3598 pure_subroutine (c
, sym
);
3604 /* Resolve a subroutine call. Although it was tempting to use the same code
3605 for functions, subroutines and functions are stored differently and this
3606 makes things awkward. */
3609 resolve_call (gfc_code
*c
)
3612 procedure_type ptype
= PROC_INTRINSIC
;
3613 gfc_symbol
*csym
, *sym
;
3614 bool no_formal_args
;
3616 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3618 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3620 gfc_error ("'%s' at %L has a type, which is not consistent with "
3621 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3625 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3628 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3629 sym
= st
? st
->n
.sym
: NULL
;
3630 if (sym
&& csym
!= sym
3631 && sym
->ns
== gfc_current_ns
3632 && sym
->attr
.flavor
== FL_PROCEDURE
3633 && sym
->attr
.contained
)
3636 if (csym
->attr
.generic
)
3637 c
->symtree
->n
.sym
= sym
;
3640 csym
= c
->symtree
->n
.sym
;
3644 /* If this ia a deferred TBP with an abstract interface
3645 (which may of course be referenced), c->expr1 will be set. */
3646 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3648 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3649 csym
->name
, &c
->loc
);
3653 /* Subroutines without the RECURSIVE attribution are not allowed to
3654 * call themselves. */
3655 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3657 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3658 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3659 " subroutine '%s' is not RECURSIVE",
3660 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3662 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3663 " is not RECURSIVE", csym
->name
, &c
->loc
);
3668 /* Switch off assumed size checking and do this again for certain kinds
3669 of procedure, once the procedure itself is resolved. */
3670 need_full_assumed_size
++;
3673 ptype
= csym
->attr
.proc
;
3675 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3676 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3677 no_formal_args
) == FAILURE
)
3680 /* Resume assumed_size checking. */
3681 need_full_assumed_size
--;
3683 /* If external, check for usage. */
3684 if (csym
&& is_external_proc (csym
))
3685 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3688 if (c
->resolved_sym
== NULL
)
3690 c
->resolved_isym
= NULL
;
3691 switch (procedure_kind (csym
))
3694 t
= resolve_generic_s (c
);
3697 case PTYPE_SPECIFIC
:
3698 t
= resolve_specific_s (c
);
3702 t
= resolve_unknown_s (c
);
3706 gfc_internal_error ("resolve_subroutine(): bad function type");
3710 /* Some checks of elemental subroutine actual arguments. */
3711 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3718 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3719 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3720 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3721 if their shapes do not match. If either op1->shape or op2->shape is
3722 NULL, return SUCCESS. */
3725 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3732 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3734 for (i
= 0; i
< op1
->rank
; i
++)
3736 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3738 gfc_error ("Shapes for operands at %L and %L are not conformable",
3739 &op1
->where
, &op2
->where
);
3750 /* Resolve an operator expression node. This can involve replacing the
3751 operation with a user defined function call. */
3754 resolve_operator (gfc_expr
*e
)
3756 gfc_expr
*op1
, *op2
;
3758 bool dual_locus_error
;
3761 /* Resolve all subnodes-- give them types. */
3763 switch (e
->value
.op
.op
)
3766 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3769 /* Fall through... */
3772 case INTRINSIC_UPLUS
:
3773 case INTRINSIC_UMINUS
:
3774 case INTRINSIC_PARENTHESES
:
3775 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3780 /* Typecheck the new node. */
3782 op1
= e
->value
.op
.op1
;
3783 op2
= e
->value
.op
.op2
;
3784 dual_locus_error
= false;
3786 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3787 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3789 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3793 switch (e
->value
.op
.op
)
3795 case INTRINSIC_UPLUS
:
3796 case INTRINSIC_UMINUS
:
3797 if (op1
->ts
.type
== BT_INTEGER
3798 || op1
->ts
.type
== BT_REAL
3799 || op1
->ts
.type
== BT_COMPLEX
)
3805 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3806 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3809 case INTRINSIC_PLUS
:
3810 case INTRINSIC_MINUS
:
3811 case INTRINSIC_TIMES
:
3812 case INTRINSIC_DIVIDE
:
3813 case INTRINSIC_POWER
:
3814 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3816 gfc_type_convert_binary (e
, 1);
3821 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3822 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3823 gfc_typename (&op2
->ts
));
3826 case INTRINSIC_CONCAT
:
3827 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3828 && op1
->ts
.kind
== op2
->ts
.kind
)
3830 e
->ts
.type
= BT_CHARACTER
;
3831 e
->ts
.kind
= op1
->ts
.kind
;
3836 _("Operands of string concatenation operator at %%L are %s/%s"),
3837 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3843 case INTRINSIC_NEQV
:
3844 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3846 e
->ts
.type
= BT_LOGICAL
;
3847 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3848 if (op1
->ts
.kind
< e
->ts
.kind
)
3849 gfc_convert_type (op1
, &e
->ts
, 2);
3850 else if (op2
->ts
.kind
< e
->ts
.kind
)
3851 gfc_convert_type (op2
, &e
->ts
, 2);
3855 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3856 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3857 gfc_typename (&op2
->ts
));
3862 if (op1
->ts
.type
== BT_LOGICAL
)
3864 e
->ts
.type
= BT_LOGICAL
;
3865 e
->ts
.kind
= op1
->ts
.kind
;
3869 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3870 gfc_typename (&op1
->ts
));
3874 case INTRINSIC_GT_OS
:
3876 case INTRINSIC_GE_OS
:
3878 case INTRINSIC_LT_OS
:
3880 case INTRINSIC_LE_OS
:
3881 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3883 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3887 /* Fall through... */
3890 case INTRINSIC_EQ_OS
:
3892 case INTRINSIC_NE_OS
:
3893 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3894 && op1
->ts
.kind
== op2
->ts
.kind
)
3896 e
->ts
.type
= BT_LOGICAL
;
3897 e
->ts
.kind
= gfc_default_logical_kind
;
3901 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3903 gfc_type_convert_binary (e
, 1);
3905 e
->ts
.type
= BT_LOGICAL
;
3906 e
->ts
.kind
= gfc_default_logical_kind
;
3910 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3912 _("Logicals at %%L must be compared with %s instead of %s"),
3913 (e
->value
.op
.op
== INTRINSIC_EQ
3914 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3915 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3918 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3919 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3920 gfc_typename (&op2
->ts
));
3924 case INTRINSIC_USER
:
3925 if (e
->value
.op
.uop
->op
== NULL
)
3926 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3927 else if (op2
== NULL
)
3928 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3929 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3932 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3933 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3934 gfc_typename (&op2
->ts
));
3935 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3940 case INTRINSIC_PARENTHESES
:
3942 if (e
->ts
.type
== BT_CHARACTER
)
3943 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3947 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3950 /* Deal with arrayness of an operand through an operator. */
3954 switch (e
->value
.op
.op
)
3956 case INTRINSIC_PLUS
:
3957 case INTRINSIC_MINUS
:
3958 case INTRINSIC_TIMES
:
3959 case INTRINSIC_DIVIDE
:
3960 case INTRINSIC_POWER
:
3961 case INTRINSIC_CONCAT
:
3965 case INTRINSIC_NEQV
:
3967 case INTRINSIC_EQ_OS
:
3969 case INTRINSIC_NE_OS
:
3971 case INTRINSIC_GT_OS
:
3973 case INTRINSIC_GE_OS
:
3975 case INTRINSIC_LT_OS
:
3977 case INTRINSIC_LE_OS
:
3979 if (op1
->rank
== 0 && op2
->rank
== 0)
3982 if (op1
->rank
== 0 && op2
->rank
!= 0)
3984 e
->rank
= op2
->rank
;
3986 if (e
->shape
== NULL
)
3987 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3990 if (op1
->rank
!= 0 && op2
->rank
== 0)
3992 e
->rank
= op1
->rank
;
3994 if (e
->shape
== NULL
)
3995 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3998 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4000 if (op1
->rank
== op2
->rank
)
4002 e
->rank
= op1
->rank
;
4003 if (e
->shape
== NULL
)
4005 t
= compare_shapes (op1
, op2
);
4009 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4014 /* Allow higher level expressions to work. */
4017 /* Try user-defined operators, and otherwise throw an error. */
4018 dual_locus_error
= true;
4020 _("Inconsistent ranks for operator at %%L and %%L"));
4027 case INTRINSIC_PARENTHESES
:
4029 case INTRINSIC_UPLUS
:
4030 case INTRINSIC_UMINUS
:
4031 /* Simply copy arrayness attribute */
4032 e
->rank
= op1
->rank
;
4034 if (e
->shape
== NULL
)
4035 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4043 /* Attempt to simplify the expression. */
4046 t
= gfc_simplify_expr (e
, 0);
4047 /* Some calls do not succeed in simplification and return FAILURE
4048 even though there is no error; e.g. variable references to
4049 PARAMETER arrays. */
4050 if (!gfc_is_constant_expr (e
))
4058 match m
= gfc_extend_expr (e
);
4061 if (m
== MATCH_ERROR
)
4065 if (dual_locus_error
)
4066 gfc_error (msg
, &op1
->where
, &op2
->where
);
4068 gfc_error (msg
, &e
->where
);
4074 /************** Array resolution subroutines **************/
4077 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4080 /* Compare two integer expressions. */
4083 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4087 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4088 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4091 /* If either of the types isn't INTEGER, we must have
4092 raised an error earlier. */
4094 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4097 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4107 /* Compare an integer expression with an integer. */
4110 compare_bound_int (gfc_expr
*a
, int b
)
4114 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4117 if (a
->ts
.type
!= BT_INTEGER
)
4118 gfc_internal_error ("compare_bound_int(): Bad expression");
4120 i
= mpz_cmp_si (a
->value
.integer
, b
);
4130 /* Compare an integer expression with a mpz_t. */
4133 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4137 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4140 if (a
->ts
.type
!= BT_INTEGER
)
4141 gfc_internal_error ("compare_bound_int(): Bad expression");
4143 i
= mpz_cmp (a
->value
.integer
, b
);
4153 /* Compute the last value of a sequence given by a triplet.
4154 Return 0 if it wasn't able to compute the last value, or if the
4155 sequence if empty, and 1 otherwise. */
4158 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4159 gfc_expr
*stride
, mpz_t last
)
4163 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4164 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4165 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4168 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4169 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4172 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4174 if (compare_bound (start
, end
) == CMP_GT
)
4176 mpz_set (last
, end
->value
.integer
);
4180 if (compare_bound_int (stride
, 0) == CMP_GT
)
4182 /* Stride is positive */
4183 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4188 /* Stride is negative */
4189 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4194 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4195 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4196 mpz_sub (last
, end
->value
.integer
, rem
);
4203 /* Compare a single dimension of an array reference to the array
4207 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4211 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4213 gcc_assert (ar
->stride
[i
] == NULL
);
4214 /* This implies [*] as [*:] and [*:3] are not possible. */
4215 if (ar
->start
[i
] == NULL
)
4217 gcc_assert (ar
->end
[i
] == NULL
);
4222 /* Given start, end and stride values, calculate the minimum and
4223 maximum referenced indexes. */
4225 switch (ar
->dimen_type
[i
])
4228 case DIMEN_THIS_IMAGE
:
4233 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
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
->lower
[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
->lower
[i
]->value
.integer
),
4248 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4251 gfc_warning ("Array reference at %L is out of bounds "
4252 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4253 mpz_get_si (ar
->start
[i
]->value
.integer
),
4254 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4256 gfc_warning ("Array reference at %L is out of bounds "
4257 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4258 mpz_get_si (ar
->start
[i
]->value
.integer
),
4259 mpz_get_si (as
->upper
[i
]->value
.integer
),
4268 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4269 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4271 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4273 /* Check for zero stride, which is not allowed. */
4274 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4276 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4280 /* if start == len || (stride > 0 && start < len)
4281 || (stride < 0 && start > len),
4282 then the array section contains at least one element. In this
4283 case, there is an out-of-bounds access if
4284 (start < lower || start > upper). */
4285 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4286 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4287 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4288 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4289 && comp_start_end
== CMP_GT
))
4291 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4293 gfc_warning ("Lower array reference at %L is out of bounds "
4294 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4295 mpz_get_si (AR_START
->value
.integer
),
4296 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4299 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4301 gfc_warning ("Lower array reference at %L is out of bounds "
4302 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4303 mpz_get_si (AR_START
->value
.integer
),
4304 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4309 /* If we can compute the highest index of the array section,
4310 then it also has to be between lower and upper. */
4311 mpz_init (last_value
);
4312 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4315 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4317 gfc_warning ("Upper array reference at %L is out of bounds "
4318 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4319 mpz_get_si (last_value
),
4320 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4321 mpz_clear (last_value
);
4324 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4326 gfc_warning ("Upper array reference at %L is out of bounds "
4327 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4328 mpz_get_si (last_value
),
4329 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4330 mpz_clear (last_value
);
4334 mpz_clear (last_value
);
4342 gfc_internal_error ("check_dimension(): Bad array reference");
4349 /* Compare an array reference with an array specification. */
4352 compare_spec_to_ref (gfc_array_ref
*ar
)
4359 /* TODO: Full array sections are only allowed as actual parameters. */
4360 if (as
->type
== AS_ASSUMED_SIZE
4361 && (/*ar->type == AR_FULL
4362 ||*/ (ar
->type
== AR_SECTION
4363 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4365 gfc_error ("Rightmost upper bound of assumed size array section "
4366 "not specified at %L", &ar
->where
);
4370 if (ar
->type
== AR_FULL
)
4373 if (as
->rank
!= ar
->dimen
)
4375 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4376 &ar
->where
, ar
->dimen
, as
->rank
);
4380 /* ar->codimen == 0 is a local array. */
4381 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4383 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4384 &ar
->where
, ar
->codimen
, as
->corank
);
4388 for (i
= 0; i
< as
->rank
; i
++)
4389 if (check_dimension (i
, ar
, as
) == FAILURE
)
4392 /* Local access has no coarray spec. */
4393 if (ar
->codimen
!= 0)
4394 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4396 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4397 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4399 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4400 i
+ 1 - as
->rank
, &ar
->where
);
4403 if (check_dimension (i
, ar
, as
) == FAILURE
)
4411 /* Resolve one part of an array index. */
4414 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4415 int force_index_integer_kind
)
4422 if (gfc_resolve_expr (index
) == FAILURE
)
4425 if (check_scalar
&& index
->rank
!= 0)
4427 gfc_error ("Array index at %L must be scalar", &index
->where
);
4431 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4433 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4434 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4438 if (index
->ts
.type
== BT_REAL
)
4439 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4440 &index
->where
) == FAILURE
)
4443 if ((index
->ts
.kind
!= gfc_index_integer_kind
4444 && force_index_integer_kind
)
4445 || index
->ts
.type
!= BT_INTEGER
)
4448 ts
.type
= BT_INTEGER
;
4449 ts
.kind
= gfc_index_integer_kind
;
4451 gfc_convert_type_warn (index
, &ts
, 2, 0);
4457 /* Resolve one part of an array index. */
4460 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4462 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4465 /* Resolve a dim argument to an intrinsic function. */
4468 gfc_resolve_dim_arg (gfc_expr
*dim
)
4473 if (gfc_resolve_expr (dim
) == FAILURE
)
4478 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4483 if (dim
->ts
.type
!= BT_INTEGER
)
4485 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4489 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4494 ts
.type
= BT_INTEGER
;
4495 ts
.kind
= gfc_index_integer_kind
;
4497 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4503 /* Given an expression that contains array references, update those array
4504 references to point to the right array specifications. While this is
4505 filled in during matching, this information is difficult to save and load
4506 in a module, so we take care of it here.
4508 The idea here is that the original array reference comes from the
4509 base symbol. We traverse the list of reference structures, setting
4510 the stored reference to references. Component references can
4511 provide an additional array specification. */
4514 find_array_spec (gfc_expr
*e
)
4520 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4521 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4523 as
= e
->symtree
->n
.sym
->as
;
4525 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4530 gfc_internal_error ("find_array_spec(): Missing spec");
4537 c
= ref
->u
.c
.component
;
4538 if (c
->attr
.dimension
)
4541 gfc_internal_error ("find_array_spec(): unused as(1)");
4552 gfc_internal_error ("find_array_spec(): unused as(2)");
4556 /* Resolve an array reference. */
4559 resolve_array_ref (gfc_array_ref
*ar
)
4561 int i
, check_scalar
;
4564 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4566 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4568 /* Do not force gfc_index_integer_kind for the start. We can
4569 do fine with any integer kind. This avoids temporary arrays
4570 created for indexing with a vector. */
4571 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4573 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4575 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4580 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4584 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4588 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4589 if (e
->expr_type
== EXPR_VARIABLE
4590 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4591 ar
->start
[i
] = gfc_get_parentheses (e
);
4595 gfc_error ("Array index at %L is an array of rank %d",
4596 &ar
->c_where
[i
], e
->rank
);
4600 /* Fill in the upper bound, which may be lower than the
4601 specified one for something like a(2:10:5), which is
4602 identical to a(2:7:5). Only relevant for strides not equal
4603 to one. Don't try a division by zero. */
4604 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4605 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4606 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4607 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4611 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4613 if (ar
->end
[i
] == NULL
)
4616 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4618 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4620 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4621 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4623 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4634 if (ar
->type
== AR_FULL
)
4636 if (ar
->as
->rank
== 0)
4637 ar
->type
= AR_ELEMENT
;
4639 /* Make sure array is the same as array(:,:), this way
4640 we don't need to special case all the time. */
4641 ar
->dimen
= ar
->as
->rank
;
4642 for (i
= 0; i
< ar
->dimen
; i
++)
4644 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4646 gcc_assert (ar
->start
[i
] == NULL
);
4647 gcc_assert (ar
->end
[i
] == NULL
);
4648 gcc_assert (ar
->stride
[i
] == NULL
);
4652 /* If the reference type is unknown, figure out what kind it is. */
4654 if (ar
->type
== AR_UNKNOWN
)
4656 ar
->type
= AR_ELEMENT
;
4657 for (i
= 0; i
< ar
->dimen
; i
++)
4658 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4659 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4661 ar
->type
= AR_SECTION
;
4666 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4669 if (ar
->as
->corank
&& ar
->codimen
== 0)
4672 ar
->codimen
= ar
->as
->corank
;
4673 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4674 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4682 resolve_substring (gfc_ref
*ref
)
4684 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4686 if (ref
->u
.ss
.start
!= NULL
)
4688 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4691 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4693 gfc_error ("Substring start index at %L must be of type INTEGER",
4694 &ref
->u
.ss
.start
->where
);
4698 if (ref
->u
.ss
.start
->rank
!= 0)
4700 gfc_error ("Substring start index at %L must be scalar",
4701 &ref
->u
.ss
.start
->where
);
4705 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4706 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4707 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4709 gfc_error ("Substring start index at %L is less than one",
4710 &ref
->u
.ss
.start
->where
);
4715 if (ref
->u
.ss
.end
!= NULL
)
4717 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4720 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4722 gfc_error ("Substring end index at %L must be of type INTEGER",
4723 &ref
->u
.ss
.end
->where
);
4727 if (ref
->u
.ss
.end
->rank
!= 0)
4729 gfc_error ("Substring end index at %L must be scalar",
4730 &ref
->u
.ss
.end
->where
);
4734 if (ref
->u
.ss
.length
!= NULL
4735 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4736 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4737 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4739 gfc_error ("Substring end index at %L exceeds the string length",
4740 &ref
->u
.ss
.start
->where
);
4744 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4745 gfc_integer_kinds
[k
].huge
) == CMP_GT
4746 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4747 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4749 gfc_error ("Substring end index at %L is too large",
4750 &ref
->u
.ss
.end
->where
);
4759 /* This function supplies missing substring charlens. */
4762 gfc_resolve_substring_charlen (gfc_expr
*e
)
4765 gfc_expr
*start
, *end
;
4767 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4768 if (char_ref
->type
== REF_SUBSTRING
)
4774 gcc_assert (char_ref
->next
== NULL
);
4778 if (e
->ts
.u
.cl
->length
)
4779 gfc_free_expr (e
->ts
.u
.cl
->length
);
4780 else if (e
->expr_type
== EXPR_VARIABLE
4781 && e
->symtree
->n
.sym
->attr
.dummy
)
4785 e
->ts
.type
= BT_CHARACTER
;
4786 e
->ts
.kind
= gfc_default_character_kind
;
4789 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4791 if (char_ref
->u
.ss
.start
)
4792 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4794 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4796 if (char_ref
->u
.ss
.end
)
4797 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4798 else if (e
->expr_type
== EXPR_VARIABLE
)
4799 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4806 /* Length = (end - start +1). */
4807 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4808 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4809 gfc_get_int_expr (gfc_default_integer_kind
,
4812 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4813 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4815 /* Make sure that the length is simplified. */
4816 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4817 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4821 /* Resolve subtype references. */
4824 resolve_ref (gfc_expr
*expr
)
4826 int current_part_dimension
, n_components
, seen_part_dimension
;
4829 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4830 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4832 find_array_spec (expr
);
4836 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4840 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4848 if (resolve_substring (ref
) == FAILURE
)
4853 /* Check constraints on part references. */
4855 current_part_dimension
= 0;
4856 seen_part_dimension
= 0;
4859 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4864 switch (ref
->u
.ar
.type
)
4867 /* Coarray scalar. */
4868 if (ref
->u
.ar
.as
->rank
== 0)
4870 current_part_dimension
= 0;
4875 current_part_dimension
= 1;
4879 current_part_dimension
= 0;
4883 gfc_internal_error ("resolve_ref(): Bad array reference");
4889 if (current_part_dimension
|| seen_part_dimension
)
4892 if (ref
->u
.c
.component
->attr
.pointer
4893 || ref
->u
.c
.component
->attr
.proc_pointer
)
4895 gfc_error ("Component to the right of a part reference "
4896 "with nonzero rank must not have the POINTER "
4897 "attribute at %L", &expr
->where
);
4900 else if (ref
->u
.c
.component
->attr
.allocatable
)
4902 gfc_error ("Component to the right of a part reference "
4903 "with nonzero rank must not have the ALLOCATABLE "
4904 "attribute at %L", &expr
->where
);
4916 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4917 || ref
->next
== NULL
)
4918 && current_part_dimension
4919 && seen_part_dimension
)
4921 gfc_error ("Two or more part references with nonzero rank must "
4922 "not be specified at %L", &expr
->where
);
4926 if (ref
->type
== REF_COMPONENT
)
4928 if (current_part_dimension
)
4929 seen_part_dimension
= 1;
4931 /* reset to make sure */
4932 current_part_dimension
= 0;
4940 /* Given an expression, determine its shape. This is easier than it sounds.
4941 Leaves the shape array NULL if it is not possible to determine the shape. */
4944 expression_shape (gfc_expr
*e
)
4946 mpz_t array
[GFC_MAX_DIMENSIONS
];
4949 if (e
->rank
== 0 || e
->shape
!= NULL
)
4952 for (i
= 0; i
< e
->rank
; i
++)
4953 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4956 e
->shape
= gfc_get_shape (e
->rank
);
4958 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4963 for (i
--; i
>= 0; i
--)
4964 mpz_clear (array
[i
]);
4968 /* Given a variable expression node, compute the rank of the expression by
4969 examining the base symbol and any reference structures it may have. */
4972 expression_rank (gfc_expr
*e
)
4977 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4978 could lead to serious confusion... */
4979 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4983 if (e
->expr_type
== EXPR_ARRAY
)
4985 /* Constructors can have a rank different from one via RESHAPE(). */
4987 if (e
->symtree
== NULL
)
4993 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4994 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5000 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5002 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5003 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5004 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5006 if (ref
->type
!= REF_ARRAY
)
5009 if (ref
->u
.ar
.type
== AR_FULL
)
5011 rank
= ref
->u
.ar
.as
->rank
;
5015 if (ref
->u
.ar
.type
== AR_SECTION
)
5017 /* Figure out the rank of the section. */
5019 gfc_internal_error ("expression_rank(): Two array specs");
5021 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5022 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5023 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5033 expression_shape (e
);
5037 /* Resolve a variable expression. */
5040 resolve_variable (gfc_expr
*e
)
5047 if (e
->symtree
== NULL
)
5049 sym
= e
->symtree
->n
.sym
;
5051 /* If this is an associate-name, it may be parsed with an array reference
5052 in error even though the target is scalar. Fail directly in this case. */
5053 if (sym
->assoc
&& !sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5056 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5057 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5059 /* On the other hand, the parser may not have known this is an array;
5060 in this case, we have to add a FULL reference. */
5061 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5063 e
->ref
= gfc_get_ref ();
5064 e
->ref
->type
= REF_ARRAY
;
5065 e
->ref
->u
.ar
.type
= AR_FULL
;
5066 e
->ref
->u
.ar
.dimen
= 0;
5069 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5072 if (sym
->attr
.flavor
== FL_PROCEDURE
5073 && (!sym
->attr
.function
5074 || (sym
->attr
.function
&& sym
->result
5075 && sym
->result
->attr
.proc_pointer
5076 && !sym
->result
->attr
.function
)))
5078 e
->ts
.type
= BT_PROCEDURE
;
5079 goto resolve_procedure
;
5082 if (sym
->ts
.type
!= BT_UNKNOWN
)
5083 gfc_variable_attr (e
, &e
->ts
);
5086 /* Must be a simple variable reference. */
5087 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5092 if (check_assumed_size_reference (sym
, e
))
5095 /* Deal with forward references to entries during resolve_code, to
5096 satisfy, at least partially, 12.5.2.5. */
5097 if (gfc_current_ns
->entries
5098 && current_entry_id
== sym
->entry_id
5101 && cs_base
->current
->op
!= EXEC_ENTRY
)
5103 gfc_entry_list
*entry
;
5104 gfc_formal_arglist
*formal
;
5108 /* If the symbol is a dummy... */
5109 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5111 entry
= gfc_current_ns
->entries
;
5114 /* ...test if the symbol is a parameter of previous entries. */
5115 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5116 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5118 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5122 /* If it has not been seen as a dummy, this is an error. */
5125 if (specification_expr
)
5126 gfc_error ("Variable '%s', used in a specification expression"
5127 ", is referenced at %L before the ENTRY statement "
5128 "in which it is a parameter",
5129 sym
->name
, &cs_base
->current
->loc
);
5131 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5132 "statement in which it is a parameter",
5133 sym
->name
, &cs_base
->current
->loc
);
5138 /* Now do the same check on the specification expressions. */
5139 specification_expr
= 1;
5140 if (sym
->ts
.type
== BT_CHARACTER
5141 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5145 for (n
= 0; n
< sym
->as
->rank
; n
++)
5147 specification_expr
= 1;
5148 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5150 specification_expr
= 1;
5151 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5154 specification_expr
= 0;
5157 /* Update the symbol's entry level. */
5158 sym
->entry_id
= current_entry_id
+ 1;
5161 /* If a symbol has been host_associated mark it. This is used latter,
5162 to identify if aliasing is possible via host association. */
5163 if (sym
->attr
.flavor
== FL_VARIABLE
5164 && gfc_current_ns
->parent
5165 && (gfc_current_ns
->parent
== sym
->ns
5166 || (gfc_current_ns
->parent
->parent
5167 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5168 sym
->attr
.host_assoc
= 1;
5171 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5174 /* F2008, C617 and C1229. */
5175 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5176 && gfc_is_coindexed (e
))
5178 gfc_ref
*ref
, *ref2
= NULL
;
5180 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5182 if (ref
->type
== REF_COMPONENT
)
5184 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5188 for ( ; ref
; ref
= ref
->next
)
5189 if (ref
->type
== REF_COMPONENT
)
5192 /* Expression itself is not coindexed object. */
5193 if (ref
&& e
->ts
.type
== BT_CLASS
)
5195 gfc_error ("Polymorphic subobject of coindexed object at %L",
5200 /* Expression itself is coindexed object. */
5204 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5205 for ( ; c
; c
= c
->next
)
5206 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5208 gfc_error ("Coindexed object with polymorphic allocatable "
5209 "subcomponent at %L", &e
->where
);
5220 /* Checks to see that the correct symbol has been host associated.
5221 The only situation where this arises is that in which a twice
5222 contained function is parsed after the host association is made.
5223 Therefore, on detecting this, change the symbol in the expression
5224 and convert the array reference into an actual arglist if the old
5225 symbol is a variable. */
5227 check_host_association (gfc_expr
*e
)
5229 gfc_symbol
*sym
, *old_sym
;
5233 gfc_actual_arglist
*arg
, *tail
= NULL
;
5234 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5236 /* If the expression is the result of substitution in
5237 interface.c(gfc_extend_expr) because there is no way in
5238 which the host association can be wrong. */
5239 if (e
->symtree
== NULL
5240 || e
->symtree
->n
.sym
== NULL
5241 || e
->user_operator
)
5244 old_sym
= e
->symtree
->n
.sym
;
5246 if (gfc_current_ns
->parent
5247 && old_sym
->ns
!= gfc_current_ns
)
5249 /* Use the 'USE' name so that renamed module symbols are
5250 correctly handled. */
5251 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5253 if (sym
&& old_sym
!= sym
5254 && sym
->ts
.type
== old_sym
->ts
.type
5255 && sym
->attr
.flavor
== FL_PROCEDURE
5256 && sym
->attr
.contained
)
5258 /* Clear the shape, since it might not be valid. */
5259 gfc_free_shape (&e
->shape
, e
->rank
);
5261 /* Give the expression the right symtree! */
5262 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5263 gcc_assert (st
!= NULL
);
5265 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5266 || e
->expr_type
== EXPR_FUNCTION
)
5268 /* Original was function so point to the new symbol, since
5269 the actual argument list is already attached to the
5271 e
->value
.function
.esym
= NULL
;
5276 /* Original was variable so convert array references into
5277 an actual arglist. This does not need any checking now
5278 since resolve_function will take care of it. */
5279 e
->value
.function
.actual
= NULL
;
5280 e
->expr_type
= EXPR_FUNCTION
;
5283 /* Ambiguity will not arise if the array reference is not
5284 the last reference. */
5285 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5286 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5289 gcc_assert (ref
->type
== REF_ARRAY
);
5291 /* Grab the start expressions from the array ref and
5292 copy them into actual arguments. */
5293 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5295 arg
= gfc_get_actual_arglist ();
5296 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5297 if (e
->value
.function
.actual
== NULL
)
5298 tail
= e
->value
.function
.actual
= arg
;
5306 /* Dump the reference list and set the rank. */
5307 gfc_free_ref_list (e
->ref
);
5309 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5312 gfc_resolve_expr (e
);
5316 /* This might have changed! */
5317 return e
->expr_type
== EXPR_FUNCTION
;
5322 gfc_resolve_character_operator (gfc_expr
*e
)
5324 gfc_expr
*op1
= e
->value
.op
.op1
;
5325 gfc_expr
*op2
= e
->value
.op
.op2
;
5326 gfc_expr
*e1
= NULL
;
5327 gfc_expr
*e2
= NULL
;
5329 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5331 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5332 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5333 else if (op1
->expr_type
== EXPR_CONSTANT
)
5334 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5335 op1
->value
.character
.length
);
5337 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5338 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5339 else if (op2
->expr_type
== EXPR_CONSTANT
)
5340 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5341 op2
->value
.character
.length
);
5343 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5348 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5349 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5350 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5351 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5352 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5358 /* Ensure that an character expression has a charlen and, if possible, a
5359 length expression. */
5362 fixup_charlen (gfc_expr
*e
)
5364 /* The cases fall through so that changes in expression type and the need
5365 for multiple fixes are picked up. In all circumstances, a charlen should
5366 be available for the middle end to hang a backend_decl on. */
5367 switch (e
->expr_type
)
5370 gfc_resolve_character_operator (e
);
5373 if (e
->expr_type
== EXPR_ARRAY
)
5374 gfc_resolve_character_array_constructor (e
);
5376 case EXPR_SUBSTRING
:
5377 if (!e
->ts
.u
.cl
&& e
->ref
)
5378 gfc_resolve_substring_charlen (e
);
5382 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5389 /* Update an actual argument to include the passed-object for type-bound
5390 procedures at the right position. */
5392 static gfc_actual_arglist
*
5393 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5396 gcc_assert (argpos
> 0);
5400 gfc_actual_arglist
* result
;
5402 result
= gfc_get_actual_arglist ();
5406 result
->name
= name
;
5412 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5414 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5419 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5422 extract_compcall_passed_object (gfc_expr
* e
)
5426 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5428 if (e
->value
.compcall
.base_object
)
5429 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5432 po
= gfc_get_expr ();
5433 po
->expr_type
= EXPR_VARIABLE
;
5434 po
->symtree
= e
->symtree
;
5435 po
->ref
= gfc_copy_ref (e
->ref
);
5436 po
->where
= e
->where
;
5439 if (gfc_resolve_expr (po
) == FAILURE
)
5446 /* Update the arglist of an EXPR_COMPCALL expression to include the
5450 update_compcall_arglist (gfc_expr
* e
)
5453 gfc_typebound_proc
* tbp
;
5455 tbp
= e
->value
.compcall
.tbp
;
5460 po
= extract_compcall_passed_object (e
);
5464 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5470 gcc_assert (tbp
->pass_arg_num
> 0);
5471 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5479 /* Extract the passed object from a PPC call (a copy of it). */
5482 extract_ppc_passed_object (gfc_expr
*e
)
5487 po
= gfc_get_expr ();
5488 po
->expr_type
= EXPR_VARIABLE
;
5489 po
->symtree
= e
->symtree
;
5490 po
->ref
= gfc_copy_ref (e
->ref
);
5491 po
->where
= e
->where
;
5493 /* Remove PPC reference. */
5495 while ((*ref
)->next
)
5496 ref
= &(*ref
)->next
;
5497 gfc_free_ref_list (*ref
);
5500 if (gfc_resolve_expr (po
) == FAILURE
)
5507 /* Update the actual arglist of a procedure pointer component to include the
5511 update_ppc_arglist (gfc_expr
* e
)
5515 gfc_typebound_proc
* tb
;
5517 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5524 else if (tb
->nopass
)
5527 po
= extract_ppc_passed_object (e
);
5534 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5539 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5541 gfc_error ("Base object for procedure-pointer component call at %L is of"
5542 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5546 gcc_assert (tb
->pass_arg_num
> 0);
5547 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5555 /* Check that the object a TBP is called on is valid, i.e. it must not be
5556 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5559 check_typebound_baseobject (gfc_expr
* e
)
5562 gfc_try return_value
= FAILURE
;
5564 base
= extract_compcall_passed_object (e
);
5568 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5571 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5573 gfc_error ("Base object for type-bound procedure call at %L is of"
5574 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5578 /* F08:C1230. If the procedure called is NOPASS,
5579 the base object must be scalar. */
5580 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5582 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5583 " be scalar", &e
->where
);
5587 return_value
= SUCCESS
;
5590 gfc_free_expr (base
);
5591 return return_value
;
5595 /* Resolve a call to a type-bound procedure, either function or subroutine,
5596 statically from the data in an EXPR_COMPCALL expression. The adapted
5597 arglist and the target-procedure symtree are returned. */
5600 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5601 gfc_actual_arglist
** actual
)
5603 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5604 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5606 /* Update the actual arglist for PASS. */
5607 if (update_compcall_arglist (e
) == FAILURE
)
5610 *actual
= e
->value
.compcall
.actual
;
5611 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5613 gfc_free_ref_list (e
->ref
);
5615 e
->value
.compcall
.actual
= NULL
;
5617 /* If we find a deferred typebound procedure, check for derived types
5618 that an over-riding typebound procedure has not been missed. */
5619 if (e
->value
.compcall
.tbp
->deferred
5620 && e
->value
.compcall
.name
5621 && !e
->value
.compcall
.tbp
->non_overridable
5622 && e
->value
.compcall
.base_object
5623 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5626 gfc_symbol
*derived
;
5628 /* Use the derived type of the base_object. */
5629 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5632 /* If necessary, go throught the inheritance chain. */
5633 while (!st
&& derived
)
5635 /* Look for the typebound procedure 'name'. */
5636 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5637 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5638 e
->value
.compcall
.name
);
5640 derived
= gfc_get_derived_super_type (derived
);
5643 /* Now find the specific name in the derived type namespace. */
5644 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5645 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5646 derived
->ns
, 1, &st
);
5654 /* Get the ultimate declared type from an expression. In addition,
5655 return the last class/derived type reference and the copy of the
5656 reference list. If check_types is set true, derived types are
5657 identified as well as class references. */
5659 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5660 gfc_expr
*e
, bool check_types
)
5662 gfc_symbol
*declared
;
5669 *new_ref
= gfc_copy_ref (e
->ref
);
5671 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5673 if (ref
->type
!= REF_COMPONENT
)
5676 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5677 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5678 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5680 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5686 if (declared
== NULL
)
5687 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5693 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5694 which of the specific bindings (if any) matches the arglist and transform
5695 the expression into a call of that binding. */
5698 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5700 gfc_typebound_proc
* genproc
;
5701 const char* genname
;
5703 gfc_symbol
*derived
;
5705 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5706 genname
= e
->value
.compcall
.name
;
5707 genproc
= e
->value
.compcall
.tbp
;
5709 if (!genproc
->is_generic
)
5712 /* Try the bindings on this type and in the inheritance hierarchy. */
5713 for (; genproc
; genproc
= genproc
->overridden
)
5717 gcc_assert (genproc
->is_generic
);
5718 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5721 gfc_actual_arglist
* args
;
5724 gcc_assert (g
->specific
);
5726 if (g
->specific
->error
)
5729 target
= g
->specific
->u
.specific
->n
.sym
;
5731 /* Get the right arglist by handling PASS/NOPASS. */
5732 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5733 if (!g
->specific
->nopass
)
5736 po
= extract_compcall_passed_object (e
);
5740 gcc_assert (g
->specific
->pass_arg_num
> 0);
5741 gcc_assert (!g
->specific
->error
);
5742 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5743 g
->specific
->pass_arg
);
5745 resolve_actual_arglist (args
, target
->attr
.proc
,
5746 is_external_proc (target
) && !target
->formal
);
5748 /* Check if this arglist matches the formal. */
5749 matches
= gfc_arglist_matches_symbol (&args
, target
);
5751 /* Clean up and break out of the loop if we've found it. */
5752 gfc_free_actual_arglist (args
);
5755 e
->value
.compcall
.tbp
= g
->specific
;
5756 genname
= g
->specific_st
->name
;
5757 /* Pass along the name for CLASS methods, where the vtab
5758 procedure pointer component has to be referenced. */
5766 /* Nothing matching found! */
5767 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5768 " '%s' at %L", genname
, &e
->where
);
5772 /* Make sure that we have the right specific instance for the name. */
5773 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5775 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5777 e
->value
.compcall
.tbp
= st
->n
.tb
;
5783 /* Resolve a call to a type-bound subroutine. */
5786 resolve_typebound_call (gfc_code
* c
, const char **name
)
5788 gfc_actual_arglist
* newactual
;
5789 gfc_symtree
* target
;
5791 /* Check that's really a SUBROUTINE. */
5792 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5794 gfc_error ("'%s' at %L should be a SUBROUTINE",
5795 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5799 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5802 /* Pass along the name for CLASS methods, where the vtab
5803 procedure pointer component has to be referenced. */
5805 *name
= c
->expr1
->value
.compcall
.name
;
5807 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5810 /* Transform into an ordinary EXEC_CALL for now. */
5812 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5815 c
->ext
.actual
= newactual
;
5816 c
->symtree
= target
;
5817 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5819 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5821 gfc_free_expr (c
->expr1
);
5822 c
->expr1
= gfc_get_expr ();
5823 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5824 c
->expr1
->symtree
= target
;
5825 c
->expr1
->where
= c
->loc
;
5827 return resolve_call (c
);
5831 /* Resolve a component-call expression. */
5833 resolve_compcall (gfc_expr
* e
, const char **name
)
5835 gfc_actual_arglist
* newactual
;
5836 gfc_symtree
* target
;
5838 /* Check that's really a FUNCTION. */
5839 if (!e
->value
.compcall
.tbp
->function
)
5841 gfc_error ("'%s' at %L should be a FUNCTION",
5842 e
->value
.compcall
.name
, &e
->where
);
5846 /* These must not be assign-calls! */
5847 gcc_assert (!e
->value
.compcall
.assign
);
5849 if (check_typebound_baseobject (e
) == FAILURE
)
5852 /* Pass along the name for CLASS methods, where the vtab
5853 procedure pointer component has to be referenced. */
5855 *name
= e
->value
.compcall
.name
;
5857 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5859 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5861 /* Take the rank from the function's symbol. */
5862 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5863 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5865 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5866 arglist to the TBP's binding target. */
5868 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5871 e
->value
.function
.actual
= newactual
;
5872 e
->value
.function
.name
= NULL
;
5873 e
->value
.function
.esym
= target
->n
.sym
;
5874 e
->value
.function
.isym
= NULL
;
5875 e
->symtree
= target
;
5876 e
->ts
= target
->n
.sym
->ts
;
5877 e
->expr_type
= EXPR_FUNCTION
;
5879 /* Resolution is not necessary if this is a class subroutine; this
5880 function only has to identify the specific proc. Resolution of
5881 the call will be done next in resolve_typebound_call. */
5882 return gfc_resolve_expr (e
);
5887 /* Resolve a typebound function, or 'method'. First separate all
5888 the non-CLASS references by calling resolve_compcall directly. */
5891 resolve_typebound_function (gfc_expr
* e
)
5893 gfc_symbol
*declared
;
5905 /* Deal with typebound operators for CLASS objects. */
5906 expr
= e
->value
.compcall
.base_object
;
5907 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5908 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5910 /* If the base_object is not a variable, the corresponding actual
5911 argument expression must be stored in e->base_expression so
5912 that the corresponding tree temporary can be used as the base
5913 object in gfc_conv_procedure_call. */
5914 if (expr
->expr_type
!= EXPR_VARIABLE
)
5916 gfc_actual_arglist
*args
;
5918 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5920 if (expr
== args
->expr
)
5925 /* Since the typebound operators are generic, we have to ensure
5926 that any delays in resolution are corrected and that the vtab
5929 declared
= ts
.u
.derived
;
5930 c
= gfc_find_component (declared
, "_vptr", true, true);
5931 if (c
->ts
.u
.derived
== NULL
)
5932 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5934 if (resolve_compcall (e
, &name
) == FAILURE
)
5937 /* Use the generic name if it is there. */
5938 name
= name
? name
: e
->value
.function
.esym
->name
;
5939 e
->symtree
= expr
->symtree
;
5940 e
->ref
= gfc_copy_ref (expr
->ref
);
5941 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5943 /* Trim away the extraneous references that emerge from nested
5944 use of interface.c (extend_expr). */
5945 if (class_ref
&& class_ref
->next
)
5947 gfc_free_ref_list (class_ref
->next
);
5948 class_ref
->next
= NULL
;
5950 else if (e
->ref
&& !class_ref
)
5952 gfc_free_ref_list (e
->ref
);
5956 gfc_add_vptr_component (e
);
5957 gfc_add_component_ref (e
, name
);
5958 e
->value
.function
.esym
= NULL
;
5959 if (expr
->expr_type
!= EXPR_VARIABLE
)
5960 e
->base_expr
= expr
;
5965 return resolve_compcall (e
, NULL
);
5967 if (resolve_ref (e
) == FAILURE
)
5970 /* Get the CLASS declared type. */
5971 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5973 /* Weed out cases of the ultimate component being a derived type. */
5974 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5975 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5977 gfc_free_ref_list (new_ref
);
5978 return resolve_compcall (e
, NULL
);
5981 c
= gfc_find_component (declared
, "_data", true, true);
5982 declared
= c
->ts
.u
.derived
;
5984 /* Treat the call as if it is a typebound procedure, in order to roll
5985 out the correct name for the specific function. */
5986 if (resolve_compcall (e
, &name
) == FAILURE
)
5992 /* Convert the expression to a procedure pointer component call. */
5993 e
->value
.function
.esym
= NULL
;
5999 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6000 gfc_add_vptr_component (e
);
6001 gfc_add_component_ref (e
, name
);
6003 /* Recover the typespec for the expression. This is really only
6004 necessary for generic procedures, where the additional call
6005 to gfc_add_component_ref seems to throw the collection of the
6006 correct typespec. */
6013 /* Resolve a typebound subroutine, or 'method'. First separate all
6014 the non-CLASS references by calling resolve_typebound_call
6018 resolve_typebound_subroutine (gfc_code
*code
)
6020 gfc_symbol
*declared
;
6030 st
= code
->expr1
->symtree
;
6032 /* Deal with typebound operators for CLASS objects. */
6033 expr
= code
->expr1
->value
.compcall
.base_object
;
6034 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6035 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6037 /* If the base_object is not a variable, the corresponding actual
6038 argument expression must be stored in e->base_expression so
6039 that the corresponding tree temporary can be used as the base
6040 object in gfc_conv_procedure_call. */
6041 if (expr
->expr_type
!= EXPR_VARIABLE
)
6043 gfc_actual_arglist
*args
;
6045 args
= code
->expr1
->value
.function
.actual
;
6046 for (; args
; args
= args
->next
)
6047 if (expr
== args
->expr
)
6051 /* Since the typebound operators are generic, we have to ensure
6052 that any delays in resolution are corrected and that the vtab
6054 declared
= expr
->ts
.u
.derived
;
6055 c
= gfc_find_component (declared
, "_vptr", true, true);
6056 if (c
->ts
.u
.derived
== NULL
)
6057 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6059 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6062 /* Use the generic name if it is there. */
6063 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6064 code
->expr1
->symtree
= expr
->symtree
;
6065 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6067 /* Trim away the extraneous references that emerge from nested
6068 use of interface.c (extend_expr). */
6069 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6070 if (class_ref
&& class_ref
->next
)
6072 gfc_free_ref_list (class_ref
->next
);
6073 class_ref
->next
= NULL
;
6075 else if (code
->expr1
->ref
&& !class_ref
)
6077 gfc_free_ref_list (code
->expr1
->ref
);
6078 code
->expr1
->ref
= NULL
;
6081 /* Now use the procedure in the vtable. */
6082 gfc_add_vptr_component (code
->expr1
);
6083 gfc_add_component_ref (code
->expr1
, name
);
6084 code
->expr1
->value
.function
.esym
= NULL
;
6085 if (expr
->expr_type
!= EXPR_VARIABLE
)
6086 code
->expr1
->base_expr
= expr
;
6091 return resolve_typebound_call (code
, NULL
);
6093 if (resolve_ref (code
->expr1
) == FAILURE
)
6096 /* Get the CLASS declared type. */
6097 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6099 /* Weed out cases of the ultimate component being a derived type. */
6100 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6101 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6103 gfc_free_ref_list (new_ref
);
6104 return resolve_typebound_call (code
, NULL
);
6107 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6109 ts
= code
->expr1
->ts
;
6113 /* Convert the expression to a procedure pointer component call. */
6114 code
->expr1
->value
.function
.esym
= NULL
;
6115 code
->expr1
->symtree
= st
;
6118 code
->expr1
->ref
= new_ref
;
6120 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6121 gfc_add_vptr_component (code
->expr1
);
6122 gfc_add_component_ref (code
->expr1
, name
);
6124 /* Recover the typespec for the expression. This is really only
6125 necessary for generic procedures, where the additional call
6126 to gfc_add_component_ref seems to throw the collection of the
6127 correct typespec. */
6128 code
->expr1
->ts
= ts
;
6135 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6138 resolve_ppc_call (gfc_code
* c
)
6140 gfc_component
*comp
;
6143 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6146 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6147 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6149 if (!comp
->attr
.subroutine
)
6150 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6152 if (resolve_ref (c
->expr1
) == FAILURE
)
6155 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6158 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6160 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6161 comp
->formal
== NULL
) == FAILURE
)
6164 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6170 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6173 resolve_expr_ppc (gfc_expr
* e
)
6175 gfc_component
*comp
;
6178 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6181 /* Convert to EXPR_FUNCTION. */
6182 e
->expr_type
= EXPR_FUNCTION
;
6183 e
->value
.function
.isym
= NULL
;
6184 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6186 if (comp
->as
!= NULL
)
6187 e
->rank
= comp
->as
->rank
;
6189 if (!comp
->attr
.function
)
6190 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6192 if (resolve_ref (e
) == FAILURE
)
6195 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6196 comp
->formal
== NULL
) == FAILURE
)
6199 if (update_ppc_arglist (e
) == FAILURE
)
6202 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6209 gfc_is_expandable_expr (gfc_expr
*e
)
6211 gfc_constructor
*con
;
6213 if (e
->expr_type
== EXPR_ARRAY
)
6215 /* Traverse the constructor looking for variables that are flavor
6216 parameter. Parameters must be expanded since they are fully used at
6218 con
= gfc_constructor_first (e
->value
.constructor
);
6219 for (; con
; con
= gfc_constructor_next (con
))
6221 if (con
->expr
->expr_type
== EXPR_VARIABLE
6222 && con
->expr
->symtree
6223 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6224 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6226 if (con
->expr
->expr_type
== EXPR_ARRAY
6227 && gfc_is_expandable_expr (con
->expr
))
6235 /* Resolve an expression. That is, make sure that types of operands agree
6236 with their operators, intrinsic operators are converted to function calls
6237 for overloaded types and unresolved function references are resolved. */
6240 gfc_resolve_expr (gfc_expr
*e
)
6248 /* inquiry_argument only applies to variables. */
6249 inquiry_save
= inquiry_argument
;
6250 if (e
->expr_type
!= EXPR_VARIABLE
)
6251 inquiry_argument
= false;
6253 switch (e
->expr_type
)
6256 t
= resolve_operator (e
);
6262 if (check_host_association (e
))
6263 t
= resolve_function (e
);
6266 t
= resolve_variable (e
);
6268 expression_rank (e
);
6271 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6272 && e
->ref
->type
!= REF_SUBSTRING
)
6273 gfc_resolve_substring_charlen (e
);
6278 t
= resolve_typebound_function (e
);
6281 case EXPR_SUBSTRING
:
6282 t
= resolve_ref (e
);
6291 t
= resolve_expr_ppc (e
);
6296 if (resolve_ref (e
) == FAILURE
)
6299 t
= gfc_resolve_array_constructor (e
);
6300 /* Also try to expand a constructor. */
6303 expression_rank (e
);
6304 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6305 gfc_expand_constructor (e
, false);
6308 /* This provides the opportunity for the length of constructors with
6309 character valued function elements to propagate the string length
6310 to the expression. */
6311 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6313 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6314 here rather then add a duplicate test for it above. */
6315 gfc_expand_constructor (e
, false);
6316 t
= gfc_resolve_character_array_constructor (e
);
6321 case EXPR_STRUCTURE
:
6322 t
= resolve_ref (e
);
6326 t
= resolve_structure_cons (e
, 0);
6330 t
= gfc_simplify_expr (e
, 0);
6334 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6337 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6340 inquiry_argument
= inquiry_save
;
6346 /* Resolve an expression from an iterator. They must be scalar and have
6347 INTEGER or (optionally) REAL type. */
6350 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6351 const char *name_msgid
)
6353 if (gfc_resolve_expr (expr
) == FAILURE
)
6356 if (expr
->rank
!= 0)
6358 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6362 if (expr
->ts
.type
!= BT_INTEGER
)
6364 if (expr
->ts
.type
== BT_REAL
)
6367 return gfc_notify_std (GFC_STD_F95_DEL
,
6368 "Deleted feature: %s at %L must be integer",
6369 _(name_msgid
), &expr
->where
);
6372 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6379 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6387 /* Resolve the expressions in an iterator structure. If REAL_OK is
6388 false allow only INTEGER type iterators, otherwise allow REAL types. */
6391 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6393 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6397 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6401 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6402 "Start expression in DO loop") == FAILURE
)
6405 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6406 "End expression in DO loop") == FAILURE
)
6409 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6410 "Step expression in DO loop") == FAILURE
)
6413 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6415 if ((iter
->step
->ts
.type
== BT_INTEGER
6416 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6417 || (iter
->step
->ts
.type
== BT_REAL
6418 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6420 gfc_error ("Step expression in DO loop at %L cannot be zero",
6421 &iter
->step
->where
);
6426 /* Convert start, end, and step to the same type as var. */
6427 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6428 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6429 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6431 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6432 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6433 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6435 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6436 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6437 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6439 if (iter
->start
->expr_type
== EXPR_CONSTANT
6440 && iter
->end
->expr_type
== EXPR_CONSTANT
6441 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6444 if (iter
->start
->ts
.type
== BT_INTEGER
)
6446 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6447 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6451 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6452 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6454 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6455 gfc_warning ("DO loop at %L will be executed zero times",
6456 &iter
->step
->where
);
6463 /* Traversal function for find_forall_index. f == 2 signals that
6464 that variable itself is not to be checked - only the references. */
6467 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6469 if (expr
->expr_type
!= EXPR_VARIABLE
)
6472 /* A scalar assignment */
6473 if (!expr
->ref
|| *f
== 1)
6475 if (expr
->symtree
->n
.sym
== sym
)
6487 /* Check whether the FORALL index appears in the expression or not.
6488 Returns SUCCESS if SYM is found in EXPR. */
6491 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6493 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6500 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6501 to be a scalar INTEGER variable. The subscripts and stride are scalar
6502 INTEGERs, and if stride is a constant it must be nonzero.
6503 Furthermore "A subscript or stride in a forall-triplet-spec shall
6504 not contain a reference to any index-name in the
6505 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6508 resolve_forall_iterators (gfc_forall_iterator
*it
)
6510 gfc_forall_iterator
*iter
, *iter2
;
6512 for (iter
= it
; iter
; iter
= iter
->next
)
6514 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6515 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6516 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6519 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6520 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6521 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6522 &iter
->start
->where
);
6523 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6524 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6526 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6527 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6528 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6530 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6531 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6533 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6535 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6536 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6537 &iter
->stride
->where
, "INTEGER");
6539 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6540 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6541 gfc_error ("FORALL stride expression at %L cannot be zero",
6542 &iter
->stride
->where
);
6544 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6545 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6548 for (iter
= it
; iter
; iter
= iter
->next
)
6549 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6551 if (find_forall_index (iter2
->start
,
6552 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6553 || find_forall_index (iter2
->end
,
6554 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6555 || find_forall_index (iter2
->stride
,
6556 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6557 gfc_error ("FORALL index '%s' may not appear in triplet "
6558 "specification at %L", iter
->var
->symtree
->name
,
6559 &iter2
->start
->where
);
6564 /* Given a pointer to a symbol that is a derived type, see if it's
6565 inaccessible, i.e. if it's defined in another module and the components are
6566 PRIVATE. The search is recursive if necessary. Returns zero if no
6567 inaccessible components are found, nonzero otherwise. */
6570 derived_inaccessible (gfc_symbol
*sym
)
6574 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6577 for (c
= sym
->components
; c
; c
= c
->next
)
6579 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6587 /* Resolve the argument of a deallocate expression. The expression must be
6588 a pointer or a full array. */
6591 resolve_deallocate_expr (gfc_expr
*e
)
6593 symbol_attribute attr
;
6594 int allocatable
, pointer
;
6599 if (gfc_resolve_expr (e
) == FAILURE
)
6602 if (e
->expr_type
!= EXPR_VARIABLE
)
6605 sym
= e
->symtree
->n
.sym
;
6607 if (sym
->ts
.type
== BT_CLASS
)
6609 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6610 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6614 allocatable
= sym
->attr
.allocatable
;
6615 pointer
= sym
->attr
.pointer
;
6617 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6622 if (ref
->u
.ar
.type
!= AR_FULL
6623 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6624 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6629 c
= ref
->u
.c
.component
;
6630 if (c
->ts
.type
== BT_CLASS
)
6632 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6633 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6637 allocatable
= c
->attr
.allocatable
;
6638 pointer
= c
->attr
.pointer
;
6648 attr
= gfc_expr_attr (e
);
6650 if (allocatable
== 0 && attr
.pointer
== 0)
6653 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6659 if (gfc_is_coindexed (e
))
6661 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6666 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6669 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6677 /* Returns true if the expression e contains a reference to the symbol sym. */
6679 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6681 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6688 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6690 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6694 /* Given the expression node e for an allocatable/pointer of derived type to be
6695 allocated, get the expression node to be initialized afterwards (needed for
6696 derived types with default initializers, and derived types with allocatable
6697 components that need nullification.) */
6700 gfc_expr_to_initialize (gfc_expr
*e
)
6706 result
= gfc_copy_expr (e
);
6708 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6709 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6710 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6712 ref
->u
.ar
.type
= AR_FULL
;
6714 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6715 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6720 gfc_free_shape (&result
->shape
, result
->rank
);
6722 /* Recalculate rank, shape, etc. */
6723 gfc_resolve_expr (result
);
6728 /* If the last ref of an expression is an array ref, return a copy of the
6729 expression with that one removed. Otherwise, a copy of the original
6730 expression. This is used for allocate-expressions and pointer assignment
6731 LHS, where there may be an array specification that needs to be stripped
6732 off when using gfc_check_vardef_context. */
6735 remove_last_array_ref (gfc_expr
* e
)
6740 e2
= gfc_copy_expr (e
);
6741 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6742 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6744 gfc_free_ref_list (*r
);
6753 /* Used in resolve_allocate_expr to check that a allocation-object and
6754 a source-expr are conformable. This does not catch all possible
6755 cases; in particular a runtime checking is needed. */
6758 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6761 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6763 /* First compare rank. */
6764 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6766 gfc_error ("Source-expr at %L must be scalar or have the "
6767 "same rank as the allocate-object at %L",
6768 &e1
->where
, &e2
->where
);
6779 for (i
= 0; i
< e1
->rank
; i
++)
6781 if (tail
->u
.ar
.end
[i
])
6783 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6784 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6785 mpz_add_ui (s
, s
, 1);
6789 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6792 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6794 gfc_error ("Source-expr at %L and allocate-object at %L must "
6795 "have the same shape", &e1
->where
, &e2
->where
);
6808 /* Resolve the expression in an ALLOCATE statement, doing the additional
6809 checks to see whether the expression is OK or not. The expression must
6810 have a trailing array reference that gives the size of the array. */
6813 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6815 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6818 symbol_attribute attr
;
6819 gfc_ref
*ref
, *ref2
;
6822 gfc_symbol
*sym
= NULL
;
6827 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6828 checking of coarrays. */
6829 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6830 if (ref
->next
== NULL
)
6833 if (ref
&& ref
->type
== REF_ARRAY
)
6834 ref
->u
.ar
.in_allocate
= true;
6836 if (gfc_resolve_expr (e
) == FAILURE
)
6839 /* Make sure the expression is allocatable or a pointer. If it is
6840 pointer, the next-to-last reference must be a pointer. */
6844 sym
= e
->symtree
->n
.sym
;
6846 /* Check whether ultimate component is abstract and CLASS. */
6849 if (e
->expr_type
!= EXPR_VARIABLE
)
6852 attr
= gfc_expr_attr (e
);
6853 pointer
= attr
.pointer
;
6854 dimension
= attr
.dimension
;
6855 codimension
= attr
.codimension
;
6859 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6861 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6862 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6863 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6864 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6865 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6869 allocatable
= sym
->attr
.allocatable
;
6870 pointer
= sym
->attr
.pointer
;
6871 dimension
= sym
->attr
.dimension
;
6872 codimension
= sym
->attr
.codimension
;
6877 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6882 if (ref
->u
.ar
.codimen
> 0)
6885 for (n
= ref
->u
.ar
.dimen
;
6886 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6887 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6894 if (ref
->next
!= NULL
)
6902 gfc_error ("Coindexed allocatable object at %L",
6907 c
= ref
->u
.c
.component
;
6908 if (c
->ts
.type
== BT_CLASS
)
6910 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6911 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6912 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6913 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6914 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6918 allocatable
= c
->attr
.allocatable
;
6919 pointer
= c
->attr
.pointer
;
6920 dimension
= c
->attr
.dimension
;
6921 codimension
= c
->attr
.codimension
;
6922 is_abstract
= c
->attr
.abstract
;
6934 if (allocatable
== 0 && pointer
== 0)
6936 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6941 /* Some checks for the SOURCE tag. */
6944 /* Check F03:C631. */
6945 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6947 gfc_error ("Type of entity at %L is type incompatible with "
6948 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6952 /* Check F03:C632 and restriction following Note 6.18. */
6953 if (code
->expr3
->rank
> 0
6954 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
6957 /* Check F03:C633. */
6958 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
6960 gfc_error ("The allocate-object at %L and the source-expr at %L "
6961 "shall have the same kind type parameter",
6962 &e
->where
, &code
->expr3
->where
);
6966 /* Check F2008, C642. */
6967 if (code
->expr3
->ts
.type
== BT_DERIVED
6968 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6969 || (code
->expr3
->ts
.u
.derived
->from_intmod
6970 == INTMOD_ISO_FORTRAN_ENV
6971 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6972 == ISOFORTRAN_LOCK_TYPE
)))
6974 gfc_error ("The source-expr at %L shall neither be of type "
6975 "LOCK_TYPE nor have a LOCK_TYPE component if "
6976 "allocate-object at %L is a coarray",
6977 &code
->expr3
->where
, &e
->where
);
6982 /* Check F08:C629. */
6983 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6986 gcc_assert (e
->ts
.type
== BT_CLASS
);
6987 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6988 "type-spec or source-expr", sym
->name
, &e
->where
);
6992 /* In the variable definition context checks, gfc_expr_attr is used
6993 on the expression. This is fooled by the array specification
6994 present in e, thus we have to eliminate that one temporarily. */
6995 e2
= remove_last_array_ref (e
);
6997 if (t
== SUCCESS
&& pointer
)
6998 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
7000 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
7005 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7006 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7008 /* For class arrays, the initialization with SOURCE is done
7009 using _copy and trans_call. It is convenient to exploit that
7010 when the allocated type is different from the declared type but
7011 no SOURCE exists by setting expr3. */
7012 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7014 else if (!code
->expr3
)
7016 /* Set up default initializer if needed. */
7020 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7021 ts
= code
->ext
.alloc
.ts
;
7025 if (ts
.type
== BT_CLASS
)
7026 ts
= ts
.u
.derived
->components
->ts
;
7028 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7030 gfc_code
*init_st
= gfc_get_code ();
7031 init_st
->loc
= code
->loc
;
7032 init_st
->op
= EXEC_INIT_ASSIGN
;
7033 init_st
->expr1
= gfc_expr_to_initialize (e
);
7034 init_st
->expr2
= init_e
;
7035 init_st
->next
= code
->next
;
7036 code
->next
= init_st
;
7039 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7041 /* Default initialization via MOLD (non-polymorphic). */
7042 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7043 gfc_resolve_expr (rhs
);
7044 gfc_free_expr (code
->expr3
);
7048 if (e
->ts
.type
== BT_CLASS
)
7050 /* Make sure the vtab symbol is present when
7051 the module variables are generated. */
7052 gfc_typespec ts
= e
->ts
;
7054 ts
= code
->expr3
->ts
;
7055 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7056 ts
= code
->ext
.alloc
.ts
;
7057 gfc_find_derived_vtab (ts
.u
.derived
);
7059 e
= gfc_expr_to_initialize (e
);
7062 if (dimension
== 0 && codimension
== 0)
7065 /* Make sure the last reference node is an array specifiction. */
7067 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7068 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7070 gfc_error ("Array specification required in ALLOCATE statement "
7071 "at %L", &e
->where
);
7075 /* Make sure that the array section reference makes sense in the
7076 context of an ALLOCATE specification. */
7081 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7082 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7084 gfc_error ("Coarray specification required in ALLOCATE statement "
7085 "at %L", &e
->where
);
7089 for (i
= 0; i
< ar
->dimen
; i
++)
7091 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7094 switch (ar
->dimen_type
[i
])
7100 if (ar
->start
[i
] != NULL
7101 && ar
->end
[i
] != NULL
7102 && ar
->stride
[i
] == NULL
)
7105 /* Fall Through... */
7110 case DIMEN_THIS_IMAGE
:
7111 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7117 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7119 sym
= a
->expr
->symtree
->n
.sym
;
7121 /* TODO - check derived type components. */
7122 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7125 if ((ar
->start
[i
] != NULL
7126 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7127 || (ar
->end
[i
] != NULL
7128 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7130 gfc_error ("'%s' must not appear in the array specification at "
7131 "%L in the same ALLOCATE statement where it is "
7132 "itself allocated", sym
->name
, &ar
->where
);
7138 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7140 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7141 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7143 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7145 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7146 "statement at %L", &e
->where
);
7152 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7153 && ar
->stride
[i
] == NULL
)
7156 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7169 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7171 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7172 gfc_alloc
*a
, *p
, *q
;
7175 errmsg
= code
->expr2
;
7177 /* Check the stat variable. */
7180 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7182 if ((stat
->ts
.type
!= BT_INTEGER
7183 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7184 || stat
->ref
->type
== REF_COMPONENT
)))
7186 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7187 "variable", &stat
->where
);
7189 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7190 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7192 gfc_ref
*ref1
, *ref2
;
7195 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7196 ref1
= ref1
->next
, ref2
= ref2
->next
)
7198 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7200 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7209 gfc_error ("Stat-variable at %L shall not be %sd within "
7210 "the same %s statement", &stat
->where
, fcn
, fcn
);
7216 /* Check the errmsg variable. */
7220 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7223 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7225 if ((errmsg
->ts
.type
!= BT_CHARACTER
7227 && (errmsg
->ref
->type
== REF_ARRAY
7228 || errmsg
->ref
->type
== REF_COMPONENT
)))
7229 || errmsg
->rank
> 0 )
7230 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7231 "variable", &errmsg
->where
);
7233 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7234 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7236 gfc_ref
*ref1
, *ref2
;
7239 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7240 ref1
= ref1
->next
, ref2
= ref2
->next
)
7242 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7244 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7253 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7254 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7260 /* Check that an allocate-object appears only once in the statement.
7261 FIXME: Checking derived types is disabled. */
7262 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7265 for (q
= p
->next
; q
; q
= q
->next
)
7268 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7270 /* This is a potential collision. */
7271 gfc_ref
*pr
= pe
->ref
;
7272 gfc_ref
*qr
= qe
->ref
;
7274 /* Follow the references until
7275 a) They start to differ, in which case there is no error;
7276 you can deallocate a%b and a%c in a single statement
7277 b) Both of them stop, which is an error
7278 c) One of them stops, which is also an error. */
7281 if (pr
== NULL
&& qr
== NULL
)
7283 gfc_error ("Allocate-object at %L also appears at %L",
7284 &pe
->where
, &qe
->where
);
7287 else if (pr
!= NULL
&& qr
== NULL
)
7289 gfc_error ("Allocate-object at %L is subobject of"
7290 " object at %L", &pe
->where
, &qe
->where
);
7293 else if (pr
== NULL
&& qr
!= NULL
)
7295 gfc_error ("Allocate-object at %L is subobject of"
7296 " object at %L", &qe
->where
, &pe
->where
);
7299 /* Here, pr != NULL && qr != NULL */
7300 gcc_assert(pr
->type
== qr
->type
);
7301 if (pr
->type
== REF_ARRAY
)
7303 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7305 gcc_assert (qr
->type
== REF_ARRAY
);
7307 if (pr
->next
&& qr
->next
)
7309 gfc_array_ref
*par
= &(pr
->u
.ar
);
7310 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7311 if (gfc_dep_compare_expr (par
->start
[0],
7312 qar
->start
[0]) != 0)
7318 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7329 if (strcmp (fcn
, "ALLOCATE") == 0)
7331 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7332 resolve_allocate_expr (a
->expr
, code
);
7336 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7337 resolve_deallocate_expr (a
->expr
);
7342 /************ SELECT CASE resolution subroutines ************/
7344 /* Callback function for our mergesort variant. Determines interval
7345 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7346 op1 > op2. Assumes we're not dealing with the default case.
7347 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7348 There are nine situations to check. */
7351 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7355 if (op1
->low
== NULL
) /* op1 = (:L) */
7357 /* op2 = (:N), so overlap. */
7359 /* op2 = (M:) or (M:N), L < M */
7360 if (op2
->low
!= NULL
7361 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7364 else if (op1
->high
== NULL
) /* op1 = (K:) */
7366 /* op2 = (M:), so overlap. */
7368 /* op2 = (:N) or (M:N), K > N */
7369 if (op2
->high
!= NULL
7370 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7373 else /* op1 = (K:L) */
7375 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7376 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7378 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7379 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7381 else /* op2 = (M:N) */
7385 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7388 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7397 /* Merge-sort a double linked case list, detecting overlap in the
7398 process. LIST is the head of the double linked case list before it
7399 is sorted. Returns the head of the sorted list if we don't see any
7400 overlap, or NULL otherwise. */
7403 check_case_overlap (gfc_case
*list
)
7405 gfc_case
*p
, *q
, *e
, *tail
;
7406 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7408 /* If the passed list was empty, return immediately. */
7415 /* Loop unconditionally. The only exit from this loop is a return
7416 statement, when we've finished sorting the case list. */
7423 /* Count the number of merges we do in this pass. */
7426 /* Loop while there exists a merge to be done. */
7431 /* Count this merge. */
7434 /* Cut the list in two pieces by stepping INSIZE places
7435 forward in the list, starting from P. */
7438 for (i
= 0; i
< insize
; i
++)
7447 /* Now we have two lists. Merge them! */
7448 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7450 /* See from which the next case to merge comes from. */
7453 /* P is empty so the next case must come from Q. */
7458 else if (qsize
== 0 || q
== NULL
)
7467 cmp
= compare_cases (p
, q
);
7470 /* The whole case range for P is less than the
7478 /* The whole case range for Q is greater than
7479 the case range for P. */
7486 /* The cases overlap, or they are the same
7487 element in the list. Either way, we must
7488 issue an error and get the next case from P. */
7489 /* FIXME: Sort P and Q by line number. */
7490 gfc_error ("CASE label at %L overlaps with CASE "
7491 "label at %L", &p
->where
, &q
->where
);
7499 /* Add the next element to the merged list. */
7508 /* P has now stepped INSIZE places along, and so has Q. So
7509 they're the same. */
7514 /* If we have done only one merge or none at all, we've
7515 finished sorting the cases. */
7524 /* Otherwise repeat, merging lists twice the size. */
7530 /* Check to see if an expression is suitable for use in a CASE statement.
7531 Makes sure that all case expressions are scalar constants of the same
7532 type. Return FAILURE if anything is wrong. */
7535 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7537 if (e
== NULL
) return SUCCESS
;
7539 if (e
->ts
.type
!= case_expr
->ts
.type
)
7541 gfc_error ("Expression in CASE statement at %L must be of type %s",
7542 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7546 /* C805 (R808) For a given case-construct, each case-value shall be of
7547 the same type as case-expr. For character type, length differences
7548 are allowed, but the kind type parameters shall be the same. */
7550 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7552 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7553 &e
->where
, case_expr
->ts
.kind
);
7557 /* Convert the case value kind to that of case expression kind,
7560 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7561 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7565 gfc_error ("Expression in CASE statement at %L must be scalar",
7574 /* Given a completely parsed select statement, we:
7576 - Validate all expressions and code within the SELECT.
7577 - Make sure that the selection expression is not of the wrong type.
7578 - Make sure that no case ranges overlap.
7579 - Eliminate unreachable cases and unreachable code resulting from
7580 removing case labels.
7582 The standard does allow unreachable cases, e.g. CASE (5:3). But
7583 they are a hassle for code generation, and to prevent that, we just
7584 cut them out here. This is not necessary for overlapping cases
7585 because they are illegal and we never even try to generate code.
7587 We have the additional caveat that a SELECT construct could have
7588 been a computed GOTO in the source code. Fortunately we can fairly
7589 easily work around that here: The case_expr for a "real" SELECT CASE
7590 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7591 we have to do is make sure that the case_expr is a scalar integer
7595 resolve_select (gfc_code
*code
)
7598 gfc_expr
*case_expr
;
7599 gfc_case
*cp
, *default_case
, *tail
, *head
;
7600 int seen_unreachable
;
7606 if (code
->expr1
== NULL
)
7608 /* This was actually a computed GOTO statement. */
7609 case_expr
= code
->expr2
;
7610 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7611 gfc_error ("Selection expression in computed GOTO statement "
7612 "at %L must be a scalar integer expression",
7615 /* Further checking is not necessary because this SELECT was built
7616 by the compiler, so it should always be OK. Just move the
7617 case_expr from expr2 to expr so that we can handle computed
7618 GOTOs as normal SELECTs from here on. */
7619 code
->expr1
= code
->expr2
;
7624 case_expr
= code
->expr1
;
7626 type
= case_expr
->ts
.type
;
7627 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7629 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7630 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7632 /* Punt. Going on here just produce more garbage error messages. */
7636 /* Raise a warning if an INTEGER case value exceeds the range of
7637 the case-expr. Later, all expressions will be promoted to the
7638 largest kind of all case-labels. */
7640 if (type
== BT_INTEGER
)
7641 for (body
= code
->block
; body
; body
= body
->block
)
7642 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7645 && gfc_check_integer_range (cp
->low
->value
.integer
,
7646 case_expr
->ts
.kind
) != ARITH_OK
)
7647 gfc_warning ("Expression in CASE statement at %L is "
7648 "not in the range of %s", &cp
->low
->where
,
7649 gfc_typename (&case_expr
->ts
));
7652 && cp
->low
!= cp
->high
7653 && gfc_check_integer_range (cp
->high
->value
.integer
,
7654 case_expr
->ts
.kind
) != ARITH_OK
)
7655 gfc_warning ("Expression in CASE statement at %L is "
7656 "not in the range of %s", &cp
->high
->where
,
7657 gfc_typename (&case_expr
->ts
));
7660 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7661 of the SELECT CASE expression and its CASE values. Walk the lists
7662 of case values, and if we find a mismatch, promote case_expr to
7663 the appropriate kind. */
7665 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7667 for (body
= code
->block
; body
; body
= body
->block
)
7669 /* Walk the case label list. */
7670 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7672 /* Intercept the DEFAULT case. It does not have a kind. */
7673 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7676 /* Unreachable case ranges are discarded, so ignore. */
7677 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7678 && cp
->low
!= cp
->high
7679 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7683 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7684 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7686 if (cp
->high
!= NULL
7687 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7688 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7693 /* Assume there is no DEFAULT case. */
7694 default_case
= NULL
;
7699 for (body
= code
->block
; body
; body
= body
->block
)
7701 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7703 seen_unreachable
= 0;
7705 /* Walk the case label list, making sure that all case labels
7707 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7709 /* Count the number of cases in the whole construct. */
7712 /* Intercept the DEFAULT case. */
7713 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7715 if (default_case
!= NULL
)
7717 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7718 "by a second DEFAULT CASE at %L",
7719 &default_case
->where
, &cp
->where
);
7730 /* Deal with single value cases and case ranges. Errors are
7731 issued from the validation function. */
7732 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7733 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7739 if (type
== BT_LOGICAL
7740 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7741 || cp
->low
!= cp
->high
))
7743 gfc_error ("Logical range in CASE statement at %L is not "
7744 "allowed", &cp
->low
->where
);
7749 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7752 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7753 if (value
& seen_logical
)
7755 gfc_error ("Constant logical value in CASE statement "
7756 "is repeated at %L",
7761 seen_logical
|= value
;
7764 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7765 && cp
->low
!= cp
->high
7766 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7768 if (gfc_option
.warn_surprising
)
7769 gfc_warning ("Range specification at %L can never "
7770 "be matched", &cp
->where
);
7772 cp
->unreachable
= 1;
7773 seen_unreachable
= 1;
7777 /* If the case range can be matched, it can also overlap with
7778 other cases. To make sure it does not, we put it in a
7779 double linked list here. We sort that with a merge sort
7780 later on to detect any overlapping cases. */
7784 head
->right
= head
->left
= NULL
;
7789 tail
->right
->left
= tail
;
7796 /* It there was a failure in the previous case label, give up
7797 for this case label list. Continue with the next block. */
7801 /* See if any case labels that are unreachable have been seen.
7802 If so, we eliminate them. This is a bit of a kludge because
7803 the case lists for a single case statement (label) is a
7804 single forward linked lists. */
7805 if (seen_unreachable
)
7807 /* Advance until the first case in the list is reachable. */
7808 while (body
->ext
.block
.case_list
!= NULL
7809 && body
->ext
.block
.case_list
->unreachable
)
7811 gfc_case
*n
= body
->ext
.block
.case_list
;
7812 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7814 gfc_free_case_list (n
);
7817 /* Strip all other unreachable cases. */
7818 if (body
->ext
.block
.case_list
)
7820 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7822 if (cp
->next
->unreachable
)
7824 gfc_case
*n
= cp
->next
;
7825 cp
->next
= cp
->next
->next
;
7827 gfc_free_case_list (n
);
7834 /* See if there were overlapping cases. If the check returns NULL,
7835 there was overlap. In that case we don't do anything. If head
7836 is non-NULL, we prepend the DEFAULT case. The sorted list can
7837 then used during code generation for SELECT CASE constructs with
7838 a case expression of a CHARACTER type. */
7841 head
= check_case_overlap (head
);
7843 /* Prepend the default_case if it is there. */
7844 if (head
!= NULL
&& default_case
)
7846 default_case
->left
= NULL
;
7847 default_case
->right
= head
;
7848 head
->left
= default_case
;
7852 /* Eliminate dead blocks that may be the result if we've seen
7853 unreachable case labels for a block. */
7854 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7856 if (body
->block
->ext
.block
.case_list
== NULL
)
7858 /* Cut the unreachable block from the code chain. */
7859 gfc_code
*c
= body
->block
;
7860 body
->block
= c
->block
;
7862 /* Kill the dead block, but not the blocks below it. */
7864 gfc_free_statements (c
);
7868 /* More than two cases is legal but insane for logical selects.
7869 Issue a warning for it. */
7870 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7872 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7877 /* Check if a derived type is extensible. */
7880 gfc_type_is_extensible (gfc_symbol
*sym
)
7882 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7886 /* Resolve an associate name: Resolve target and ensure the type-spec is
7887 correct as well as possibly the array-spec. */
7890 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7894 gcc_assert (sym
->assoc
);
7895 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7897 /* If this is for SELECT TYPE, the target may not yet be set. In that
7898 case, return. Resolution will be called later manually again when
7900 target
= sym
->assoc
->target
;
7903 gcc_assert (!sym
->assoc
->dangling
);
7905 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7908 /* For variable targets, we get some attributes from the target. */
7909 if (target
->expr_type
== EXPR_VARIABLE
)
7913 gcc_assert (target
->symtree
);
7914 tsym
= target
->symtree
->n
.sym
;
7916 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7917 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7919 if (tsym
->ts
.type
== BT_CLASS
)
7920 sym
->attr
.target
= tsym
->attr
.target
|| CLASS_DATA (tsym
)->attr
.pointer
;
7922 sym
->attr
.target
= tsym
->attr
.target
|| tsym
->attr
.pointer
;
7924 if (sym
->ts
.type
== BT_DERIVED
&& tsym
->ts
.type
== BT_CLASS
)
7925 target
->rank
= sym
->as
? sym
->as
->rank
: 0;
7928 /* Get type if this was not already set. Note that it can be
7929 some other type than the target in case this is a SELECT TYPE
7930 selector! So we must not update when the type is already there. */
7931 if (sym
->ts
.type
== BT_UNKNOWN
)
7932 sym
->ts
= target
->ts
;
7933 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7935 /* See if this is a valid association-to-variable. */
7936 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7937 && !gfc_has_vector_subscript (target
));
7939 /* Finally resolve if this is an array or not. */
7940 if (sym
->attr
.dimension
7941 && (target
->ts
.type
== BT_CLASS
7942 ? !CLASS_DATA (target
)->attr
.dimension
7943 : target
->rank
== 0))
7945 gfc_error ("Associate-name '%s' at %L is used as array",
7946 sym
->name
, &sym
->declared_at
);
7947 sym
->attr
.dimension
= 0;
7950 if (target
->rank
> 0)
7951 sym
->attr
.dimension
= 1;
7953 if (sym
->attr
.dimension
)
7955 sym
->as
= gfc_get_array_spec ();
7956 sym
->as
->rank
= target
->rank
;
7957 sym
->as
->type
= AS_DEFERRED
;
7959 /* Target must not be coindexed, thus the associate-variable
7961 sym
->as
->corank
= 0;
7966 /* Resolve a SELECT TYPE statement. */
7969 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7971 gfc_symbol
*selector_type
;
7972 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7973 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7976 char name
[GFC_MAX_SYMBOL_LEN
];
7980 ns
= code
->ext
.block
.ns
;
7983 /* Check for F03:C813. */
7984 if (code
->expr1
->ts
.type
!= BT_CLASS
7985 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7987 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7988 "at %L", &code
->loc
);
7992 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7997 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7998 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7999 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8002 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8004 /* Loop over TYPE IS / CLASS IS cases. */
8005 for (body
= code
->block
; body
; body
= body
->block
)
8007 c
= body
->ext
.block
.case_list
;
8009 /* Check F03:C815. */
8010 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8011 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8013 gfc_error ("Derived type '%s' at %L must be extensible",
8014 c
->ts
.u
.derived
->name
, &c
->where
);
8019 /* Check F03:C816. */
8020 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8021 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8023 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8024 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8029 /* Intercept the DEFAULT case. */
8030 if (c
->ts
.type
== BT_UNKNOWN
)
8032 /* Check F03:C818. */
8035 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8036 "by a second DEFAULT CASE at %L",
8037 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8042 default_case
= body
;
8049 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8050 target if present. If there are any EXIT statements referring to the
8051 SELECT TYPE construct, this is no problem because the gfc_code
8052 reference stays the same and EXIT is equally possible from the BLOCK
8053 it is changed to. */
8054 code
->op
= EXEC_BLOCK
;
8057 gfc_association_list
* assoc
;
8059 assoc
= gfc_get_association_list ();
8060 assoc
->st
= code
->expr1
->symtree
;
8061 assoc
->target
= gfc_copy_expr (code
->expr2
);
8062 assoc
->target
->where
= code
->expr2
->where
;
8063 /* assoc->variable will be set by resolve_assoc_var. */
8065 code
->ext
.block
.assoc
= assoc
;
8066 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8068 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8071 code
->ext
.block
.assoc
= NULL
;
8073 /* Add EXEC_SELECT to switch on type. */
8074 new_st
= gfc_get_code ();
8075 new_st
->op
= code
->op
;
8076 new_st
->expr1
= code
->expr1
;
8077 new_st
->expr2
= code
->expr2
;
8078 new_st
->block
= code
->block
;
8079 code
->expr1
= code
->expr2
= NULL
;
8084 ns
->code
->next
= new_st
;
8086 code
->op
= EXEC_SELECT
;
8087 gfc_add_vptr_component (code
->expr1
);
8088 gfc_add_hash_component (code
->expr1
);
8090 /* Loop over TYPE IS / CLASS IS cases. */
8091 for (body
= code
->block
; body
; body
= body
->block
)
8093 c
= body
->ext
.block
.case_list
;
8095 if (c
->ts
.type
== BT_DERIVED
)
8096 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8097 c
->ts
.u
.derived
->hash_value
);
8099 else if (c
->ts
.type
== BT_UNKNOWN
)
8102 /* Associate temporary to selector. This should only be done
8103 when this case is actually true, so build a new ASSOCIATE
8104 that does precisely this here (instead of using the
8107 if (c
->ts
.type
== BT_CLASS
)
8108 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8110 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8111 st
= gfc_find_symtree (ns
->sym_root
, name
);
8112 gcc_assert (st
->n
.sym
->assoc
);
8113 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8114 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8115 if (c
->ts
.type
== BT_DERIVED
)
8116 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8118 new_st
= gfc_get_code ();
8119 new_st
->op
= EXEC_BLOCK
;
8120 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8121 new_st
->ext
.block
.ns
->code
= body
->next
;
8122 body
->next
= new_st
;
8124 /* Chain in the new list only if it is marked as dangling. Otherwise
8125 there is a CASE label overlap and this is already used. Just ignore,
8126 the error is diagonsed elsewhere. */
8127 if (st
->n
.sym
->assoc
->dangling
)
8129 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8130 st
->n
.sym
->assoc
->dangling
= 0;
8133 resolve_assoc_var (st
->n
.sym
, false);
8136 /* Take out CLASS IS cases for separate treatment. */
8138 while (body
&& body
->block
)
8140 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8142 /* Add to class_is list. */
8143 if (class_is
== NULL
)
8145 class_is
= body
->block
;
8150 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8151 tail
->block
= body
->block
;
8154 /* Remove from EXEC_SELECT list. */
8155 body
->block
= body
->block
->block
;
8168 /* Add a default case to hold the CLASS IS cases. */
8169 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8170 tail
->block
= gfc_get_code ();
8172 tail
->op
= EXEC_SELECT_TYPE
;
8173 tail
->ext
.block
.case_list
= gfc_get_case ();
8174 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8176 default_case
= tail
;
8179 /* More than one CLASS IS block? */
8180 if (class_is
->block
)
8184 /* Sort CLASS IS blocks by extension level. */
8188 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8191 /* F03:C817 (check for doubles). */
8192 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8193 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8195 gfc_error ("Double CLASS IS block in SELECT TYPE "
8197 &c2
->ext
.block
.case_list
->where
);
8200 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8201 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8204 (*c1
)->block
= c2
->block
;
8214 /* Generate IF chain. */
8215 if_st
= gfc_get_code ();
8216 if_st
->op
= EXEC_IF
;
8218 for (body
= class_is
; body
; body
= body
->block
)
8220 new_st
->block
= gfc_get_code ();
8221 new_st
= new_st
->block
;
8222 new_st
->op
= EXEC_IF
;
8223 /* Set up IF condition: Call _gfortran_is_extension_of. */
8224 new_st
->expr1
= gfc_get_expr ();
8225 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8226 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8227 new_st
->expr1
->ts
.kind
= 4;
8228 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8229 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8230 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8231 /* Set up arguments. */
8232 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8233 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8234 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8235 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8236 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8237 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8238 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8239 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8240 new_st
->next
= body
->next
;
8242 if (default_case
->next
)
8244 new_st
->block
= gfc_get_code ();
8245 new_st
= new_st
->block
;
8246 new_st
->op
= EXEC_IF
;
8247 new_st
->next
= default_case
->next
;
8250 /* Replace CLASS DEFAULT code by the IF chain. */
8251 default_case
->next
= if_st
;
8254 /* Resolve the internal code. This can not be done earlier because
8255 it requires that the sym->assoc of selectors is set already. */
8256 gfc_current_ns
= ns
;
8257 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8258 gfc_current_ns
= old_ns
;
8260 resolve_select (code
);
8264 /* Resolve a transfer statement. This is making sure that:
8265 -- a derived type being transferred has only non-pointer components
8266 -- a derived type being transferred doesn't have private components, unless
8267 it's being transferred from the module where the type was defined
8268 -- we're not trying to transfer a whole assumed size array. */
8271 resolve_transfer (gfc_code
*code
)
8280 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8281 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8282 exp
= exp
->value
.op
.op1
;
8284 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8286 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8287 "MOLD=", &exp
->where
);
8291 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8292 && exp
->expr_type
!= EXPR_FUNCTION
))
8295 /* If we are reading, the variable will be changed. Note that
8296 code->ext.dt may be NULL if the TRANSFER is related to
8297 an INQUIRE statement -- but in this case, we are not reading, either. */
8298 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8299 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8303 sym
= exp
->symtree
->n
.sym
;
8306 /* Go to actual component transferred. */
8307 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8308 if (ref
->type
== REF_COMPONENT
)
8309 ts
= &ref
->u
.c
.component
->ts
;
8311 if (ts
->type
== BT_CLASS
)
8313 /* FIXME: Test for defined input/output. */
8314 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8315 "it is processed by a defined input/output procedure",
8320 if (ts
->type
== BT_DERIVED
)
8322 /* Check that transferred derived type doesn't contain POINTER
8324 if (ts
->u
.derived
->attr
.pointer_comp
)
8326 gfc_error ("Data transfer element at %L cannot have POINTER "
8327 "components unless it is processed by a defined "
8328 "input/output procedure", &code
->loc
);
8333 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8335 gfc_error ("Data transfer element at %L cannot have "
8336 "procedure pointer components", &code
->loc
);
8340 if (ts
->u
.derived
->attr
.alloc_comp
)
8342 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8343 "components unless it is processed by a defined "
8344 "input/output procedure", &code
->loc
);
8348 if (derived_inaccessible (ts
->u
.derived
))
8350 gfc_error ("Data transfer element at %L cannot have "
8351 "PRIVATE components",&code
->loc
);
8356 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8357 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8359 gfc_error ("Data transfer element at %L cannot be a full reference to "
8360 "an assumed-size array", &code
->loc
);
8366 /*********** Toplevel code resolution subroutines ***********/
8368 /* Find the set of labels that are reachable from this block. We also
8369 record the last statement in each block. */
8372 find_reachable_labels (gfc_code
*block
)
8379 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8381 /* Collect labels in this block. We don't keep those corresponding
8382 to END {IF|SELECT}, these are checked in resolve_branch by going
8383 up through the code_stack. */
8384 for (c
= block
; c
; c
= c
->next
)
8386 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8387 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8390 /* Merge with labels from parent block. */
8393 gcc_assert (cs_base
->prev
->reachable_labels
);
8394 bitmap_ior_into (cs_base
->reachable_labels
,
8395 cs_base
->prev
->reachable_labels
);
8401 resolve_lock_unlock (gfc_code
*code
)
8403 if (code
->expr1
->ts
.type
!= BT_DERIVED
8404 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8405 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8406 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8407 || code
->expr1
->rank
!= 0
8408 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8409 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8410 &code
->expr1
->where
);
8414 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8415 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8416 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8417 &code
->expr2
->where
);
8420 && gfc_check_vardef_context (code
->expr2
, false, false,
8421 _("STAT variable")) == FAILURE
)
8426 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8427 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8428 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8429 &code
->expr3
->where
);
8432 && gfc_check_vardef_context (code
->expr3
, false, false,
8433 _("ERRMSG variable")) == FAILURE
)
8436 /* Check ACQUIRED_LOCK. */
8438 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8439 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8440 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8441 "variable", &code
->expr4
->where
);
8444 && gfc_check_vardef_context (code
->expr4
, false, false,
8445 _("ACQUIRED_LOCK variable")) == FAILURE
)
8451 resolve_sync (gfc_code
*code
)
8453 /* Check imageset. The * case matches expr1 == NULL. */
8456 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8457 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8458 "INTEGER expression", &code
->expr1
->where
);
8459 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8460 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8461 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8462 &code
->expr1
->where
);
8463 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8464 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8466 gfc_constructor
*cons
;
8467 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8468 for (; cons
; cons
= gfc_constructor_next (cons
))
8469 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8470 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8471 gfc_error ("Imageset argument at %L must between 1 and "
8472 "num_images()", &cons
->expr
->where
);
8478 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8479 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8480 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8481 &code
->expr2
->where
);
8485 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8486 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8487 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8488 &code
->expr3
->where
);
8492 /* Given a branch to a label, see if the branch is conforming.
8493 The code node describes where the branch is located. */
8496 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8503 /* Step one: is this a valid branching target? */
8505 if (label
->defined
== ST_LABEL_UNKNOWN
)
8507 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8512 if (label
->defined
!= ST_LABEL_TARGET
)
8514 gfc_error ("Statement at %L is not a valid branch target statement "
8515 "for the branch statement at %L", &label
->where
, &code
->loc
);
8519 /* Step two: make sure this branch is not a branch to itself ;-) */
8521 if (code
->here
== label
)
8523 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8527 /* Step three: See if the label is in the same block as the
8528 branching statement. The hard work has been done by setting up
8529 the bitmap reachable_labels. */
8531 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8533 /* Check now whether there is a CRITICAL construct; if so, check
8534 whether the label is still visible outside of the CRITICAL block,
8535 which is invalid. */
8536 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8538 if (stack
->current
->op
== EXEC_CRITICAL
8539 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8540 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8541 "label at %L", &code
->loc
, &label
->where
);
8542 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8543 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8544 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8545 "for label at %L", &code
->loc
, &label
->where
);
8551 /* Step four: If we haven't found the label in the bitmap, it may
8552 still be the label of the END of the enclosing block, in which
8553 case we find it by going up the code_stack. */
8555 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8557 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8559 if (stack
->current
->op
== EXEC_CRITICAL
)
8561 /* Note: A label at END CRITICAL does not leave the CRITICAL
8562 construct as END CRITICAL is still part of it. */
8563 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8564 " at %L", &code
->loc
, &label
->where
);
8567 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8569 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8570 "label at %L", &code
->loc
, &label
->where
);
8577 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8581 /* The label is not in an enclosing block, so illegal. This was
8582 allowed in Fortran 66, so we allow it as extension. No
8583 further checks are necessary in this case. */
8584 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8585 "as the GOTO statement at %L", &label
->where
,
8591 /* Check whether EXPR1 has the same shape as EXPR2. */
8594 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8596 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8597 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8598 gfc_try result
= FAILURE
;
8601 /* Compare the rank. */
8602 if (expr1
->rank
!= expr2
->rank
)
8605 /* Compare the size of each dimension. */
8606 for (i
=0; i
<expr1
->rank
; i
++)
8608 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8611 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8614 if (mpz_cmp (shape
[i
], shape2
[i
]))
8618 /* When either of the two expression is an assumed size array, we
8619 ignore the comparison of dimension sizes. */
8624 gfc_clear_shape (shape
, i
);
8625 gfc_clear_shape (shape2
, i
);
8630 /* Check whether a WHERE assignment target or a WHERE mask expression
8631 has the same shape as the outmost WHERE mask expression. */
8634 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8640 cblock
= code
->block
;
8642 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8643 In case of nested WHERE, only the outmost one is stored. */
8644 if (mask
== NULL
) /* outmost WHERE */
8646 else /* inner WHERE */
8653 /* Check if the mask-expr has a consistent shape with the
8654 outmost WHERE mask-expr. */
8655 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8656 gfc_error ("WHERE mask at %L has inconsistent shape",
8657 &cblock
->expr1
->where
);
8660 /* the assignment statement of a WHERE statement, or the first
8661 statement in where-body-construct of a WHERE construct */
8662 cnext
= cblock
->next
;
8667 /* WHERE assignment statement */
8670 /* Check shape consistent for WHERE assignment target. */
8671 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8672 gfc_error ("WHERE assignment target at %L has "
8673 "inconsistent shape", &cnext
->expr1
->where
);
8677 case EXEC_ASSIGN_CALL
:
8678 resolve_call (cnext
);
8679 if (!cnext
->resolved_sym
->attr
.elemental
)
8680 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8681 &cnext
->ext
.actual
->expr
->where
);
8684 /* WHERE or WHERE construct is part of a where-body-construct */
8686 resolve_where (cnext
, e
);
8690 gfc_error ("Unsupported statement inside WHERE at %L",
8693 /* the next statement within the same where-body-construct */
8694 cnext
= cnext
->next
;
8696 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8697 cblock
= cblock
->block
;
8702 /* Resolve assignment in FORALL construct.
8703 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8704 FORALL index variables. */
8707 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8711 for (n
= 0; n
< nvar
; n
++)
8713 gfc_symbol
*forall_index
;
8715 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8717 /* Check whether the assignment target is one of the FORALL index
8719 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8720 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8721 gfc_error ("Assignment to a FORALL index variable at %L",
8722 &code
->expr1
->where
);
8725 /* If one of the FORALL index variables doesn't appear in the
8726 assignment variable, then there could be a many-to-one
8727 assignment. Emit a warning rather than an error because the
8728 mask could be resolving this problem. */
8729 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8730 gfc_warning ("The FORALL with index '%s' is not used on the "
8731 "left side of the assignment at %L and so might "
8732 "cause multiple assignment to this object",
8733 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8739 /* Resolve WHERE statement in FORALL construct. */
8742 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8743 gfc_expr
**var_expr
)
8748 cblock
= code
->block
;
8751 /* the assignment statement of a WHERE statement, or the first
8752 statement in where-body-construct of a WHERE construct */
8753 cnext
= cblock
->next
;
8758 /* WHERE assignment statement */
8760 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8763 /* WHERE operator assignment statement */
8764 case EXEC_ASSIGN_CALL
:
8765 resolve_call (cnext
);
8766 if (!cnext
->resolved_sym
->attr
.elemental
)
8767 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8768 &cnext
->ext
.actual
->expr
->where
);
8771 /* WHERE or WHERE construct is part of a where-body-construct */
8773 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8777 gfc_error ("Unsupported statement inside WHERE at %L",
8780 /* the next statement within the same where-body-construct */
8781 cnext
= cnext
->next
;
8783 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8784 cblock
= cblock
->block
;
8789 /* Traverse the FORALL body to check whether the following errors exist:
8790 1. For assignment, check if a many-to-one assignment happens.
8791 2. For WHERE statement, check the WHERE body to see if there is any
8792 many-to-one assignment. */
8795 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8799 c
= code
->block
->next
;
8805 case EXEC_POINTER_ASSIGN
:
8806 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8809 case EXEC_ASSIGN_CALL
:
8813 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8814 there is no need to handle it here. */
8818 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8823 /* The next statement in the FORALL body. */
8829 /* Counts the number of iterators needed inside a forall construct, including
8830 nested forall constructs. This is used to allocate the needed memory
8831 in gfc_resolve_forall. */
8834 gfc_count_forall_iterators (gfc_code
*code
)
8836 int max_iters
, sub_iters
, current_iters
;
8837 gfc_forall_iterator
*fa
;
8839 gcc_assert(code
->op
== EXEC_FORALL
);
8843 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8846 code
= code
->block
->next
;
8850 if (code
->op
== EXEC_FORALL
)
8852 sub_iters
= gfc_count_forall_iterators (code
);
8853 if (sub_iters
> max_iters
)
8854 max_iters
= sub_iters
;
8859 return current_iters
+ max_iters
;
8863 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8864 gfc_resolve_forall_body to resolve the FORALL body. */
8867 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8869 static gfc_expr
**var_expr
;
8870 static int total_var
= 0;
8871 static int nvar
= 0;
8873 gfc_forall_iterator
*fa
;
8878 /* Start to resolve a FORALL construct */
8879 if (forall_save
== 0)
8881 /* Count the total number of FORALL index in the nested FORALL
8882 construct in order to allocate the VAR_EXPR with proper size. */
8883 total_var
= gfc_count_forall_iterators (code
);
8885 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8886 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8889 /* The information about FORALL iterator, including FORALL index start, end
8890 and stride. The FORALL index can not appear in start, end or stride. */
8891 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8893 /* Check if any outer FORALL index name is the same as the current
8895 for (i
= 0; i
< nvar
; i
++)
8897 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8899 gfc_error ("An outer FORALL construct already has an index "
8900 "with this name %L", &fa
->var
->where
);
8904 /* Record the current FORALL index. */
8905 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8909 /* No memory leak. */
8910 gcc_assert (nvar
<= total_var
);
8913 /* Resolve the FORALL body. */
8914 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8916 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8917 gfc_resolve_blocks (code
->block
, ns
);
8921 /* Free only the VAR_EXPRs allocated in this frame. */
8922 for (i
= nvar
; i
< tmp
; i
++)
8923 gfc_free_expr (var_expr
[i
]);
8927 /* We are in the outermost FORALL construct. */
8928 gcc_assert (forall_save
== 0);
8930 /* VAR_EXPR is not needed any more. */
8937 /* Resolve a BLOCK construct statement. */
8940 resolve_block_construct (gfc_code
* code
)
8942 /* Resolve the BLOCK's namespace. */
8943 gfc_resolve (code
->ext
.block
.ns
);
8945 /* For an ASSOCIATE block, the associations (and their targets) are already
8946 resolved during resolve_symbol. */
8950 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8953 static void resolve_code (gfc_code
*, gfc_namespace
*);
8956 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8960 for (; b
; b
= b
->block
)
8962 t
= gfc_resolve_expr (b
->expr1
);
8963 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
8969 if (t
== SUCCESS
&& b
->expr1
!= NULL
8970 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8971 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8978 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8979 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8984 resolve_branch (b
->label1
, b
);
8988 resolve_block_construct (b
);
8992 case EXEC_SELECT_TYPE
:
8996 case EXEC_DO_CONCURRENT
:
9004 case EXEC_OMP_ATOMIC
:
9005 case EXEC_OMP_CRITICAL
:
9007 case EXEC_OMP_MASTER
:
9008 case EXEC_OMP_ORDERED
:
9009 case EXEC_OMP_PARALLEL
:
9010 case EXEC_OMP_PARALLEL_DO
:
9011 case EXEC_OMP_PARALLEL_SECTIONS
:
9012 case EXEC_OMP_PARALLEL_WORKSHARE
:
9013 case EXEC_OMP_SECTIONS
:
9014 case EXEC_OMP_SINGLE
:
9016 case EXEC_OMP_TASKWAIT
:
9017 case EXEC_OMP_TASKYIELD
:
9018 case EXEC_OMP_WORKSHARE
:
9022 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9025 resolve_code (b
->next
, ns
);
9030 /* Does everything to resolve an ordinary assignment. Returns true
9031 if this is an interface assignment. */
9033 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9043 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9047 if (code
->op
== EXEC_ASSIGN_CALL
)
9049 lhs
= code
->ext
.actual
->expr
;
9050 rhsptr
= &code
->ext
.actual
->next
->expr
;
9054 gfc_actual_arglist
* args
;
9055 gfc_typebound_proc
* tbp
;
9057 gcc_assert (code
->op
== EXEC_COMPCALL
);
9059 args
= code
->expr1
->value
.compcall
.actual
;
9061 rhsptr
= &args
->next
->expr
;
9063 tbp
= code
->expr1
->value
.compcall
.tbp
;
9064 gcc_assert (!tbp
->is_generic
);
9067 /* Make a temporary rhs when there is a default initializer
9068 and rhs is the same symbol as the lhs. */
9069 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9070 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9071 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9072 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9073 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9082 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
9083 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9084 &code
->loc
) == FAILURE
)
9087 /* Handle the case of a BOZ literal on the RHS. */
9088 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9091 if (gfc_option
.warn_surprising
)
9092 gfc_warning ("BOZ literal at %L is bitwise transferred "
9093 "non-integer symbol '%s'", &code
->loc
,
9094 lhs
->symtree
->n
.sym
->name
);
9096 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9098 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9100 if (rc
== ARITH_UNDERFLOW
)
9101 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9102 ". This check can be disabled with the option "
9103 "-fno-range-check", &rhs
->where
);
9104 else if (rc
== ARITH_OVERFLOW
)
9105 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9106 ". This check can be disabled with the option "
9107 "-fno-range-check", &rhs
->where
);
9108 else if (rc
== ARITH_NAN
)
9109 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9110 ". This check can be disabled with the option "
9111 "-fno-range-check", &rhs
->where
);
9116 if (lhs
->ts
.type
== BT_CHARACTER
9117 && gfc_option
.warn_character_truncation
)
9119 if (lhs
->ts
.u
.cl
!= NULL
9120 && lhs
->ts
.u
.cl
->length
!= NULL
9121 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9122 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9124 if (rhs
->expr_type
== EXPR_CONSTANT
)
9125 rlen
= rhs
->value
.character
.length
;
9127 else if (rhs
->ts
.u
.cl
!= NULL
9128 && rhs
->ts
.u
.cl
->length
!= NULL
9129 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9130 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9132 if (rlen
&& llen
&& rlen
> llen
)
9133 gfc_warning_now ("CHARACTER expression will be truncated "
9134 "in assignment (%d/%d) at %L",
9135 llen
, rlen
, &code
->loc
);
9138 /* Ensure that a vector index expression for the lvalue is evaluated
9139 to a temporary if the lvalue symbol is referenced in it. */
9142 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9143 if (ref
->type
== REF_ARRAY
)
9145 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9146 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9147 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9148 ref
->u
.ar
.start
[n
]))
9150 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9154 if (gfc_pure (NULL
))
9156 if (lhs
->ts
.type
== BT_DERIVED
9157 && lhs
->expr_type
== EXPR_VARIABLE
9158 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9159 && rhs
->expr_type
== EXPR_VARIABLE
9160 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9161 || gfc_is_coindexed (rhs
)))
9164 if (gfc_is_coindexed (rhs
))
9165 gfc_error ("Coindexed expression at %L is assigned to "
9166 "a derived type variable with a POINTER "
9167 "component in a PURE procedure",
9170 gfc_error ("The impure variable at %L is assigned to "
9171 "a derived type variable with a POINTER "
9172 "component in a PURE procedure (12.6)",
9177 /* Fortran 2008, C1283. */
9178 if (gfc_is_coindexed (lhs
))
9180 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9181 "procedure", &rhs
->where
);
9186 if (gfc_implicit_pure (NULL
))
9188 if (lhs
->expr_type
== EXPR_VARIABLE
9189 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9190 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9191 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9193 if (lhs
->ts
.type
== BT_DERIVED
9194 && lhs
->expr_type
== EXPR_VARIABLE
9195 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9196 && rhs
->expr_type
== EXPR_VARIABLE
9197 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9198 || gfc_is_coindexed (rhs
)))
9199 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9201 /* Fortran 2008, C1283. */
9202 if (gfc_is_coindexed (lhs
))
9203 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9207 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9208 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9209 if (lhs
->ts
.type
== BT_CLASS
)
9211 gfc_error ("Variable must not be polymorphic in assignment at %L "
9212 "- check that there is a matching specific subroutine "
9213 "for '=' operator", &lhs
->where
);
9217 /* F2008, Section 7.2.1.2. */
9218 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9220 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9221 "component in assignment at %L", &lhs
->where
);
9225 gfc_check_assign (lhs
, rhs
, 1);
9230 /* Given a block of code, recursively resolve everything pointed to by this
9234 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9236 int omp_workshare_save
;
9237 int forall_save
, do_concurrent_save
;
9241 frame
.prev
= cs_base
;
9245 find_reachable_labels (code
);
9247 for (; code
; code
= code
->next
)
9249 frame
.current
= code
;
9250 forall_save
= forall_flag
;
9251 do_concurrent_save
= do_concurrent_flag
;
9253 if (code
->op
== EXEC_FORALL
)
9256 gfc_resolve_forall (code
, ns
, forall_save
);
9259 else if (code
->block
)
9261 omp_workshare_save
= -1;
9264 case EXEC_OMP_PARALLEL_WORKSHARE
:
9265 omp_workshare_save
= omp_workshare_flag
;
9266 omp_workshare_flag
= 1;
9267 gfc_resolve_omp_parallel_blocks (code
, ns
);
9269 case EXEC_OMP_PARALLEL
:
9270 case EXEC_OMP_PARALLEL_DO
:
9271 case EXEC_OMP_PARALLEL_SECTIONS
:
9273 omp_workshare_save
= omp_workshare_flag
;
9274 omp_workshare_flag
= 0;
9275 gfc_resolve_omp_parallel_blocks (code
, ns
);
9278 gfc_resolve_omp_do_blocks (code
, ns
);
9280 case EXEC_SELECT_TYPE
:
9281 /* Blocks are handled in resolve_select_type because we have
9282 to transform the SELECT TYPE into ASSOCIATE first. */
9284 case EXEC_DO_CONCURRENT
:
9285 do_concurrent_flag
= 1;
9286 gfc_resolve_blocks (code
->block
, ns
);
9287 do_concurrent_flag
= 2;
9289 case EXEC_OMP_WORKSHARE
:
9290 omp_workshare_save
= omp_workshare_flag
;
9291 omp_workshare_flag
= 1;
9294 gfc_resolve_blocks (code
->block
, ns
);
9298 if (omp_workshare_save
!= -1)
9299 omp_workshare_flag
= omp_workshare_save
;
9303 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9304 t
= gfc_resolve_expr (code
->expr1
);
9305 forall_flag
= forall_save
;
9306 do_concurrent_flag
= do_concurrent_save
;
9308 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9311 if (code
->op
== EXEC_ALLOCATE
9312 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9318 case EXEC_END_BLOCK
:
9319 case EXEC_END_NESTED_BLOCK
:
9323 case EXEC_ERROR_STOP
:
9327 case EXEC_ASSIGN_CALL
:
9332 case EXEC_SYNC_IMAGES
:
9333 case EXEC_SYNC_MEMORY
:
9334 resolve_sync (code
);
9339 resolve_lock_unlock (code
);
9343 /* Keep track of which entry we are up to. */
9344 current_entry_id
= code
->ext
.entry
->id
;
9348 resolve_where (code
, NULL
);
9352 if (code
->expr1
!= NULL
)
9354 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9355 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9356 "INTEGER variable", &code
->expr1
->where
);
9357 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9358 gfc_error ("Variable '%s' has not been assigned a target "
9359 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9360 &code
->expr1
->where
);
9363 resolve_branch (code
->label1
, code
);
9367 if (code
->expr1
!= NULL
9368 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9369 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9370 "INTEGER return specifier", &code
->expr1
->where
);
9373 case EXEC_INIT_ASSIGN
:
9374 case EXEC_END_PROCEDURE
:
9381 if (gfc_check_vardef_context (code
->expr1
, false, false,
9382 _("assignment")) == FAILURE
)
9385 if (resolve_ordinary_assign (code
, ns
))
9387 if (code
->op
== EXEC_COMPCALL
)
9394 case EXEC_LABEL_ASSIGN
:
9395 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9396 gfc_error ("Label %d referenced at %L is never defined",
9397 code
->label1
->value
, &code
->label1
->where
);
9399 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9400 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9401 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9402 != gfc_default_integer_kind
9403 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9404 gfc_error ("ASSIGN statement at %L requires a scalar "
9405 "default INTEGER variable", &code
->expr1
->where
);
9408 case EXEC_POINTER_ASSIGN
:
9415 /* This is both a variable definition and pointer assignment
9416 context, so check both of them. For rank remapping, a final
9417 array ref may be present on the LHS and fool gfc_expr_attr
9418 used in gfc_check_vardef_context. Remove it. */
9419 e
= remove_last_array_ref (code
->expr1
);
9420 t
= gfc_check_vardef_context (e
, true, false,
9421 _("pointer assignment"));
9423 t
= gfc_check_vardef_context (e
, false, false,
9424 _("pointer assignment"));
9429 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9433 case EXEC_ARITHMETIC_IF
:
9435 && code
->expr1
->ts
.type
!= BT_INTEGER
9436 && code
->expr1
->ts
.type
!= BT_REAL
)
9437 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9438 "expression", &code
->expr1
->where
);
9440 resolve_branch (code
->label1
, code
);
9441 resolve_branch (code
->label2
, code
);
9442 resolve_branch (code
->label3
, code
);
9446 if (t
== SUCCESS
&& code
->expr1
!= NULL
9447 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9448 || code
->expr1
->rank
!= 0))
9449 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9450 &code
->expr1
->where
);
9455 resolve_call (code
);
9460 resolve_typebound_subroutine (code
);
9464 resolve_ppc_call (code
);
9468 /* Select is complicated. Also, a SELECT construct could be
9469 a transformed computed GOTO. */
9470 resolve_select (code
);
9473 case EXEC_SELECT_TYPE
:
9474 resolve_select_type (code
, ns
);
9478 resolve_block_construct (code
);
9482 if (code
->ext
.iterator
!= NULL
)
9484 gfc_iterator
*iter
= code
->ext
.iterator
;
9485 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9486 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9491 if (code
->expr1
== NULL
)
9492 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9494 && (code
->expr1
->rank
!= 0
9495 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9496 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9497 "a scalar LOGICAL expression", &code
->expr1
->where
);
9502 resolve_allocate_deallocate (code
, "ALLOCATE");
9506 case EXEC_DEALLOCATE
:
9508 resolve_allocate_deallocate (code
, "DEALLOCATE");
9513 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9516 resolve_branch (code
->ext
.open
->err
, code
);
9520 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9523 resolve_branch (code
->ext
.close
->err
, code
);
9526 case EXEC_BACKSPACE
:
9530 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9533 resolve_branch (code
->ext
.filepos
->err
, code
);
9537 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9540 resolve_branch (code
->ext
.inquire
->err
, code
);
9544 gcc_assert (code
->ext
.inquire
!= NULL
);
9545 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9548 resolve_branch (code
->ext
.inquire
->err
, code
);
9552 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9555 resolve_branch (code
->ext
.wait
->err
, code
);
9556 resolve_branch (code
->ext
.wait
->end
, code
);
9557 resolve_branch (code
->ext
.wait
->eor
, code
);
9562 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9565 resolve_branch (code
->ext
.dt
->err
, code
);
9566 resolve_branch (code
->ext
.dt
->end
, code
);
9567 resolve_branch (code
->ext
.dt
->eor
, code
);
9571 resolve_transfer (code
);
9574 case EXEC_DO_CONCURRENT
:
9576 resolve_forall_iterators (code
->ext
.forall_iterator
);
9578 if (code
->expr1
!= NULL
9579 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9580 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9581 "expression", &code
->expr1
->where
);
9584 case EXEC_OMP_ATOMIC
:
9585 case EXEC_OMP_BARRIER
:
9586 case EXEC_OMP_CRITICAL
:
9587 case EXEC_OMP_FLUSH
:
9589 case EXEC_OMP_MASTER
:
9590 case EXEC_OMP_ORDERED
:
9591 case EXEC_OMP_SECTIONS
:
9592 case EXEC_OMP_SINGLE
:
9593 case EXEC_OMP_TASKWAIT
:
9594 case EXEC_OMP_TASKYIELD
:
9595 case EXEC_OMP_WORKSHARE
:
9596 gfc_resolve_omp_directive (code
, ns
);
9599 case EXEC_OMP_PARALLEL
:
9600 case EXEC_OMP_PARALLEL_DO
:
9601 case EXEC_OMP_PARALLEL_SECTIONS
:
9602 case EXEC_OMP_PARALLEL_WORKSHARE
:
9604 omp_workshare_save
= omp_workshare_flag
;
9605 omp_workshare_flag
= 0;
9606 gfc_resolve_omp_directive (code
, ns
);
9607 omp_workshare_flag
= omp_workshare_save
;
9611 gfc_internal_error ("resolve_code(): Bad statement code");
9615 cs_base
= frame
.prev
;
9619 /* Resolve initial values and make sure they are compatible with
9623 resolve_values (gfc_symbol
*sym
)
9627 if (sym
->value
== NULL
|| sym
->attr
.use_assoc
)
9630 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9631 t
= resolve_structure_cons (sym
->value
, 1);
9633 t
= gfc_resolve_expr (sym
->value
);
9638 gfc_check_assign_symbol (sym
, sym
->value
);
9642 /* Verify the binding labels for common blocks that are BIND(C). The label
9643 for a BIND(C) common block must be identical in all scoping units in which
9644 the common block is declared. Further, the binding label can not collide
9645 with any other global entity in the program. */
9648 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9650 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9652 gfc_gsymbol
*binding_label_gsym
;
9653 gfc_gsymbol
*comm_name_gsym
;
9655 /* See if a global symbol exists by the common block's name. It may
9656 be NULL if the common block is use-associated. */
9657 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9658 comm_block_tree
->n
.common
->name
);
9659 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9660 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9661 "with the global entity '%s' at %L",
9662 comm_block_tree
->n
.common
->binding_label
,
9663 comm_block_tree
->n
.common
->name
,
9664 &(comm_block_tree
->n
.common
->where
),
9665 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9666 else if (comm_name_gsym
!= NULL
9667 && strcmp (comm_name_gsym
->name
,
9668 comm_block_tree
->n
.common
->name
) == 0)
9670 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9672 if (comm_name_gsym
->binding_label
== NULL
)
9673 /* No binding label for common block stored yet; save this one. */
9674 comm_name_gsym
->binding_label
=
9675 comm_block_tree
->n
.common
->binding_label
;
9677 if (strcmp (comm_name_gsym
->binding_label
,
9678 comm_block_tree
->n
.common
->binding_label
) != 0)
9680 /* Common block names match but binding labels do not. */
9681 gfc_error ("Binding label '%s' for common block '%s' at %L "
9682 "does not match the binding label '%s' for common "
9684 comm_block_tree
->n
.common
->binding_label
,
9685 comm_block_tree
->n
.common
->name
,
9686 &(comm_block_tree
->n
.common
->where
),
9687 comm_name_gsym
->binding_label
,
9688 comm_name_gsym
->name
,
9689 &(comm_name_gsym
->where
));
9694 /* There is no binding label (NAME="") so we have nothing further to
9695 check and nothing to add as a global symbol for the label. */
9696 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
9699 binding_label_gsym
=
9700 gfc_find_gsymbol (gfc_gsym_root
,
9701 comm_block_tree
->n
.common
->binding_label
);
9702 if (binding_label_gsym
== NULL
)
9704 /* Need to make a global symbol for the binding label to prevent
9705 it from colliding with another. */
9706 binding_label_gsym
=
9707 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9708 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9709 binding_label_gsym
->type
= GSYM_COMMON
;
9713 /* If comm_name_gsym is NULL, the name common block is use
9714 associated and the name could be colliding. */
9715 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9716 gfc_error ("Binding label '%s' for common block '%s' at %L "
9717 "collides with the global entity '%s' at %L",
9718 comm_block_tree
->n
.common
->binding_label
,
9719 comm_block_tree
->n
.common
->name
,
9720 &(comm_block_tree
->n
.common
->where
),
9721 binding_label_gsym
->name
,
9722 &(binding_label_gsym
->where
));
9723 else if (comm_name_gsym
!= NULL
9724 && (strcmp (binding_label_gsym
->name
,
9725 comm_name_gsym
->binding_label
) != 0)
9726 && (strcmp (binding_label_gsym
->sym_name
,
9727 comm_name_gsym
->name
) != 0))
9728 gfc_error ("Binding label '%s' for common block '%s' at %L "
9729 "collides with global entity '%s' at %L",
9730 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9731 &(comm_block_tree
->n
.common
->where
),
9732 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9740 /* Verify any BIND(C) derived types in the namespace so we can report errors
9741 for them once, rather than for each variable declared of that type. */
9744 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9746 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9747 && derived_sym
->attr
.is_bind_c
== 1)
9748 verify_bind_c_derived_type (derived_sym
);
9754 /* Verify that any binding labels used in a given namespace do not collide
9755 with the names or binding labels of any global symbols. */
9758 gfc_verify_binding_labels (gfc_symbol
*sym
)
9762 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9763 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
9765 gfc_gsymbol
*bind_c_sym
;
9767 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9768 if (bind_c_sym
!= NULL
9769 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9771 if (sym
->attr
.if_source
== IFSRC_DECL
9772 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9773 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9774 && ((sym
->attr
.contained
== 1
9775 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9776 || (sym
->attr
.use_assoc
== 1
9777 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9779 /* Make sure global procedures don't collide with anything. */
9780 gfc_error ("Binding label '%s' at %L collides with the global "
9781 "entity '%s' at %L", sym
->binding_label
,
9782 &(sym
->declared_at
), bind_c_sym
->name
,
9783 &(bind_c_sym
->where
));
9786 else if (sym
->attr
.contained
== 0
9787 && (sym
->attr
.if_source
== IFSRC_IFBODY
9788 && sym
->attr
.flavor
== FL_PROCEDURE
)
9789 && (bind_c_sym
->sym_name
!= NULL
9790 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9792 /* Make sure procedures in interface bodies don't collide. */
9793 gfc_error ("Binding label '%s' in interface body at %L collides "
9794 "with the global entity '%s' at %L",
9796 &(sym
->declared_at
), bind_c_sym
->name
,
9797 &(bind_c_sym
->where
));
9800 else if (sym
->attr
.contained
== 0
9801 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9802 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9803 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9804 || sym
->attr
.use_assoc
== 0)
9806 gfc_error ("Binding label '%s' at %L collides with global "
9807 "entity '%s' at %L", sym
->binding_label
,
9808 &(sym
->declared_at
), bind_c_sym
->name
,
9809 &(bind_c_sym
->where
));
9814 /* Clear the binding label to prevent checking multiple times. */
9815 sym
->binding_label
[0] = '\0';
9817 else if (bind_c_sym
== NULL
)
9819 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9820 bind_c_sym
->where
= sym
->declared_at
;
9821 bind_c_sym
->sym_name
= sym
->name
;
9823 if (sym
->attr
.use_assoc
== 1)
9824 bind_c_sym
->mod_name
= sym
->module
;
9826 if (sym
->ns
->proc_name
!= NULL
)
9827 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9829 if (sym
->attr
.contained
== 0)
9831 if (sym
->attr
.subroutine
)
9832 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9833 else if (sym
->attr
.function
)
9834 bind_c_sym
->type
= GSYM_FUNCTION
;
9842 /* Resolve an index expression. */
9845 resolve_index_expr (gfc_expr
*e
)
9847 if (gfc_resolve_expr (e
) == FAILURE
)
9850 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9853 if (gfc_specification_expr (e
) == FAILURE
)
9860 /* Resolve a charlen structure. */
9863 resolve_charlen (gfc_charlen
*cl
)
9872 specification_expr
= 1;
9874 if (resolve_index_expr (cl
->length
) == FAILURE
)
9876 specification_expr
= 0;
9880 /* "If the character length parameter value evaluates to a negative
9881 value, the length of character entities declared is zero." */
9882 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9884 if (gfc_option
.warn_surprising
)
9885 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9886 " the length has been set to zero",
9887 &cl
->length
->where
, i
);
9888 gfc_replace_expr (cl
->length
,
9889 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9892 /* Check that the character length is not too large. */
9893 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9894 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9895 && cl
->length
->ts
.type
== BT_INTEGER
9896 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9898 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9906 /* Test for non-constant shape arrays. */
9909 is_non_constant_shape_array (gfc_symbol
*sym
)
9915 not_constant
= false;
9916 if (sym
->as
!= NULL
)
9918 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9919 has not been simplified; parameter array references. Do the
9920 simplification now. */
9921 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
9923 e
= sym
->as
->lower
[i
];
9924 if (e
&& (resolve_index_expr (e
) == FAILURE
9925 || !gfc_is_constant_expr (e
)))
9926 not_constant
= true;
9927 e
= sym
->as
->upper
[i
];
9928 if (e
&& (resolve_index_expr (e
) == FAILURE
9929 || !gfc_is_constant_expr (e
)))
9930 not_constant
= true;
9933 return not_constant
;
9936 /* Given a symbol and an initialization expression, add code to initialize
9937 the symbol to the function entry. */
9939 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
9943 gfc_namespace
*ns
= sym
->ns
;
9945 /* Search for the function namespace if this is a contained
9946 function without an explicit result. */
9947 if (sym
->attr
.function
&& sym
== sym
->result
9948 && sym
->name
!= sym
->ns
->proc_name
->name
)
9951 for (;ns
; ns
= ns
->sibling
)
9952 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
9958 gfc_free_expr (init
);
9962 /* Build an l-value expression for the result. */
9963 lval
= gfc_lval_expr_from_sym (sym
);
9965 /* Add the code at scope entry. */
9966 init_st
= gfc_get_code ();
9967 init_st
->next
= ns
->code
;
9970 /* Assign the default initializer to the l-value. */
9971 init_st
->loc
= sym
->declared_at
;
9972 init_st
->op
= EXEC_INIT_ASSIGN
;
9973 init_st
->expr1
= lval
;
9974 init_st
->expr2
= init
;
9977 /* Assign the default initializer to a derived type variable or result. */
9980 apply_default_init (gfc_symbol
*sym
)
9982 gfc_expr
*init
= NULL
;
9984 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9987 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
9988 init
= gfc_default_initializer (&sym
->ts
);
9990 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
9993 build_init_assign (sym
, init
);
9994 sym
->attr
.referenced
= 1;
9997 /* Build an initializer for a local integer, real, complex, logical, or
9998 character variable, based on the command line flags finit-local-zero,
9999 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10000 null if the symbol should not have a default initialization. */
10002 build_default_init_expr (gfc_symbol
*sym
)
10005 gfc_expr
*init_expr
;
10008 /* These symbols should never have a default initialization. */
10009 if (sym
->attr
.allocatable
10010 || sym
->attr
.external
10012 || sym
->attr
.pointer
10013 || sym
->attr
.in_equivalence
10014 || sym
->attr
.in_common
10017 || sym
->attr
.cray_pointee
10018 || sym
->attr
.cray_pointer
)
10021 /* Now we'll try to build an initializer expression. */
10022 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10023 &sym
->declared_at
);
10025 /* We will only initialize integers, reals, complex, logicals, and
10026 characters, and only if the corresponding command-line flags
10027 were set. Otherwise, we free init_expr and return null. */
10028 switch (sym
->ts
.type
)
10031 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10032 mpz_set_si (init_expr
->value
.integer
,
10033 gfc_option
.flag_init_integer_value
);
10036 gfc_free_expr (init_expr
);
10042 switch (gfc_option
.flag_init_real
)
10044 case GFC_INIT_REAL_SNAN
:
10045 init_expr
->is_snan
= 1;
10046 /* Fall through. */
10047 case GFC_INIT_REAL_NAN
:
10048 mpfr_set_nan (init_expr
->value
.real
);
10051 case GFC_INIT_REAL_INF
:
10052 mpfr_set_inf (init_expr
->value
.real
, 1);
10055 case GFC_INIT_REAL_NEG_INF
:
10056 mpfr_set_inf (init_expr
->value
.real
, -1);
10059 case GFC_INIT_REAL_ZERO
:
10060 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10064 gfc_free_expr (init_expr
);
10071 switch (gfc_option
.flag_init_real
)
10073 case GFC_INIT_REAL_SNAN
:
10074 init_expr
->is_snan
= 1;
10075 /* Fall through. */
10076 case GFC_INIT_REAL_NAN
:
10077 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10078 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10081 case GFC_INIT_REAL_INF
:
10082 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10083 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10086 case GFC_INIT_REAL_NEG_INF
:
10087 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10088 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10091 case GFC_INIT_REAL_ZERO
:
10092 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10096 gfc_free_expr (init_expr
);
10103 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10104 init_expr
->value
.logical
= 0;
10105 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10106 init_expr
->value
.logical
= 1;
10109 gfc_free_expr (init_expr
);
10115 /* For characters, the length must be constant in order to
10116 create a default initializer. */
10117 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10118 && sym
->ts
.u
.cl
->length
10119 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10121 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10122 init_expr
->value
.character
.length
= char_len
;
10123 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10124 for (i
= 0; i
< char_len
; i
++)
10125 init_expr
->value
.character
.string
[i
]
10126 = (unsigned char) gfc_option
.flag_init_character_value
;
10130 gfc_free_expr (init_expr
);
10136 gfc_free_expr (init_expr
);
10142 /* Add an initialization expression to a local variable. */
10144 apply_default_init_local (gfc_symbol
*sym
)
10146 gfc_expr
*init
= NULL
;
10148 /* The symbol should be a variable or a function return value. */
10149 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10150 || (sym
->attr
.function
&& sym
->result
!= sym
))
10153 /* Try to build the initializer expression. If we can't initialize
10154 this symbol, then init will be NULL. */
10155 init
= build_default_init_expr (sym
);
10159 /* For saved variables, we don't want to add an initializer at
10160 function entry, so we just add a static initializer. */
10161 if (sym
->attr
.save
|| sym
->ns
->save_all
10162 || gfc_option
.flag_max_stack_var_size
== 0)
10164 /* Don't clobber an existing initializer! */
10165 gcc_assert (sym
->value
== NULL
);
10170 build_init_assign (sym
, init
);
10174 /* Resolution of common features of flavors variable and procedure. */
10177 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10179 gfc_array_spec
*as
;
10181 /* Avoid double diagnostics for function result symbols. */
10182 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10183 && (sym
->ns
!= gfc_current_ns
))
10186 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10187 as
= CLASS_DATA (sym
)->as
;
10191 /* Constraints on deferred shape variable. */
10192 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10194 bool pointer
, allocatable
, dimension
;
10196 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10198 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10199 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10200 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10204 pointer
= sym
->attr
.pointer
;
10205 allocatable
= sym
->attr
.allocatable
;
10206 dimension
= sym
->attr
.dimension
;
10213 gfc_error ("Allocatable array '%s' at %L must have "
10214 "a deferred shape", sym
->name
, &sym
->declared_at
);
10217 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
10218 "may not be ALLOCATABLE", sym
->name
,
10219 &sym
->declared_at
) == FAILURE
)
10223 if (pointer
&& dimension
)
10225 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10226 sym
->name
, &sym
->declared_at
);
10232 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10233 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10235 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10236 sym
->name
, &sym
->declared_at
);
10241 /* Constraints on polymorphic variables. */
10242 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10245 if (sym
->attr
.class_ok
10246 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10248 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10249 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10250 &sym
->declared_at
);
10255 /* Assume that use associated symbols were checked in the module ns.
10256 Class-variables that are associate-names are also something special
10257 and excepted from the test. */
10258 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10260 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10261 "or pointer", sym
->name
, &sym
->declared_at
);
10270 /* Additional checks for symbols with flavor variable and derived
10271 type. To be called from resolve_fl_variable. */
10274 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10276 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10278 /* Check to see if a derived type is blocked from being host
10279 associated by the presence of another class I symbol in the same
10280 namespace. 14.6.1.3 of the standard and the discussion on
10281 comp.lang.fortran. */
10282 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10283 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10286 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10287 if (s
&& s
->attr
.generic
)
10288 s
= gfc_find_dt_in_generic (s
);
10289 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10291 gfc_error ("The type '%s' cannot be host associated at %L "
10292 "because it is blocked by an incompatible object "
10293 "of the same name declared at %L",
10294 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10300 /* 4th constraint in section 11.3: "If an object of a type for which
10301 component-initialization is specified (R429) appears in the
10302 specification-part of a module and does not have the ALLOCATABLE
10303 or POINTER attribute, the object shall have the SAVE attribute."
10305 The check for initializers is performed with
10306 gfc_has_default_initializer because gfc_default_initializer generates
10307 a hidden default for allocatable components. */
10308 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10309 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10310 && !sym
->ns
->save_all
&& !sym
->attr
.save
10311 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10312 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10313 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
10314 "module variable '%s' at %L, needed due to "
10315 "the default initialization", sym
->name
,
10316 &sym
->declared_at
) == FAILURE
)
10319 /* Assign default initializer. */
10320 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10321 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10323 sym
->value
= gfc_default_initializer (&sym
->ts
);
10330 /* Resolve symbols with flavor variable. */
10333 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10335 int no_init_flag
, automatic_flag
;
10337 const char *auto_save_msg
;
10339 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10342 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10345 /* Set this flag to check that variables are parameters of all entries.
10346 This check is effected by the call to gfc_resolve_expr through
10347 is_non_constant_shape_array. */
10348 specification_expr
= 1;
10350 if (sym
->ns
->proc_name
10351 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10352 || sym
->ns
->proc_name
->attr
.is_main_program
)
10353 && !sym
->attr
.use_assoc
10354 && !sym
->attr
.allocatable
10355 && !sym
->attr
.pointer
10356 && is_non_constant_shape_array (sym
))
10358 /* The shape of a main program or module array needs to be
10360 gfc_error ("The module or main program array '%s' at %L must "
10361 "have constant shape", sym
->name
, &sym
->declared_at
);
10362 specification_expr
= 0;
10366 /* Constraints on deferred type parameter. */
10367 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10369 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10370 "requires either the pointer or allocatable attribute",
10371 sym
->name
, &sym
->declared_at
);
10375 if (sym
->ts
.type
== BT_CHARACTER
)
10377 /* Make sure that character string variables with assumed length are
10378 dummy arguments. */
10379 e
= sym
->ts
.u
.cl
->length
;
10380 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10381 && !sym
->ts
.deferred
)
10383 gfc_error ("Entity with assumed character length at %L must be a "
10384 "dummy argument or a PARAMETER", &sym
->declared_at
);
10388 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10390 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10394 if (!gfc_is_constant_expr (e
)
10395 && !(e
->expr_type
== EXPR_VARIABLE
10396 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10398 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10399 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10400 || sym
->ns
->proc_name
->attr
.is_main_program
))
10402 gfc_error ("'%s' at %L must have constant character length "
10403 "in this context", sym
->name
, &sym
->declared_at
);
10406 if (sym
->attr
.in_common
)
10408 gfc_error ("COMMON variable '%s' at %L must have constant "
10409 "character length", sym
->name
, &sym
->declared_at
);
10415 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10416 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10418 /* Determine if the symbol may not have an initializer. */
10419 no_init_flag
= automatic_flag
= 0;
10420 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10421 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10423 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10424 && is_non_constant_shape_array (sym
))
10426 no_init_flag
= automatic_flag
= 1;
10428 /* Also, they must not have the SAVE attribute.
10429 SAVE_IMPLICIT is checked below. */
10430 if (sym
->as
&& sym
->attr
.codimension
)
10432 int corank
= sym
->as
->corank
;
10433 sym
->as
->corank
= 0;
10434 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10435 sym
->as
->corank
= corank
;
10437 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10439 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10444 /* Ensure that any initializer is simplified. */
10446 gfc_simplify_expr (sym
->value
, 1);
10448 /* Reject illegal initializers. */
10449 if (!sym
->mark
&& sym
->value
)
10451 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10452 && CLASS_DATA (sym
)->attr
.allocatable
))
10453 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10454 sym
->name
, &sym
->declared_at
);
10455 else if (sym
->attr
.external
)
10456 gfc_error ("External '%s' at %L cannot have an initializer",
10457 sym
->name
, &sym
->declared_at
);
10458 else if (sym
->attr
.dummy
10459 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10460 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10461 sym
->name
, &sym
->declared_at
);
10462 else if (sym
->attr
.intrinsic
)
10463 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10464 sym
->name
, &sym
->declared_at
);
10465 else if (sym
->attr
.result
)
10466 gfc_error ("Function result '%s' at %L cannot have an initializer",
10467 sym
->name
, &sym
->declared_at
);
10468 else if (automatic_flag
)
10469 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10470 sym
->name
, &sym
->declared_at
);
10472 goto no_init_error
;
10477 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10478 return resolve_fl_variable_derived (sym
, no_init_flag
);
10484 /* Resolve a procedure. */
10487 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10489 gfc_formal_arglist
*arg
;
10491 if (sym
->attr
.function
10492 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10495 if (sym
->ts
.type
== BT_CHARACTER
)
10497 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10499 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10500 && resolve_charlen (cl
) == FAILURE
)
10503 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10504 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10506 gfc_error ("Character-valued statement function '%s' at %L must "
10507 "have constant length", sym
->name
, &sym
->declared_at
);
10512 /* Ensure that derived type for are not of a private type. Internal
10513 module procedures are excluded by 2.2.3.3 - i.e., they are not
10514 externally accessible and can access all the objects accessible in
10516 if (!(sym
->ns
->parent
10517 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10518 && gfc_check_symbol_access (sym
))
10520 gfc_interface
*iface
;
10522 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10525 && arg
->sym
->ts
.type
== BT_DERIVED
10526 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10527 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10528 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10529 "PRIVATE type and cannot be a dummy argument"
10530 " of '%s', which is PUBLIC at %L",
10531 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10534 /* Stop this message from recurring. */
10535 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10540 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10541 PRIVATE to the containing module. */
10542 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10544 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10547 && arg
->sym
->ts
.type
== BT_DERIVED
10548 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10549 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10550 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10551 "'%s' in PUBLIC interface '%s' at %L "
10552 "takes dummy arguments of '%s' which is "
10553 "PRIVATE", iface
->sym
->name
, sym
->name
,
10554 &iface
->sym
->declared_at
,
10555 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10557 /* Stop this message from recurring. */
10558 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10564 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10565 PRIVATE to the containing module. */
10566 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10568 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10571 && arg
->sym
->ts
.type
== BT_DERIVED
10572 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10573 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10574 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10575 "'%s' in PUBLIC interface '%s' at %L "
10576 "takes dummy arguments of '%s' which is "
10577 "PRIVATE", iface
->sym
->name
, sym
->name
,
10578 &iface
->sym
->declared_at
,
10579 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10581 /* Stop this message from recurring. */
10582 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10589 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10590 && !sym
->attr
.proc_pointer
)
10592 gfc_error ("Function '%s' at %L cannot have an initializer",
10593 sym
->name
, &sym
->declared_at
);
10597 /* An external symbol may not have an initializer because it is taken to be
10598 a procedure. Exception: Procedure Pointers. */
10599 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10601 gfc_error ("External object '%s' at %L may not have an initializer",
10602 sym
->name
, &sym
->declared_at
);
10606 /* An elemental function is required to return a scalar 12.7.1 */
10607 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10609 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10610 "result", sym
->name
, &sym
->declared_at
);
10611 /* Reset so that the error only occurs once. */
10612 sym
->attr
.elemental
= 0;
10616 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10617 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10619 gfc_error ("Statement function '%s' at %L may not have pointer or "
10620 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10624 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10625 char-len-param shall not be array-valued, pointer-valued, recursive
10626 or pure. ....snip... A character value of * may only be used in the
10627 following ways: (i) Dummy arg of procedure - dummy associates with
10628 actual length; (ii) To declare a named constant; or (iii) External
10629 function - but length must be declared in calling scoping unit. */
10630 if (sym
->attr
.function
10631 && sym
->ts
.type
== BT_CHARACTER
10632 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10634 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10635 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10637 if (sym
->as
&& sym
->as
->rank
)
10638 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10639 "array-valued", sym
->name
, &sym
->declared_at
);
10641 if (sym
->attr
.pointer
)
10642 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10643 "pointer-valued", sym
->name
, &sym
->declared_at
);
10645 if (sym
->attr
.pure
)
10646 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10647 "pure", sym
->name
, &sym
->declared_at
);
10649 if (sym
->attr
.recursive
)
10650 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10651 "recursive", sym
->name
, &sym
->declared_at
);
10656 /* Appendix B.2 of the standard. Contained functions give an
10657 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10658 character length is an F2003 feature. */
10659 if (!sym
->attr
.contained
10660 && gfc_current_form
!= FORM_FIXED
10661 && !sym
->ts
.deferred
)
10662 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10663 "CHARACTER(*) function '%s' at %L",
10664 sym
->name
, &sym
->declared_at
);
10667 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10669 gfc_formal_arglist
*curr_arg
;
10670 int has_non_interop_arg
= 0;
10672 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10673 sym
->common_block
) == FAILURE
)
10675 /* Clear these to prevent looking at them again if there was an
10677 sym
->attr
.is_bind_c
= 0;
10678 sym
->attr
.is_c_interop
= 0;
10679 sym
->ts
.is_c_interop
= 0;
10683 /* So far, no errors have been found. */
10684 sym
->attr
.is_c_interop
= 1;
10685 sym
->ts
.is_c_interop
= 1;
10688 curr_arg
= sym
->formal
;
10689 while (curr_arg
!= NULL
)
10691 /* Skip implicitly typed dummy args here. */
10692 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10693 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10694 /* If something is found to fail, record the fact so we
10695 can mark the symbol for the procedure as not being
10696 BIND(C) to try and prevent multiple errors being
10698 has_non_interop_arg
= 1;
10700 curr_arg
= curr_arg
->next
;
10703 /* See if any of the arguments were not interoperable and if so, clear
10704 the procedure symbol to prevent duplicate error messages. */
10705 if (has_non_interop_arg
!= 0)
10707 sym
->attr
.is_c_interop
= 0;
10708 sym
->ts
.is_c_interop
= 0;
10709 sym
->attr
.is_bind_c
= 0;
10713 if (!sym
->attr
.proc_pointer
)
10715 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10717 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10718 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10721 if (sym
->attr
.intent
)
10723 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10724 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10727 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10729 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10730 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10733 if (sym
->attr
.external
&& sym
->attr
.function
10734 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10735 || sym
->attr
.contained
))
10737 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10738 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10741 if (strcmp ("ppr@", sym
->name
) == 0)
10743 gfc_error ("Procedure pointer result '%s' at %L "
10744 "is missing the pointer attribute",
10745 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10754 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10755 been defined and we now know their defined arguments, check that they fulfill
10756 the requirements of the standard for procedures used as finalizers. */
10759 gfc_resolve_finalizers (gfc_symbol
* derived
)
10761 gfc_finalizer
* list
;
10762 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10763 gfc_try result
= SUCCESS
;
10764 bool seen_scalar
= false;
10766 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10769 /* Walk over the list of finalizer-procedures, check them, and if any one
10770 does not fit in with the standard's definition, print an error and remove
10771 it from the list. */
10772 prev_link
= &derived
->f2k_derived
->finalizers
;
10773 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10779 /* Skip this finalizer if we already resolved it. */
10780 if (list
->proc_tree
)
10782 prev_link
= &(list
->next
);
10786 /* Check this exists and is a SUBROUTINE. */
10787 if (!list
->proc_sym
->attr
.subroutine
)
10789 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10790 list
->proc_sym
->name
, &list
->where
);
10794 /* We should have exactly one argument. */
10795 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10797 gfc_error ("FINAL procedure at %L must have exactly one argument",
10801 arg
= list
->proc_sym
->formal
->sym
;
10803 /* This argument must be of our type. */
10804 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10806 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10807 &arg
->declared_at
, derived
->name
);
10811 /* It must neither be a pointer nor allocatable nor optional. */
10812 if (arg
->attr
.pointer
)
10814 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10815 &arg
->declared_at
);
10818 if (arg
->attr
.allocatable
)
10820 gfc_error ("Argument of FINAL procedure at %L must not be"
10821 " ALLOCATABLE", &arg
->declared_at
);
10824 if (arg
->attr
.optional
)
10826 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10827 &arg
->declared_at
);
10831 /* It must not be INTENT(OUT). */
10832 if (arg
->attr
.intent
== INTENT_OUT
)
10834 gfc_error ("Argument of FINAL procedure at %L must not be"
10835 " INTENT(OUT)", &arg
->declared_at
);
10839 /* Warn if the procedure is non-scalar and not assumed shape. */
10840 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10841 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10842 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10843 " shape argument", &arg
->declared_at
);
10845 /* Check that it does not match in kind and rank with a FINAL procedure
10846 defined earlier. To really loop over the *earlier* declarations,
10847 we need to walk the tail of the list as new ones were pushed at the
10849 /* TODO: Handle kind parameters once they are implemented. */
10850 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10851 for (i
= list
->next
; i
; i
= i
->next
)
10853 /* Argument list might be empty; that is an error signalled earlier,
10854 but we nevertheless continued resolving. */
10855 if (i
->proc_sym
->formal
)
10857 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10858 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10859 if (i_rank
== my_rank
)
10861 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10862 " rank (%d) as '%s'",
10863 list
->proc_sym
->name
, &list
->where
, my_rank
,
10864 i
->proc_sym
->name
);
10870 /* Is this the/a scalar finalizer procedure? */
10871 if (!arg
->as
|| arg
->as
->rank
== 0)
10872 seen_scalar
= true;
10874 /* Find the symtree for this procedure. */
10875 gcc_assert (!list
->proc_tree
);
10876 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10878 prev_link
= &list
->next
;
10881 /* Remove wrong nodes immediately from the list so we don't risk any
10882 troubles in the future when they might fail later expectations. */
10886 *prev_link
= list
->next
;
10887 gfc_free_finalizer (i
);
10890 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10891 were nodes in the list, must have been for arrays. It is surely a good
10892 idea to have a scalar version there if there's something to finalize. */
10893 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10894 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10895 " defined at %L, suggest also scalar one",
10896 derived
->name
, &derived
->declared_at
);
10898 /* TODO: Remove this error when finalization is finished. */
10899 gfc_error ("Finalization at %L is not yet implemented",
10900 &derived
->declared_at
);
10906 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10909 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
10910 const char* generic_name
, locus where
)
10915 gcc_assert (t1
->specific
&& t2
->specific
);
10916 gcc_assert (!t1
->specific
->is_generic
);
10917 gcc_assert (!t2
->specific
->is_generic
);
10919 sym1
= t1
->specific
->u
.specific
->n
.sym
;
10920 sym2
= t2
->specific
->u
.specific
->n
.sym
;
10925 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10926 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
10927 || sym1
->attr
.function
!= sym2
->attr
.function
)
10929 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10930 " GENERIC '%s' at %L",
10931 sym1
->name
, sym2
->name
, generic_name
, &where
);
10935 /* Compare the interfaces. */
10936 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, 1, 0, NULL
, 0))
10938 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10939 sym1
->name
, sym2
->name
, generic_name
, &where
);
10947 /* Worker function for resolving a generic procedure binding; this is used to
10948 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10950 The difference between those cases is finding possible inherited bindings
10951 that are overridden, as one has to look for them in tb_sym_root,
10952 tb_uop_root or tb_op, respectively. Thus the caller must already find
10953 the super-type and set p->overridden correctly. */
10956 resolve_tb_generic_targets (gfc_symbol
* super_type
,
10957 gfc_typebound_proc
* p
, const char* name
)
10959 gfc_tbp_generic
* target
;
10960 gfc_symtree
* first_target
;
10961 gfc_symtree
* inherited
;
10963 gcc_assert (p
&& p
->is_generic
);
10965 /* Try to find the specific bindings for the symtrees in our target-list. */
10966 gcc_assert (p
->u
.generic
);
10967 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10968 if (!target
->specific
)
10970 gfc_typebound_proc
* overridden_tbp
;
10971 gfc_tbp_generic
* g
;
10972 const char* target_name
;
10974 target_name
= target
->specific_st
->name
;
10976 /* Defined for this type directly. */
10977 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
10979 target
->specific
= target
->specific_st
->n
.tb
;
10980 goto specific_found
;
10983 /* Look for an inherited specific binding. */
10986 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
10991 gcc_assert (inherited
->n
.tb
);
10992 target
->specific
= inherited
->n
.tb
;
10993 goto specific_found
;
10997 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10998 " at %L", target_name
, name
, &p
->where
);
11001 /* Once we've found the specific binding, check it is not ambiguous with
11002 other specifics already found or inherited for the same GENERIC. */
11004 gcc_assert (target
->specific
);
11006 /* This must really be a specific binding! */
11007 if (target
->specific
->is_generic
)
11009 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11010 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11014 /* Check those already resolved on this type directly. */
11015 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11016 if (g
!= target
&& g
->specific
11017 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11021 /* Check for ambiguity with inherited specific targets. */
11022 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11023 overridden_tbp
= overridden_tbp
->overridden
)
11024 if (overridden_tbp
->is_generic
)
11026 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11028 gcc_assert (g
->specific
);
11029 if (check_generic_tbp_ambiguity (target
, g
,
11030 name
, p
->where
) == FAILURE
)
11036 /* If we attempt to "overwrite" a specific binding, this is an error. */
11037 if (p
->overridden
&& !p
->overridden
->is_generic
)
11039 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11040 " the same name", name
, &p
->where
);
11044 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11045 all must have the same attributes here. */
11046 first_target
= p
->u
.generic
->specific
->u
.specific
;
11047 gcc_assert (first_target
);
11048 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11049 p
->function
= first_target
->n
.sym
->attr
.function
;
11055 /* Resolve a GENERIC procedure binding for a derived type. */
11058 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11060 gfc_symbol
* super_type
;
11062 /* Find the overridden binding if any. */
11063 st
->n
.tb
->overridden
= NULL
;
11064 super_type
= gfc_get_derived_super_type (derived
);
11067 gfc_symtree
* overridden
;
11068 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11071 if (overridden
&& overridden
->n
.tb
)
11072 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11075 /* Resolve using worker function. */
11076 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11080 /* Retrieve the target-procedure of an operator binding and do some checks in
11081 common for intrinsic and user-defined type-bound operators. */
11084 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11086 gfc_symbol
* target_proc
;
11088 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11089 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11090 gcc_assert (target_proc
);
11092 /* All operator bindings must have a passed-object dummy argument. */
11093 if (target
->specific
->nopass
)
11095 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11099 return target_proc
;
11103 /* Resolve a type-bound intrinsic operator. */
11106 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11107 gfc_typebound_proc
* p
)
11109 gfc_symbol
* super_type
;
11110 gfc_tbp_generic
* target
;
11112 /* If there's already an error here, do nothing (but don't fail again). */
11116 /* Operators should always be GENERIC bindings. */
11117 gcc_assert (p
->is_generic
);
11119 /* Look for an overridden binding. */
11120 super_type
= gfc_get_derived_super_type (derived
);
11121 if (super_type
&& super_type
->f2k_derived
)
11122 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11125 p
->overridden
= NULL
;
11127 /* Resolve general GENERIC properties using worker function. */
11128 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11131 /* Check the targets to be procedures of correct interface. */
11132 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11134 gfc_symbol
* target_proc
;
11136 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11140 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11152 /* Resolve a type-bound user operator (tree-walker callback). */
11154 static gfc_symbol
* resolve_bindings_derived
;
11155 static gfc_try resolve_bindings_result
;
11157 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11160 resolve_typebound_user_op (gfc_symtree
* stree
)
11162 gfc_symbol
* super_type
;
11163 gfc_tbp_generic
* target
;
11165 gcc_assert (stree
&& stree
->n
.tb
);
11167 if (stree
->n
.tb
->error
)
11170 /* Operators should always be GENERIC bindings. */
11171 gcc_assert (stree
->n
.tb
->is_generic
);
11173 /* Find overridden procedure, if any. */
11174 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11175 if (super_type
&& super_type
->f2k_derived
)
11177 gfc_symtree
* overridden
;
11178 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11179 stree
->name
, true, NULL
);
11181 if (overridden
&& overridden
->n
.tb
)
11182 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11185 stree
->n
.tb
->overridden
= NULL
;
11187 /* Resolve basically using worker function. */
11188 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11192 /* Check the targets to be functions of correct interface. */
11193 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11195 gfc_symbol
* target_proc
;
11197 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11201 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11208 resolve_bindings_result
= FAILURE
;
11209 stree
->n
.tb
->error
= 1;
11213 /* Resolve the type-bound procedures for a derived type. */
11216 resolve_typebound_procedure (gfc_symtree
* stree
)
11220 gfc_symbol
* me_arg
;
11221 gfc_symbol
* super_type
;
11222 gfc_component
* comp
;
11224 gcc_assert (stree
);
11226 /* Undefined specific symbol from GENERIC target definition. */
11230 if (stree
->n
.tb
->error
)
11233 /* If this is a GENERIC binding, use that routine. */
11234 if (stree
->n
.tb
->is_generic
)
11236 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11242 /* Get the target-procedure to check it. */
11243 gcc_assert (!stree
->n
.tb
->is_generic
);
11244 gcc_assert (stree
->n
.tb
->u
.specific
);
11245 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11246 where
= stree
->n
.tb
->where
;
11248 /* Default access should already be resolved from the parser. */
11249 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11251 /* It should be a module procedure or an external procedure with explicit
11252 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11253 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11254 || (proc
->attr
.proc
!= PROC_MODULE
11255 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11256 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11258 gfc_error ("'%s' must be a module procedure or an external procedure with"
11259 " an explicit interface at %L", proc
->name
, &where
);
11262 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11263 stree
->n
.tb
->function
= proc
->attr
.function
;
11265 /* Find the super-type of the current derived type. We could do this once and
11266 store in a global if speed is needed, but as long as not I believe this is
11267 more readable and clearer. */
11268 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11270 /* If PASS, resolve and check arguments if not already resolved / loaded
11271 from a .mod file. */
11272 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11274 if (stree
->n
.tb
->pass_arg
)
11276 gfc_formal_arglist
* i
;
11278 /* If an explicit passing argument name is given, walk the arg-list
11279 and look for it. */
11282 stree
->n
.tb
->pass_arg_num
= 1;
11283 for (i
= proc
->formal
; i
; i
= i
->next
)
11285 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11290 ++stree
->n
.tb
->pass_arg_num
;
11295 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11297 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11298 stree
->n
.tb
->pass_arg
);
11304 /* Otherwise, take the first one; there should in fact be at least
11306 stree
->n
.tb
->pass_arg_num
= 1;
11309 gfc_error ("Procedure '%s' with PASS at %L must have at"
11310 " least one argument", proc
->name
, &where
);
11313 me_arg
= proc
->formal
->sym
;
11316 /* Now check that the argument-type matches and the passed-object
11317 dummy argument is generally fine. */
11319 gcc_assert (me_arg
);
11321 if (me_arg
->ts
.type
!= BT_CLASS
)
11323 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11324 " at %L", proc
->name
, &where
);
11328 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11329 != resolve_bindings_derived
)
11331 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11332 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11333 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11337 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11338 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11340 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11341 " scalar", proc
->name
, &where
);
11344 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11346 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11347 " be ALLOCATABLE", proc
->name
, &where
);
11350 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11352 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11353 " be POINTER", proc
->name
, &where
);
11358 /* If we are extending some type, check that we don't override a procedure
11359 flagged NON_OVERRIDABLE. */
11360 stree
->n
.tb
->overridden
= NULL
;
11363 gfc_symtree
* overridden
;
11364 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11365 stree
->name
, true, NULL
);
11369 if (overridden
->n
.tb
)
11370 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11372 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11377 /* See if there's a name collision with a component directly in this type. */
11378 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11379 if (!strcmp (comp
->name
, stree
->name
))
11381 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11383 stree
->name
, &where
, resolve_bindings_derived
->name
);
11387 /* Try to find a name collision with an inherited component. */
11388 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11390 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11391 " component of '%s'",
11392 stree
->name
, &where
, resolve_bindings_derived
->name
);
11396 stree
->n
.tb
->error
= 0;
11400 resolve_bindings_result
= FAILURE
;
11401 stree
->n
.tb
->error
= 1;
11406 resolve_typebound_procedures (gfc_symbol
* derived
)
11409 gfc_symbol
* super_type
;
11411 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11414 super_type
= gfc_get_derived_super_type (derived
);
11416 resolve_typebound_procedures (super_type
);
11418 resolve_bindings_derived
= derived
;
11419 resolve_bindings_result
= SUCCESS
;
11421 /* Make sure the vtab has been generated. */
11422 gfc_find_derived_vtab (derived
);
11424 if (derived
->f2k_derived
->tb_sym_root
)
11425 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11426 &resolve_typebound_procedure
);
11428 if (derived
->f2k_derived
->tb_uop_root
)
11429 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11430 &resolve_typebound_user_op
);
11432 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11434 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11435 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11437 resolve_bindings_result
= FAILURE
;
11440 return resolve_bindings_result
;
11444 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11445 to give all identical derived types the same backend_decl. */
11447 add_dt_to_dt_list (gfc_symbol
*derived
)
11449 gfc_dt_list
*dt_list
;
11451 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11452 if (derived
== dt_list
->derived
)
11455 dt_list
= gfc_get_dt_list ();
11456 dt_list
->next
= gfc_derived_types
;
11457 dt_list
->derived
= derived
;
11458 gfc_derived_types
= dt_list
;
11462 /* Ensure that a derived-type is really not abstract, meaning that every
11463 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11466 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11471 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11473 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11476 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11478 gfc_symtree
* overriding
;
11479 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11482 gcc_assert (overriding
->n
.tb
);
11483 if (overriding
->n
.tb
->deferred
)
11485 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11486 " '%s' is DEFERRED and not overridden",
11487 sub
->name
, &sub
->declared_at
, st
->name
);
11496 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11498 /* The algorithm used here is to recursively travel up the ancestry of sub
11499 and for each ancestor-type, check all bindings. If any of them is
11500 DEFERRED, look it up starting from sub and see if the found (overriding)
11501 binding is not DEFERRED.
11502 This is not the most efficient way to do this, but it should be ok and is
11503 clearer than something sophisticated. */
11505 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11507 if (!ancestor
->attr
.abstract
)
11510 /* Walk bindings of this ancestor. */
11511 if (ancestor
->f2k_derived
)
11514 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11519 /* Find next ancestor type and recurse on it. */
11520 ancestor
= gfc_get_derived_super_type (ancestor
);
11522 return ensure_not_abstract (sub
, ancestor
);
11528 /* Resolve the components of a derived type. This does not have to wait until
11529 resolution stage, but can be done as soon as the dt declaration has been
11533 resolve_fl_derived0 (gfc_symbol
*sym
)
11535 gfc_symbol
* super_type
;
11538 super_type
= gfc_get_derived_super_type (sym
);
11541 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11543 gfc_error ("As extending type '%s' at %L has a coarray component, "
11544 "parent type '%s' shall also have one", sym
->name
,
11545 &sym
->declared_at
, super_type
->name
);
11549 /* Ensure the extended type gets resolved before we do. */
11550 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11553 /* An ABSTRACT type must be extensible. */
11554 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11556 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11557 sym
->name
, &sym
->declared_at
);
11561 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11564 for ( ; c
!= NULL
; c
= c
->next
)
11566 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11567 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
)
11569 gfc_error ("Deferred-length character component '%s' at %L is not "
11570 "yet supported", c
->name
, &c
->loc
);
11575 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11576 && c
->attr
.codimension
11577 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11579 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11580 "deferred shape", c
->name
, &c
->loc
);
11585 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11586 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11588 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11589 "shall not be a coarray", c
->name
, &c
->loc
);
11594 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11595 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11596 || c
->attr
.allocatable
))
11598 gfc_error ("Component '%s' at %L with coarray component "
11599 "shall be a nonpointer, nonallocatable scalar",
11605 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11607 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11608 "is not an array pointer", c
->name
, &c
->loc
);
11612 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11614 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11615 gfc_error ("Interface '%s', used by procedure pointer component "
11616 "'%s' at %L, is declared in a later PROCEDURE statement",
11617 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11619 /* Get the attributes from the interface (now resolved). */
11620 if (c
->ts
.interface
->attr
.if_source
11621 || c
->ts
.interface
->attr
.intrinsic
)
11623 gfc_symbol
*ifc
= c
->ts
.interface
;
11625 if (ifc
->formal
&& !ifc
->formal_ns
)
11626 resolve_symbol (ifc
);
11628 if (ifc
->attr
.intrinsic
)
11629 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11633 c
->ts
= ifc
->result
->ts
;
11634 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11635 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11636 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11637 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11642 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11643 c
->attr
.pointer
= ifc
->attr
.pointer
;
11644 c
->attr
.dimension
= ifc
->attr
.dimension
;
11645 c
->as
= gfc_copy_array_spec (ifc
->as
);
11647 c
->ts
.interface
= ifc
;
11648 c
->attr
.function
= ifc
->attr
.function
;
11649 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11650 gfc_copy_formal_args_ppc (c
, ifc
);
11652 c
->attr
.pure
= ifc
->attr
.pure
;
11653 c
->attr
.elemental
= ifc
->attr
.elemental
;
11654 c
->attr
.recursive
= ifc
->attr
.recursive
;
11655 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11656 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11657 /* Replace symbols in array spec. */
11661 for (i
= 0; i
< c
->as
->rank
; i
++)
11663 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11664 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11667 /* Copy char length. */
11668 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11670 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11671 gfc_expr_replace_comp (cl
->length
, c
);
11672 if (cl
->length
&& !cl
->resolved
11673 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11678 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11680 gfc_error ("Interface '%s' of procedure pointer component "
11681 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11686 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11688 /* Since PPCs are not implicitly typed, a PPC without an explicit
11689 interface must be a subroutine. */
11690 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11693 /* Procedure pointer components: Check PASS arg. */
11694 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11695 && !sym
->attr
.vtype
)
11697 gfc_symbol
* me_arg
;
11699 if (c
->tb
->pass_arg
)
11701 gfc_formal_arglist
* i
;
11703 /* If an explicit passing argument name is given, walk the arg-list
11704 and look for it. */
11707 c
->tb
->pass_arg_num
= 1;
11708 for (i
= c
->formal
; i
; i
= i
->next
)
11710 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11715 c
->tb
->pass_arg_num
++;
11720 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11721 "at %L has no argument '%s'", c
->name
,
11722 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11729 /* Otherwise, take the first one; there should in fact be at least
11731 c
->tb
->pass_arg_num
= 1;
11734 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11735 "must have at least one argument",
11740 me_arg
= c
->formal
->sym
;
11743 /* Now check that the argument-type matches. */
11744 gcc_assert (me_arg
);
11745 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11746 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11747 || (me_arg
->ts
.type
== BT_CLASS
11748 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11750 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11751 " the derived type '%s'", me_arg
->name
, c
->name
,
11752 me_arg
->name
, &c
->loc
, sym
->name
);
11757 /* Check for C453. */
11758 if (me_arg
->attr
.dimension
)
11760 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11761 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11767 if (me_arg
->attr
.pointer
)
11769 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11770 "may not have the POINTER attribute", me_arg
->name
,
11771 c
->name
, me_arg
->name
, &c
->loc
);
11776 if (me_arg
->attr
.allocatable
)
11778 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11779 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11780 me_arg
->name
, &c
->loc
);
11785 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11786 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11787 " at %L", c
->name
, &c
->loc
);
11791 /* Check type-spec if this is not the parent-type component. */
11792 if (((sym
->attr
.is_class
11793 && (!sym
->components
->ts
.u
.derived
->attr
.extension
11794 || c
!= sym
->components
->ts
.u
.derived
->components
))
11795 || (!sym
->attr
.is_class
11796 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
11797 && !sym
->attr
.vtype
11798 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11801 /* If this type is an extension, set the accessibility of the parent
11804 && ((sym
->attr
.is_class
11805 && c
== sym
->components
->ts
.u
.derived
->components
)
11806 || (!sym
->attr
.is_class
&& c
== sym
->components
))
11807 && strcmp (super_type
->name
, c
->name
) == 0)
11808 c
->attr
.access
= super_type
->attr
.access
;
11810 /* If this type is an extension, see if this component has the same name
11811 as an inherited type-bound procedure. */
11812 if (super_type
&& !sym
->attr
.is_class
11813 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11815 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11816 " inherited type-bound procedure",
11817 c
->name
, sym
->name
, &c
->loc
);
11821 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11822 && !c
->ts
.deferred
)
11824 if (c
->ts
.u
.cl
->length
== NULL
11825 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11826 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11828 gfc_error ("Character length of component '%s' needs to "
11829 "be a constant specification expression at %L",
11831 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11836 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11837 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11839 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11840 "length must be a POINTER or ALLOCATABLE",
11841 c
->name
, sym
->name
, &c
->loc
);
11845 if (c
->ts
.type
== BT_DERIVED
11846 && sym
->component_access
!= ACCESS_PRIVATE
11847 && gfc_check_symbol_access (sym
)
11848 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11849 && !c
->ts
.u
.derived
->attr
.use_assoc
11850 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
11851 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11852 "is a PRIVATE type and cannot be a component of "
11853 "'%s', which is PUBLIC at %L", c
->name
,
11854 sym
->name
, &sym
->declared_at
) == FAILURE
)
11857 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11859 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11860 "type %s", c
->name
, &c
->loc
, sym
->name
);
11864 if (sym
->attr
.sequence
)
11866 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11868 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11869 "not have the SEQUENCE attribute",
11870 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11875 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
11876 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
11877 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11878 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
11879 CLASS_DATA (c
)->ts
.u
.derived
11880 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
11882 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11883 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11884 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11886 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11887 "that has not been declared", c
->name
, sym
->name
,
11892 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11893 && CLASS_DATA (c
)->attr
.class_pointer
11894 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11895 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11897 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11898 "that has not been declared", c
->name
, sym
->name
,
11904 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
11905 && (!c
->attr
.class_ok
11906 || !(CLASS_DATA (c
)->attr
.class_pointer
11907 || CLASS_DATA (c
)->attr
.allocatable
)))
11909 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11910 "or pointer", c
->name
, &c
->loc
);
11914 /* Ensure that all the derived type components are put on the
11915 derived type list; even in formal namespaces, where derived type
11916 pointer components might not have been declared. */
11917 if (c
->ts
.type
== BT_DERIVED
11919 && c
->ts
.u
.derived
->components
11921 && sym
!= c
->ts
.u
.derived
)
11922 add_dt_to_dt_list (c
->ts
.u
.derived
);
11924 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
11925 || c
->attr
.proc_pointer
11926 || c
->attr
.allocatable
)) == FAILURE
)
11930 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11931 all DEFERRED bindings are overridden. */
11932 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
11933 && !sym
->attr
.is_class
11934 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
11937 /* Add derived type to the derived type list. */
11938 add_dt_to_dt_list (sym
);
11944 /* The following procedure does the full resolution of a derived type,
11945 including resolution of all type-bound procedures (if present). In contrast
11946 to 'resolve_fl_derived0' this can only be done after the module has been
11947 parsed completely. */
11950 resolve_fl_derived (gfc_symbol
*sym
)
11952 gfc_symbol
*gen_dt
= NULL
;
11954 if (!sym
->attr
.is_class
)
11955 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
11956 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
11957 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Generic name '%s' of "
11958 "function '%s' at %L being the same name as derived "
11959 "type at %L", sym
->name
,
11960 gen_dt
->generic
->sym
== sym
11961 ? gen_dt
->generic
->next
->sym
->name
11962 : gen_dt
->generic
->sym
->name
,
11963 gen_dt
->generic
->sym
== sym
11964 ? &gen_dt
->generic
->next
->sym
->declared_at
11965 : &gen_dt
->generic
->sym
->declared_at
,
11966 &sym
->declared_at
) == FAILURE
)
11969 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
11971 /* Fix up incomplete CLASS symbols. */
11972 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
11973 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
11974 if (vptr
->ts
.u
.derived
== NULL
)
11976 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
11978 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
11982 if (resolve_fl_derived0 (sym
) == FAILURE
)
11985 /* Resolve the type-bound procedures. */
11986 if (resolve_typebound_procedures (sym
) == FAILURE
)
11989 /* Resolve the finalizer procedures. */
11990 if (gfc_resolve_finalizers (sym
) == FAILURE
)
11998 resolve_fl_namelist (gfc_symbol
*sym
)
12003 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12005 /* Check again, the check in match only works if NAMELIST comes
12007 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12009 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12010 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12014 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12015 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12016 "object '%s' with assumed shape in namelist "
12017 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12018 &sym
->declared_at
) == FAILURE
)
12021 if (is_non_constant_shape_array (nl
->sym
)
12022 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12023 "object '%s' with nonconstant shape in namelist "
12024 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12025 &sym
->declared_at
) == FAILURE
)
12028 if (nl
->sym
->ts
.type
== BT_CHARACTER
12029 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12030 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12031 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12032 "'%s' with nonconstant character length in "
12033 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12034 &sym
->declared_at
) == FAILURE
)
12037 /* FIXME: Once UDDTIO is implemented, the following can be
12039 if (nl
->sym
->ts
.type
== BT_CLASS
)
12041 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12042 "polymorphic and requires a defined input/output "
12043 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12047 if (nl
->sym
->ts
.type
== BT_DERIVED
12048 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12049 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12051 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12052 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12053 "or POINTER components", nl
->sym
->name
,
12054 sym
->name
, &sym
->declared_at
) == FAILURE
)
12057 /* FIXME: Once UDDTIO is implemented, the following can be
12059 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12060 "ALLOCATABLE or POINTER components and thus requires "
12061 "a defined input/output procedure", nl
->sym
->name
,
12062 sym
->name
, &sym
->declared_at
);
12067 /* Reject PRIVATE objects in a PUBLIC namelist. */
12068 if (gfc_check_symbol_access (sym
))
12070 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12072 if (!nl
->sym
->attr
.use_assoc
12073 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12074 && !gfc_check_symbol_access (nl
->sym
))
12076 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12077 "cannot be member of PUBLIC namelist '%s' at %L",
12078 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12082 /* Types with private components that came here by USE-association. */
12083 if (nl
->sym
->ts
.type
== BT_DERIVED
12084 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12086 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12087 "components and cannot be member of namelist '%s' at %L",
12088 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12092 /* Types with private components that are defined in the same module. */
12093 if (nl
->sym
->ts
.type
== BT_DERIVED
12094 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12095 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12097 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12098 "cannot be a member of PUBLIC namelist '%s' at %L",
12099 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12106 /* 14.1.2 A module or internal procedure represent local entities
12107 of the same type as a namelist member and so are not allowed. */
12108 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12110 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12113 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12114 if ((nl
->sym
== sym
->ns
->proc_name
)
12116 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12120 if (nl
->sym
&& nl
->sym
->name
)
12121 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12122 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12124 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12125 "attribute in '%s' at %L", nlsym
->name
,
12126 &sym
->declared_at
);
12136 resolve_fl_parameter (gfc_symbol
*sym
)
12138 /* A parameter array's shape needs to be constant. */
12139 if (sym
->as
!= NULL
12140 && (sym
->as
->type
== AS_DEFERRED
12141 || is_non_constant_shape_array (sym
)))
12143 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12144 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12148 /* Make sure a parameter that has been implicitly typed still
12149 matches the implicit type, since PARAMETER statements can precede
12150 IMPLICIT statements. */
12151 if (sym
->attr
.implicit_type
12152 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12155 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12156 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12160 /* Make sure the types of derived parameters are consistent. This
12161 type checking is deferred until resolution because the type may
12162 refer to a derived type from the host. */
12163 if (sym
->ts
.type
== BT_DERIVED
&& sym
->value
12164 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12166 gfc_error ("Incompatible derived type in PARAMETER at %L",
12167 &sym
->value
->where
);
12174 /* Do anything necessary to resolve a symbol. Right now, we just
12175 assume that an otherwise unknown symbol is a variable. This sort
12176 of thing commonly happens for symbols in module. */
12179 resolve_symbol (gfc_symbol
*sym
)
12181 int check_constant
, mp_flag
;
12182 gfc_symtree
*symtree
;
12183 gfc_symtree
*this_symtree
;
12186 symbol_attribute class_attr
;
12187 gfc_array_spec
*as
;
12189 if (sym
->attr
.flavor
== FL_UNKNOWN
)
12192 /* If we find that a flavorless symbol is an interface in one of the
12193 parent namespaces, find its symtree in this namespace, free the
12194 symbol and set the symtree to point to the interface symbol. */
12195 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12197 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12198 if (symtree
&& (symtree
->n
.sym
->generic
||
12199 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12200 && sym
->ns
->construct_entities
)))
12202 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12204 gfc_release_symbol (sym
);
12205 symtree
->n
.sym
->refs
++;
12206 this_symtree
->n
.sym
= symtree
->n
.sym
;
12211 /* Otherwise give it a flavor according to such attributes as
12213 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
12214 sym
->attr
.flavor
= FL_VARIABLE
;
12217 sym
->attr
.flavor
= FL_PROCEDURE
;
12218 if (sym
->attr
.dimension
)
12219 sym
->attr
.function
= 1;
12223 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12224 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12226 if (sym
->attr
.procedure
&& sym
->ts
.interface
12227 && sym
->attr
.if_source
!= IFSRC_DECL
12228 && resolve_procedure_interface (sym
) == FAILURE
)
12231 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12232 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12234 if (sym
->attr
.external
)
12235 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12236 "at %L", &sym
->declared_at
);
12238 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12239 "at %L", &sym
->declared_at
);
12244 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12247 /* Symbols that are module procedures with results (functions) have
12248 the types and array specification copied for type checking in
12249 procedures that call them, as well as for saving to a module
12250 file. These symbols can't stand the scrutiny that their results
12252 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12254 /* Make sure that the intrinsic is consistent with its internal
12255 representation. This needs to be done before assigning a default
12256 type to avoid spurious warnings. */
12257 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12258 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12261 /* Resolve associate names. */
12263 resolve_assoc_var (sym
, true);
12265 /* Assign default type to symbols that need one and don't have one. */
12266 if (sym
->ts
.type
== BT_UNKNOWN
)
12268 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12270 gfc_set_default_type (sym
, 1, NULL
);
12273 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12274 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12275 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12276 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12278 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12280 /* The specific case of an external procedure should emit an error
12281 in the case that there is no implicit type. */
12283 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12286 /* Result may be in another namespace. */
12287 resolve_symbol (sym
->result
);
12289 if (!sym
->result
->attr
.proc_pointer
)
12291 sym
->ts
= sym
->result
->ts
;
12292 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12293 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12294 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12295 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12296 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12301 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12302 gfc_resolve_array_spec (sym
->result
->as
, false);
12304 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12306 as
= CLASS_DATA (sym
)->as
;
12307 class_attr
= CLASS_DATA (sym
)->attr
;
12308 class_attr
.pointer
= class_attr
.class_pointer
;
12312 class_attr
= sym
->attr
;
12317 if (sym
->attr
.contiguous
12318 && (!class_attr
.dimension
12319 || (as
->type
!= AS_ASSUMED_SHAPE
&& !class_attr
.pointer
)))
12321 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12322 "array pointer or an assumed-shape array", sym
->name
,
12323 &sym
->declared_at
);
12327 /* Assumed size arrays and assumed shape arrays must be dummy
12328 arguments. Array-spec's of implied-shape should have been resolved to
12329 AS_EXPLICIT already. */
12333 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12334 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12335 || as
->type
== AS_ASSUMED_SHAPE
)
12336 && sym
->attr
.dummy
== 0)
12338 if (as
->type
== AS_ASSUMED_SIZE
)
12339 gfc_error ("Assumed size array at %L must be a dummy argument",
12340 &sym
->declared_at
);
12342 gfc_error ("Assumed shape array at %L must be a dummy argument",
12343 &sym
->declared_at
);
12348 /* Make sure symbols with known intent or optional are really dummy
12349 variable. Because of ENTRY statement, this has to be deferred
12350 until resolution time. */
12352 if (!sym
->attr
.dummy
12353 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12355 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12359 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12361 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12362 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12366 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12368 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12369 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12371 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12372 "attribute must have constant length",
12373 sym
->name
, &sym
->declared_at
);
12377 if (sym
->ts
.is_c_interop
12378 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12380 gfc_error ("C interoperable character dummy variable '%s' at %L "
12381 "with VALUE attribute must have length one",
12382 sym
->name
, &sym
->declared_at
);
12387 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12388 && sym
->ts
.u
.derived
->attr
.generic
)
12390 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12391 if (!sym
->ts
.u
.derived
)
12393 gfc_error ("The derived type '%s' at %L is of type '%s', "
12394 "which has not been defined", sym
->name
,
12395 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12396 sym
->ts
.type
= BT_UNKNOWN
;
12401 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12402 do this for something that was implicitly typed because that is handled
12403 in gfc_set_default_type. Handle dummy arguments and procedure
12404 definitions separately. Also, anything that is use associated is not
12405 handled here but instead is handled in the module it is declared in.
12406 Finally, derived type definitions are allowed to be BIND(C) since that
12407 only implies that they're interoperable, and they are checked fully for
12408 interoperability when a variable is declared of that type. */
12409 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12410 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12411 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12413 gfc_try t
= SUCCESS
;
12415 /* First, make sure the variable is declared at the
12416 module-level scope (J3/04-007, Section 15.3). */
12417 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12418 sym
->attr
.in_common
== 0)
12420 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12421 "is neither a COMMON block nor declared at the "
12422 "module level scope", sym
->name
, &(sym
->declared_at
));
12425 else if (sym
->common_head
!= NULL
)
12427 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12431 /* If type() declaration, we need to verify that the components
12432 of the given type are all C interoperable, etc. */
12433 if (sym
->ts
.type
== BT_DERIVED
&&
12434 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12436 /* Make sure the user marked the derived type as BIND(C). If
12437 not, call the verify routine. This could print an error
12438 for the derived type more than once if multiple variables
12439 of that type are declared. */
12440 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12441 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12445 /* Verify the variable itself as C interoperable if it
12446 is BIND(C). It is not possible for this to succeed if
12447 the verify_bind_c_derived_type failed, so don't have to handle
12448 any error returned by verify_bind_c_derived_type. */
12449 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12450 sym
->common_block
);
12455 /* clear the is_bind_c flag to prevent reporting errors more than
12456 once if something failed. */
12457 sym
->attr
.is_bind_c
= 0;
12462 /* If a derived type symbol has reached this point, without its
12463 type being declared, we have an error. Notice that most
12464 conditions that produce undefined derived types have already
12465 been dealt with. However, the likes of:
12466 implicit type(t) (t) ..... call foo (t) will get us here if
12467 the type is not declared in the scope of the implicit
12468 statement. Change the type to BT_UNKNOWN, both because it is so
12469 and to prevent an ICE. */
12470 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12471 && sym
->ts
.u
.derived
->components
== NULL
12472 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12474 gfc_error ("The derived type '%s' at %L is of type '%s', "
12475 "which has not been defined", sym
->name
,
12476 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12477 sym
->ts
.type
= BT_UNKNOWN
;
12481 /* Make sure that the derived type has been resolved and that the
12482 derived type is visible in the symbol's namespace, if it is a
12483 module function and is not PRIVATE. */
12484 if (sym
->ts
.type
== BT_DERIVED
12485 && sym
->ts
.u
.derived
->attr
.use_assoc
12486 && sym
->ns
->proc_name
12487 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12488 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12491 /* Unless the derived-type declaration is use associated, Fortran 95
12492 does not allow public entries of private derived types.
12493 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12494 161 in 95-006r3. */
12495 if (sym
->ts
.type
== BT_DERIVED
12496 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12497 && !sym
->ts
.u
.derived
->attr
.use_assoc
12498 && gfc_check_symbol_access (sym
)
12499 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12500 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12501 "of PRIVATE derived type '%s'",
12502 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12503 : "variable", sym
->name
, &sym
->declared_at
,
12504 sym
->ts
.u
.derived
->name
) == FAILURE
)
12507 /* F2008, C1302. */
12508 if (sym
->ts
.type
== BT_DERIVED
12509 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12510 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12511 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12512 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12514 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12515 "type LOCK_TYPE must be a coarray", sym
->name
,
12516 &sym
->declared_at
);
12520 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12521 default initialization is defined (5.1.2.4.4). */
12522 if (sym
->ts
.type
== BT_DERIVED
12524 && sym
->attr
.intent
== INTENT_OUT
12526 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12528 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12530 if (c
->initializer
)
12532 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12533 "ASSUMED SIZE and so cannot have a default initializer",
12534 sym
->name
, &sym
->declared_at
);
12541 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12542 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12544 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12545 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12550 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12551 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12552 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12553 || class_attr
.codimension
)
12554 && (sym
->attr
.result
|| sym
->result
== sym
))
12556 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12557 "a coarray component", sym
->name
, &sym
->declared_at
);
12562 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12563 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12565 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12566 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12571 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12572 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12573 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12574 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12575 || class_attr
.allocatable
))
12577 gfc_error ("Variable '%s' at %L with coarray component "
12578 "shall be a nonpointer, nonallocatable scalar",
12579 sym
->name
, &sym
->declared_at
);
12583 /* F2008, C526. The function-result case was handled above. */
12584 if (class_attr
.codimension
12585 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12586 || sym
->attr
.select_type_temporary
12587 || sym
->ns
->save_all
12588 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12589 || sym
->ns
->proc_name
->attr
.is_main_program
12590 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12592 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12593 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12597 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
12598 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
12600 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12601 "deferred shape", sym
->name
, &sym
->declared_at
);
12604 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
12605 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
12607 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12608 "deferred shape", sym
->name
, &sym
->declared_at
);
12613 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12614 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12615 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12616 || (class_attr
.codimension
&& class_attr
.allocatable
))
12617 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12619 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12620 "allocatable coarray or have coarray components",
12621 sym
->name
, &sym
->declared_at
);
12625 if (class_attr
.codimension
&& sym
->attr
.dummy
12626 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12628 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12629 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12630 sym
->ns
->proc_name
->name
);
12634 switch (sym
->attr
.flavor
)
12637 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12642 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12647 if (resolve_fl_namelist (sym
) == FAILURE
)
12652 if (resolve_fl_parameter (sym
) == FAILURE
)
12660 /* Resolve array specifier. Check as well some constraints
12661 on COMMON blocks. */
12663 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12665 /* Set the formal_arg_flag so that check_conflict will not throw
12666 an error for host associated variables in the specification
12667 expression for an array_valued function. */
12668 if (sym
->attr
.function
&& sym
->as
)
12669 formal_arg_flag
= 1;
12671 gfc_resolve_array_spec (sym
->as
, check_constant
);
12673 formal_arg_flag
= 0;
12675 /* Resolve formal namespaces. */
12676 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12677 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12678 gfc_resolve (sym
->formal_ns
);
12680 /* Make sure the formal namespace is present. */
12681 if (sym
->formal
&& !sym
->formal_ns
)
12683 gfc_formal_arglist
*formal
= sym
->formal
;
12684 while (formal
&& !formal
->sym
)
12685 formal
= formal
->next
;
12689 sym
->formal_ns
= formal
->sym
->ns
;
12690 sym
->formal_ns
->refs
++;
12694 /* Check threadprivate restrictions. */
12695 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12696 && (!sym
->attr
.in_common
12697 && sym
->module
== NULL
12698 && (sym
->ns
->proc_name
== NULL
12699 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12700 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12702 /* If we have come this far we can apply default-initializers, as
12703 described in 14.7.5, to those variables that have not already
12704 been assigned one. */
12705 if (sym
->ts
.type
== BT_DERIVED
12706 && sym
->ns
== gfc_current_ns
12708 && !sym
->attr
.allocatable
12709 && !sym
->attr
.alloc_comp
)
12711 symbol_attribute
*a
= &sym
->attr
;
12713 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12714 && !a
->in_common
&& !a
->use_assoc
12715 && (a
->referenced
|| a
->result
)
12716 && !(a
->function
&& sym
!= sym
->result
))
12717 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12718 apply_default_init (sym
);
12721 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12722 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12723 && !CLASS_DATA (sym
)->attr
.class_pointer
12724 && !CLASS_DATA (sym
)->attr
.allocatable
)
12725 apply_default_init (sym
);
12727 /* If this symbol has a type-spec, check it. */
12728 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12729 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12730 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12736 /************* Resolve DATA statements *************/
12740 gfc_data_value
*vnode
;
12746 /* Advance the values structure to point to the next value in the data list. */
12749 next_data_value (void)
12751 while (mpz_cmp_ui (values
.left
, 0) == 0)
12754 if (values
.vnode
->next
== NULL
)
12757 values
.vnode
= values
.vnode
->next
;
12758 mpz_set (values
.left
, values
.vnode
->repeat
);
12766 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12772 ar_type mark
= AR_UNKNOWN
;
12774 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12780 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12784 mpz_init_set_si (offset
, 0);
12787 if (e
->expr_type
!= EXPR_VARIABLE
)
12788 gfc_internal_error ("check_data_variable(): Bad expression");
12790 sym
= e
->symtree
->n
.sym
;
12792 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12794 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12795 sym
->name
, &sym
->declared_at
);
12798 if (e
->ref
== NULL
&& sym
->as
)
12800 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12801 " declaration", sym
->name
, where
);
12805 has_pointer
= sym
->attr
.pointer
;
12807 if (gfc_is_coindexed (e
))
12809 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
12814 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12816 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12820 && ref
->type
== REF_ARRAY
12821 && ref
->u
.ar
.type
!= AR_FULL
)
12823 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12824 "be a full array", sym
->name
, where
);
12829 if (e
->rank
== 0 || has_pointer
)
12831 mpz_init_set_ui (size
, 1);
12838 /* Find the array section reference. */
12839 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12841 if (ref
->type
!= REF_ARRAY
)
12843 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12849 /* Set marks according to the reference pattern. */
12850 switch (ref
->u
.ar
.type
)
12858 /* Get the start position of array section. */
12859 gfc_get_section_index (ar
, section_index
, &offset
);
12864 gcc_unreachable ();
12867 if (gfc_array_size (e
, &size
) == FAILURE
)
12869 gfc_error ("Nonconstant array section at %L in DATA statement",
12871 mpz_clear (offset
);
12878 while (mpz_cmp_ui (size
, 0) > 0)
12880 if (next_data_value () == FAILURE
)
12882 gfc_error ("DATA statement at %L has more variables than values",
12888 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
12892 /* If we have more than one element left in the repeat count,
12893 and we have more than one element left in the target variable,
12894 then create a range assignment. */
12895 /* FIXME: Only done for full arrays for now, since array sections
12897 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
12898 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
12902 if (mpz_cmp (size
, values
.left
) >= 0)
12904 mpz_init_set (range
, values
.left
);
12905 mpz_sub (size
, size
, values
.left
);
12906 mpz_set_ui (values
.left
, 0);
12910 mpz_init_set (range
, size
);
12911 mpz_sub (values
.left
, values
.left
, size
);
12912 mpz_set_ui (size
, 0);
12915 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
12918 mpz_add (offset
, offset
, range
);
12925 /* Assign initial value to symbol. */
12928 mpz_sub_ui (values
.left
, values
.left
, 1);
12929 mpz_sub_ui (size
, size
, 1);
12931 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
12936 if (mark
== AR_FULL
)
12937 mpz_add_ui (offset
, offset
, 1);
12939 /* Modify the array section indexes and recalculate the offset
12940 for next element. */
12941 else if (mark
== AR_SECTION
)
12942 gfc_advance_section (section_index
, ar
, &offset
);
12946 if (mark
== AR_SECTION
)
12948 for (i
= 0; i
< ar
->dimen
; i
++)
12949 mpz_clear (section_index
[i
]);
12953 mpz_clear (offset
);
12959 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
12961 /* Iterate over a list of elements in a DATA statement. */
12964 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
12967 iterator_stack frame
;
12968 gfc_expr
*e
, *start
, *end
, *step
;
12969 gfc_try retval
= SUCCESS
;
12971 mpz_init (frame
.value
);
12974 start
= gfc_copy_expr (var
->iter
.start
);
12975 end
= gfc_copy_expr (var
->iter
.end
);
12976 step
= gfc_copy_expr (var
->iter
.step
);
12978 if (gfc_simplify_expr (start
, 1) == FAILURE
12979 || start
->expr_type
!= EXPR_CONSTANT
)
12981 gfc_error ("start of implied-do loop at %L could not be "
12982 "simplified to a constant value", &start
->where
);
12986 if (gfc_simplify_expr (end
, 1) == FAILURE
12987 || end
->expr_type
!= EXPR_CONSTANT
)
12989 gfc_error ("end of implied-do loop at %L could not be "
12990 "simplified to a constant value", &start
->where
);
12994 if (gfc_simplify_expr (step
, 1) == FAILURE
12995 || step
->expr_type
!= EXPR_CONSTANT
)
12997 gfc_error ("step of implied-do loop at %L could not be "
12998 "simplified to a constant value", &start
->where
);
13003 mpz_set (trip
, end
->value
.integer
);
13004 mpz_sub (trip
, trip
, start
->value
.integer
);
13005 mpz_add (trip
, trip
, step
->value
.integer
);
13007 mpz_div (trip
, trip
, step
->value
.integer
);
13009 mpz_set (frame
.value
, start
->value
.integer
);
13011 frame
.prev
= iter_stack
;
13012 frame
.variable
= var
->iter
.var
->symtree
;
13013 iter_stack
= &frame
;
13015 while (mpz_cmp_ui (trip
, 0) > 0)
13017 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13023 e
= gfc_copy_expr (var
->expr
);
13024 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13031 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13033 mpz_sub_ui (trip
, trip
, 1);
13037 mpz_clear (frame
.value
);
13040 gfc_free_expr (start
);
13041 gfc_free_expr (end
);
13042 gfc_free_expr (step
);
13044 iter_stack
= frame
.prev
;
13049 /* Type resolve variables in the variable list of a DATA statement. */
13052 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13056 for (; var
; var
= var
->next
)
13058 if (var
->expr
== NULL
)
13059 t
= traverse_data_list (var
, where
);
13061 t
= check_data_variable (var
, where
);
13071 /* Resolve the expressions and iterators associated with a data statement.
13072 This is separate from the assignment checking because data lists should
13073 only be resolved once. */
13076 resolve_data_variables (gfc_data_variable
*d
)
13078 for (; d
; d
= d
->next
)
13080 if (d
->list
== NULL
)
13082 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13087 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
13090 if (resolve_data_variables (d
->list
) == FAILURE
)
13099 /* Resolve a single DATA statement. We implement this by storing a pointer to
13100 the value list into static variables, and then recursively traversing the
13101 variables list, expanding iterators and such. */
13104 resolve_data (gfc_data
*d
)
13107 if (resolve_data_variables (d
->var
) == FAILURE
)
13110 values
.vnode
= d
->value
;
13111 if (d
->value
== NULL
)
13112 mpz_set_ui (values
.left
, 0);
13114 mpz_set (values
.left
, d
->value
->repeat
);
13116 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13119 /* At this point, we better not have any values left. */
13121 if (next_data_value () == SUCCESS
)
13122 gfc_error ("DATA statement at %L has more values than variables",
13127 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13128 accessed by host or use association, is a dummy argument to a pure function,
13129 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13130 is storage associated with any such variable, shall not be used in the
13131 following contexts: (clients of this function). */
13133 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13134 procedure. Returns zero if assignment is OK, nonzero if there is a
13137 gfc_impure_variable (gfc_symbol
*sym
)
13142 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13145 /* Check if the symbol's ns is inside the pure procedure. */
13146 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13150 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13154 proc
= sym
->ns
->proc_name
;
13155 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13156 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13158 proc
->attr
.function
))
13161 /* TODO: Sort out what can be storage associated, if anything, and include
13162 it here. In principle equivalences should be scanned but it does not
13163 seem to be possible to storage associate an impure variable this way. */
13168 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13169 current namespace is inside a pure procedure. */
13172 gfc_pure (gfc_symbol
*sym
)
13174 symbol_attribute attr
;
13179 /* Check if the current namespace or one of its parents
13180 belongs to a pure procedure. */
13181 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13183 sym
= ns
->proc_name
;
13187 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13195 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13199 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13200 checks if the current namespace is implicitly pure. Note that this
13201 function returns false for a PURE procedure. */
13204 gfc_implicit_pure (gfc_symbol
*sym
)
13210 /* Check if the current procedure is implicit_pure. Walk up
13211 the procedure list until we find a procedure. */
13212 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13214 sym
= ns
->proc_name
;
13218 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13223 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13224 && !sym
->attr
.pure
;
13228 /* Test whether the current procedure is elemental or not. */
13231 gfc_elemental (gfc_symbol
*sym
)
13233 symbol_attribute attr
;
13236 sym
= gfc_current_ns
->proc_name
;
13241 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13245 /* Warn about unused labels. */
13248 warn_unused_fortran_label (gfc_st_label
*label
)
13253 warn_unused_fortran_label (label
->left
);
13255 if (label
->defined
== ST_LABEL_UNKNOWN
)
13258 switch (label
->referenced
)
13260 case ST_LABEL_UNKNOWN
:
13261 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13265 case ST_LABEL_BAD_TARGET
:
13266 gfc_warning ("Label %d at %L defined but cannot be used",
13267 label
->value
, &label
->where
);
13274 warn_unused_fortran_label (label
->right
);
13278 /* Returns the sequence type of a symbol or sequence. */
13281 sequence_type (gfc_typespec ts
)
13290 if (ts
.u
.derived
->components
== NULL
)
13291 return SEQ_NONDEFAULT
;
13293 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13294 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13295 if (sequence_type (c
->ts
) != result
)
13301 if (ts
.kind
!= gfc_default_character_kind
)
13302 return SEQ_NONDEFAULT
;
13304 return SEQ_CHARACTER
;
13307 if (ts
.kind
!= gfc_default_integer_kind
)
13308 return SEQ_NONDEFAULT
;
13310 return SEQ_NUMERIC
;
13313 if (!(ts
.kind
== gfc_default_real_kind
13314 || ts
.kind
== gfc_default_double_kind
))
13315 return SEQ_NONDEFAULT
;
13317 return SEQ_NUMERIC
;
13320 if (ts
.kind
!= gfc_default_complex_kind
)
13321 return SEQ_NONDEFAULT
;
13323 return SEQ_NUMERIC
;
13326 if (ts
.kind
!= gfc_default_logical_kind
)
13327 return SEQ_NONDEFAULT
;
13329 return SEQ_NUMERIC
;
13332 return SEQ_NONDEFAULT
;
13337 /* Resolve derived type EQUIVALENCE object. */
13340 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13342 gfc_component
*c
= derived
->components
;
13347 /* Shall not be an object of nonsequence derived type. */
13348 if (!derived
->attr
.sequence
)
13350 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13351 "attribute to be an EQUIVALENCE object", sym
->name
,
13356 /* Shall not have allocatable components. */
13357 if (derived
->attr
.alloc_comp
)
13359 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13360 "components to be an EQUIVALENCE object",sym
->name
,
13365 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13367 gfc_error ("Derived type variable '%s' at %L with default "
13368 "initialization cannot be in EQUIVALENCE with a variable "
13369 "in COMMON", sym
->name
, &e
->where
);
13373 for (; c
; c
= c
->next
)
13375 if (c
->ts
.type
== BT_DERIVED
13376 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13379 /* Shall not be an object of sequence derived type containing a pointer
13380 in the structure. */
13381 if (c
->attr
.pointer
)
13383 gfc_error ("Derived type variable '%s' at %L with pointer "
13384 "component(s) cannot be an EQUIVALENCE object",
13385 sym
->name
, &e
->where
);
13393 /* Resolve equivalence object.
13394 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13395 an allocatable array, an object of nonsequence derived type, an object of
13396 sequence derived type containing a pointer at any level of component
13397 selection, an automatic object, a function name, an entry name, a result
13398 name, a named constant, a structure component, or a subobject of any of
13399 the preceding objects. A substring shall not have length zero. A
13400 derived type shall not have components with default initialization nor
13401 shall two objects of an equivalence group be initialized.
13402 Either all or none of the objects shall have an protected attribute.
13403 The simple constraints are done in symbol.c(check_conflict) and the rest
13404 are implemented here. */
13407 resolve_equivalence (gfc_equiv
*eq
)
13410 gfc_symbol
*first_sym
;
13413 locus
*last_where
= NULL
;
13414 seq_type eq_type
, last_eq_type
;
13415 gfc_typespec
*last_ts
;
13416 int object
, cnt_protected
;
13419 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13421 first_sym
= eq
->expr
->symtree
->n
.sym
;
13425 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13429 e
->ts
= e
->symtree
->n
.sym
->ts
;
13430 /* match_varspec might not know yet if it is seeing
13431 array reference or substring reference, as it doesn't
13433 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13435 gfc_ref
*ref
= e
->ref
;
13436 sym
= e
->symtree
->n
.sym
;
13438 if (sym
->attr
.dimension
)
13440 ref
->u
.ar
.as
= sym
->as
;
13444 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13445 if (e
->ts
.type
== BT_CHARACTER
13447 && ref
->type
== REF_ARRAY
13448 && ref
->u
.ar
.dimen
== 1
13449 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13450 && ref
->u
.ar
.stride
[0] == NULL
)
13452 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13453 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13456 /* Optimize away the (:) reference. */
13457 if (start
== NULL
&& end
== NULL
)
13460 e
->ref
= ref
->next
;
13462 e
->ref
->next
= ref
->next
;
13467 ref
->type
= REF_SUBSTRING
;
13469 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13471 ref
->u
.ss
.start
= start
;
13472 if (end
== NULL
&& e
->ts
.u
.cl
)
13473 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13474 ref
->u
.ss
.end
= end
;
13475 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13482 /* Any further ref is an error. */
13485 gcc_assert (ref
->type
== REF_ARRAY
);
13486 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13492 if (gfc_resolve_expr (e
) == FAILURE
)
13495 sym
= e
->symtree
->n
.sym
;
13497 if (sym
->attr
.is_protected
)
13499 if (cnt_protected
> 0 && cnt_protected
!= object
)
13501 gfc_error ("Either all or none of the objects in the "
13502 "EQUIVALENCE set at %L shall have the "
13503 "PROTECTED attribute",
13508 /* Shall not equivalence common block variables in a PURE procedure. */
13509 if (sym
->ns
->proc_name
13510 && sym
->ns
->proc_name
->attr
.pure
13511 && sym
->attr
.in_common
)
13513 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13514 "object in the pure procedure '%s'",
13515 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13519 /* Shall not be a named constant. */
13520 if (e
->expr_type
== EXPR_CONSTANT
)
13522 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13523 "object", sym
->name
, &e
->where
);
13527 if (e
->ts
.type
== BT_DERIVED
13528 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13531 /* Check that the types correspond correctly:
13533 A numeric sequence structure may be equivalenced to another sequence
13534 structure, an object of default integer type, default real type, double
13535 precision real type, default logical type such that components of the
13536 structure ultimately only become associated to objects of the same
13537 kind. A character sequence structure may be equivalenced to an object
13538 of default character kind or another character sequence structure.
13539 Other objects may be equivalenced only to objects of the same type and
13540 kind parameters. */
13542 /* Identical types are unconditionally OK. */
13543 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13544 goto identical_types
;
13546 last_eq_type
= sequence_type (*last_ts
);
13547 eq_type
= sequence_type (sym
->ts
);
13549 /* Since the pair of objects is not of the same type, mixed or
13550 non-default sequences can be rejected. */
13552 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13553 "statement at %L with different type objects";
13555 && last_eq_type
== SEQ_MIXED
13556 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13558 || (eq_type
== SEQ_MIXED
13559 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13560 &e
->where
) == FAILURE
))
13563 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13564 "statement at %L with objects of different type";
13566 && last_eq_type
== SEQ_NONDEFAULT
13567 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13568 last_where
) == FAILURE
)
13569 || (eq_type
== SEQ_NONDEFAULT
13570 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13571 &e
->where
) == FAILURE
))
13574 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13575 "EQUIVALENCE statement at %L";
13576 if (last_eq_type
== SEQ_CHARACTER
13577 && eq_type
!= SEQ_CHARACTER
13578 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13579 &e
->where
) == FAILURE
)
13582 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13583 "EQUIVALENCE statement at %L";
13584 if (last_eq_type
== SEQ_NUMERIC
13585 && eq_type
!= SEQ_NUMERIC
13586 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13587 &e
->where
) == FAILURE
)
13592 last_where
= &e
->where
;
13597 /* Shall not be an automatic array. */
13598 if (e
->ref
->type
== REF_ARRAY
13599 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13601 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13602 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13609 /* Shall not be a structure component. */
13610 if (r
->type
== REF_COMPONENT
)
13612 gfc_error ("Structure component '%s' at %L cannot be an "
13613 "EQUIVALENCE object",
13614 r
->u
.c
.component
->name
, &e
->where
);
13618 /* A substring shall not have length zero. */
13619 if (r
->type
== REF_SUBSTRING
)
13621 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13623 gfc_error ("Substring at %L has length zero",
13624 &r
->u
.ss
.start
->where
);
13634 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13637 resolve_fntype (gfc_namespace
*ns
)
13639 gfc_entry_list
*el
;
13642 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13645 /* If there are any entries, ns->proc_name is the entry master
13646 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13648 sym
= ns
->entries
->sym
;
13650 sym
= ns
->proc_name
;
13651 if (sym
->result
== sym
13652 && sym
->ts
.type
== BT_UNKNOWN
13653 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13654 && !sym
->attr
.untyped
)
13656 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13657 sym
->name
, &sym
->declared_at
);
13658 sym
->attr
.untyped
= 1;
13661 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13662 && !sym
->attr
.contained
13663 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13664 && gfc_check_symbol_access (sym
))
13666 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13667 "%L of PRIVATE type '%s'", sym
->name
,
13668 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13672 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13674 if (el
->sym
->result
== el
->sym
13675 && el
->sym
->ts
.type
== BT_UNKNOWN
13676 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13677 && !el
->sym
->attr
.untyped
)
13679 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13680 el
->sym
->name
, &el
->sym
->declared_at
);
13681 el
->sym
->attr
.untyped
= 1;
13687 /* 12.3.2.1.1 Defined operators. */
13690 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13692 gfc_formal_arglist
*formal
;
13694 if (!sym
->attr
.function
)
13696 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13697 sym
->name
, &where
);
13701 if (sym
->ts
.type
== BT_CHARACTER
13702 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13703 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13704 && sym
->result
->ts
.u
.cl
->length
))
13706 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13707 "character length", sym
->name
, &where
);
13711 formal
= sym
->formal
;
13712 if (!formal
|| !formal
->sym
)
13714 gfc_error ("User operator procedure '%s' at %L must have at least "
13715 "one argument", sym
->name
, &where
);
13719 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13721 gfc_error ("First argument of operator interface at %L must be "
13722 "INTENT(IN)", &where
);
13726 if (formal
->sym
->attr
.optional
)
13728 gfc_error ("First argument of operator interface at %L cannot be "
13729 "optional", &where
);
13733 formal
= formal
->next
;
13734 if (!formal
|| !formal
->sym
)
13737 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13739 gfc_error ("Second argument of operator interface at %L must be "
13740 "INTENT(IN)", &where
);
13744 if (formal
->sym
->attr
.optional
)
13746 gfc_error ("Second argument of operator interface at %L cannot be "
13747 "optional", &where
);
13753 gfc_error ("Operator interface at %L must have, at most, two "
13754 "arguments", &where
);
13762 gfc_resolve_uops (gfc_symtree
*symtree
)
13764 gfc_interface
*itr
;
13766 if (symtree
== NULL
)
13769 gfc_resolve_uops (symtree
->left
);
13770 gfc_resolve_uops (symtree
->right
);
13772 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13773 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13777 /* Examine all of the expressions associated with a program unit,
13778 assign types to all intermediate expressions, make sure that all
13779 assignments are to compatible types and figure out which names
13780 refer to which functions or subroutines. It doesn't check code
13781 block, which is handled by resolve_code. */
13784 resolve_types (gfc_namespace
*ns
)
13790 gfc_namespace
* old_ns
= gfc_current_ns
;
13792 /* Check that all IMPLICIT types are ok. */
13793 if (!ns
->seen_implicit_none
)
13796 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13797 if (ns
->set_flag
[letter
]
13798 && resolve_typespec_used (&ns
->default_type
[letter
],
13799 &ns
->implicit_loc
[letter
],
13804 gfc_current_ns
= ns
;
13806 resolve_entries (ns
);
13808 resolve_common_vars (ns
->blank_common
.head
, false);
13809 resolve_common_blocks (ns
->common_root
);
13811 resolve_contained_functions (ns
);
13813 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
13814 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
13815 resolve_formal_arglist (ns
->proc_name
);
13817 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13819 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13820 resolve_charlen (cl
);
13822 gfc_traverse_ns (ns
, resolve_symbol
);
13824 resolve_fntype (ns
);
13826 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13828 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13829 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13830 "also be PURE", n
->proc_name
->name
,
13831 &n
->proc_name
->declared_at
);
13837 do_concurrent_flag
= 0;
13838 gfc_check_interfaces (ns
);
13840 gfc_traverse_ns (ns
, resolve_values
);
13846 for (d
= ns
->data
; d
; d
= d
->next
)
13850 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13852 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13854 if (ns
->common_root
!= NULL
)
13855 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13857 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13858 resolve_equivalence (eq
);
13860 /* Warn about unused labels. */
13861 if (warn_unused_label
)
13862 warn_unused_fortran_label (ns
->st_labels
);
13864 gfc_resolve_uops (ns
->uop_root
);
13866 gfc_current_ns
= old_ns
;
13870 /* Call resolve_code recursively. */
13873 resolve_codes (gfc_namespace
*ns
)
13876 bitmap_obstack old_obstack
;
13878 if (ns
->resolved
== 1)
13881 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13884 gfc_current_ns
= ns
;
13886 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13887 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
13890 /* Set to an out of range value. */
13891 current_entry_id
= -1;
13893 old_obstack
= labels_obstack
;
13894 bitmap_obstack_initialize (&labels_obstack
);
13896 resolve_code (ns
->code
, ns
);
13898 bitmap_obstack_release (&labels_obstack
);
13899 labels_obstack
= old_obstack
;
13903 /* This function is called after a complete program unit has been compiled.
13904 Its purpose is to examine all of the expressions associated with a program
13905 unit, assign types to all intermediate expressions, make sure that all
13906 assignments are to compatible types and figure out which names refer to
13907 which functions or subroutines. */
13910 gfc_resolve (gfc_namespace
*ns
)
13912 gfc_namespace
*old_ns
;
13913 code_stack
*old_cs_base
;
13919 old_ns
= gfc_current_ns
;
13920 old_cs_base
= cs_base
;
13922 resolve_types (ns
);
13923 resolve_codes (ns
);
13925 gfc_current_ns
= old_ns
;
13926 cs_base
= old_cs_base
;
13929 gfc_run_passes (ns
);