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
;
5621 /* Get the ultimate declared type from an expression. In addition,
5622 return the last class/derived type reference and the copy of the
5625 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5628 gfc_symbol
*declared
;
5635 *new_ref
= gfc_copy_ref (e
->ref
);
5637 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5639 if (ref
->type
!= REF_COMPONENT
)
5642 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5643 || ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5645 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5651 if (declared
== NULL
)
5652 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5658 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5659 which of the specific bindings (if any) matches the arglist and transform
5660 the expression into a call of that binding. */
5663 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5665 gfc_typebound_proc
* genproc
;
5666 const char* genname
;
5668 gfc_symbol
*derived
;
5670 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5671 genname
= e
->value
.compcall
.name
;
5672 genproc
= e
->value
.compcall
.tbp
;
5674 if (!genproc
->is_generic
)
5677 /* Try the bindings on this type and in the inheritance hierarchy. */
5678 for (; genproc
; genproc
= genproc
->overridden
)
5682 gcc_assert (genproc
->is_generic
);
5683 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5686 gfc_actual_arglist
* args
;
5689 gcc_assert (g
->specific
);
5691 if (g
->specific
->error
)
5694 target
= g
->specific
->u
.specific
->n
.sym
;
5696 /* Get the right arglist by handling PASS/NOPASS. */
5697 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5698 if (!g
->specific
->nopass
)
5701 po
= extract_compcall_passed_object (e
);
5705 gcc_assert (g
->specific
->pass_arg_num
> 0);
5706 gcc_assert (!g
->specific
->error
);
5707 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5708 g
->specific
->pass_arg
);
5710 resolve_actual_arglist (args
, target
->attr
.proc
,
5711 is_external_proc (target
) && !target
->formal
);
5713 /* Check if this arglist matches the formal. */
5714 matches
= gfc_arglist_matches_symbol (&args
, target
);
5716 /* Clean up and break out of the loop if we've found it. */
5717 gfc_free_actual_arglist (args
);
5720 e
->value
.compcall
.tbp
= g
->specific
;
5721 genname
= g
->specific_st
->name
;
5722 /* Pass along the name for CLASS methods, where the vtab
5723 procedure pointer component has to be referenced. */
5731 /* Nothing matching found! */
5732 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5733 " '%s' at %L", genname
, &e
->where
);
5737 /* Make sure that we have the right specific instance for the name. */
5738 derived
= get_declared_from_expr (NULL
, NULL
, e
);
5740 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5742 e
->value
.compcall
.tbp
= st
->n
.tb
;
5748 /* Resolve a call to a type-bound subroutine. */
5751 resolve_typebound_call (gfc_code
* c
, const char **name
)
5753 gfc_actual_arglist
* newactual
;
5754 gfc_symtree
* target
;
5756 /* Check that's really a SUBROUTINE. */
5757 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5759 gfc_error ("'%s' at %L should be a SUBROUTINE",
5760 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5764 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5767 /* Pass along the name for CLASS methods, where the vtab
5768 procedure pointer component has to be referenced. */
5770 *name
= c
->expr1
->value
.compcall
.name
;
5772 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5775 /* Transform into an ordinary EXEC_CALL for now. */
5777 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5780 c
->ext
.actual
= newactual
;
5781 c
->symtree
= target
;
5782 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5784 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5786 gfc_free_expr (c
->expr1
);
5787 c
->expr1
= gfc_get_expr ();
5788 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5789 c
->expr1
->symtree
= target
;
5790 c
->expr1
->where
= c
->loc
;
5792 return resolve_call (c
);
5796 /* Resolve a component-call expression. */
5798 resolve_compcall (gfc_expr
* e
, const char **name
)
5800 gfc_actual_arglist
* newactual
;
5801 gfc_symtree
* target
;
5803 /* Check that's really a FUNCTION. */
5804 if (!e
->value
.compcall
.tbp
->function
)
5806 gfc_error ("'%s' at %L should be a FUNCTION",
5807 e
->value
.compcall
.name
, &e
->where
);
5811 /* These must not be assign-calls! */
5812 gcc_assert (!e
->value
.compcall
.assign
);
5814 if (check_typebound_baseobject (e
) == FAILURE
)
5817 /* Pass along the name for CLASS methods, where the vtab
5818 procedure pointer component has to be referenced. */
5820 *name
= e
->value
.compcall
.name
;
5822 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5824 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5826 /* Take the rank from the function's symbol. */
5827 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5828 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5830 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5831 arglist to the TBP's binding target. */
5833 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5836 e
->value
.function
.actual
= newactual
;
5837 e
->value
.function
.name
= NULL
;
5838 e
->value
.function
.esym
= target
->n
.sym
;
5839 e
->value
.function
.isym
= NULL
;
5840 e
->symtree
= target
;
5841 e
->ts
= target
->n
.sym
->ts
;
5842 e
->expr_type
= EXPR_FUNCTION
;
5844 /* Resolution is not necessary if this is a class subroutine; this
5845 function only has to identify the specific proc. Resolution of
5846 the call will be done next in resolve_typebound_call. */
5847 return gfc_resolve_expr (e
);
5852 /* Resolve a typebound function, or 'method'. First separate all
5853 the non-CLASS references by calling resolve_compcall directly. */
5856 resolve_typebound_function (gfc_expr
* e
)
5858 gfc_symbol
*declared
;
5870 /* Deal with typebound operators for CLASS objects. */
5871 expr
= e
->value
.compcall
.base_object
;
5872 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5873 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5875 /* Since the typebound operators are generic, we have to ensure
5876 that any delays in resolution are corrected and that the vtab
5879 declared
= ts
.u
.derived
;
5880 c
= gfc_find_component (declared
, "_vptr", true, true);
5881 if (c
->ts
.u
.derived
== NULL
)
5882 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5884 if (resolve_compcall (e
, &name
) == FAILURE
)
5887 /* Use the generic name if it is there. */
5888 name
= name
? name
: e
->value
.function
.esym
->name
;
5889 e
->symtree
= expr
->symtree
;
5890 e
->ref
= gfc_copy_ref (expr
->ref
);
5891 gfc_add_vptr_component (e
);
5892 gfc_add_component_ref (e
, name
);
5893 e
->value
.function
.esym
= NULL
;
5898 return resolve_compcall (e
, NULL
);
5900 if (resolve_ref (e
) == FAILURE
)
5903 /* Get the CLASS declared type. */
5904 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
);
5906 /* Weed out cases of the ultimate component being a derived type. */
5907 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5908 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5910 gfc_free_ref_list (new_ref
);
5911 return resolve_compcall (e
, NULL
);
5914 c
= gfc_find_component (declared
, "_data", true, true);
5915 declared
= c
->ts
.u
.derived
;
5917 /* Treat the call as if it is a typebound procedure, in order to roll
5918 out the correct name for the specific function. */
5919 if (resolve_compcall (e
, &name
) == FAILURE
)
5925 /* Convert the expression to a procedure pointer component call. */
5926 e
->value
.function
.esym
= NULL
;
5932 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5933 gfc_add_vptr_component (e
);
5934 gfc_add_component_ref (e
, name
);
5936 /* Recover the typespec for the expression. This is really only
5937 necessary for generic procedures, where the additional call
5938 to gfc_add_component_ref seems to throw the collection of the
5939 correct typespec. */
5946 /* Resolve a typebound subroutine, or 'method'. First separate all
5947 the non-CLASS references by calling resolve_typebound_call
5951 resolve_typebound_subroutine (gfc_code
*code
)
5953 gfc_symbol
*declared
;
5963 st
= code
->expr1
->symtree
;
5965 /* Deal with typebound operators for CLASS objects. */
5966 expr
= code
->expr1
->value
.compcall
.base_object
;
5967 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5968 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5970 /* Since the typebound operators are generic, we have to ensure
5971 that any delays in resolution are corrected and that the vtab
5973 declared
= expr
->ts
.u
.derived
;
5974 c
= gfc_find_component (declared
, "_vptr", true, true);
5975 if (c
->ts
.u
.derived
== NULL
)
5976 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5978 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5981 /* Use the generic name if it is there. */
5982 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5983 code
->expr1
->symtree
= expr
->symtree
;
5984 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5985 gfc_add_vptr_component (code
->expr1
);
5986 gfc_add_component_ref (code
->expr1
, name
);
5987 code
->expr1
->value
.function
.esym
= NULL
;
5992 return resolve_typebound_call (code
, NULL
);
5994 if (resolve_ref (code
->expr1
) == FAILURE
)
5997 /* Get the CLASS declared type. */
5998 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
);
6000 /* Weed out cases of the ultimate component being a derived type. */
6001 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6002 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6004 gfc_free_ref_list (new_ref
);
6005 return resolve_typebound_call (code
, NULL
);
6008 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6010 ts
= code
->expr1
->ts
;
6014 /* Convert the expression to a procedure pointer component call. */
6015 code
->expr1
->value
.function
.esym
= NULL
;
6016 code
->expr1
->symtree
= st
;
6019 code
->expr1
->ref
= new_ref
;
6021 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6022 gfc_add_vptr_component (code
->expr1
);
6023 gfc_add_component_ref (code
->expr1
, name
);
6025 /* Recover the typespec for the expression. This is really only
6026 necessary for generic procedures, where the additional call
6027 to gfc_add_component_ref seems to throw the collection of the
6028 correct typespec. */
6029 code
->expr1
->ts
= ts
;
6036 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6039 resolve_ppc_call (gfc_code
* c
)
6041 gfc_component
*comp
;
6044 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6047 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6048 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6050 if (!comp
->attr
.subroutine
)
6051 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6053 if (resolve_ref (c
->expr1
) == FAILURE
)
6056 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6059 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6061 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6062 comp
->formal
== NULL
) == FAILURE
)
6065 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6071 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6074 resolve_expr_ppc (gfc_expr
* e
)
6076 gfc_component
*comp
;
6079 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6082 /* Convert to EXPR_FUNCTION. */
6083 e
->expr_type
= EXPR_FUNCTION
;
6084 e
->value
.function
.isym
= NULL
;
6085 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6087 if (comp
->as
!= NULL
)
6088 e
->rank
= comp
->as
->rank
;
6090 if (!comp
->attr
.function
)
6091 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6093 if (resolve_ref (e
) == FAILURE
)
6096 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6097 comp
->formal
== NULL
) == FAILURE
)
6100 if (update_ppc_arglist (e
) == FAILURE
)
6103 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6110 gfc_is_expandable_expr (gfc_expr
*e
)
6112 gfc_constructor
*con
;
6114 if (e
->expr_type
== EXPR_ARRAY
)
6116 /* Traverse the constructor looking for variables that are flavor
6117 parameter. Parameters must be expanded since they are fully used at
6119 con
= gfc_constructor_first (e
->value
.constructor
);
6120 for (; con
; con
= gfc_constructor_next (con
))
6122 if (con
->expr
->expr_type
== EXPR_VARIABLE
6123 && con
->expr
->symtree
6124 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6125 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6127 if (con
->expr
->expr_type
== EXPR_ARRAY
6128 && gfc_is_expandable_expr (con
->expr
))
6136 /* Resolve an expression. That is, make sure that types of operands agree
6137 with their operators, intrinsic operators are converted to function calls
6138 for overloaded types and unresolved function references are resolved. */
6141 gfc_resolve_expr (gfc_expr
*e
)
6149 /* inquiry_argument only applies to variables. */
6150 inquiry_save
= inquiry_argument
;
6151 if (e
->expr_type
!= EXPR_VARIABLE
)
6152 inquiry_argument
= false;
6154 switch (e
->expr_type
)
6157 t
= resolve_operator (e
);
6163 if (check_host_association (e
))
6164 t
= resolve_function (e
);
6167 t
= resolve_variable (e
);
6169 expression_rank (e
);
6172 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6173 && e
->ref
->type
!= REF_SUBSTRING
)
6174 gfc_resolve_substring_charlen (e
);
6179 t
= resolve_typebound_function (e
);
6182 case EXPR_SUBSTRING
:
6183 t
= resolve_ref (e
);
6192 t
= resolve_expr_ppc (e
);
6197 if (resolve_ref (e
) == FAILURE
)
6200 t
= gfc_resolve_array_constructor (e
);
6201 /* Also try to expand a constructor. */
6204 expression_rank (e
);
6205 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6206 gfc_expand_constructor (e
, false);
6209 /* This provides the opportunity for the length of constructors with
6210 character valued function elements to propagate the string length
6211 to the expression. */
6212 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6214 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6215 here rather then add a duplicate test for it above. */
6216 gfc_expand_constructor (e
, false);
6217 t
= gfc_resolve_character_array_constructor (e
);
6222 case EXPR_STRUCTURE
:
6223 t
= resolve_ref (e
);
6227 t
= resolve_structure_cons (e
, 0);
6231 t
= gfc_simplify_expr (e
, 0);
6235 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6238 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6241 inquiry_argument
= inquiry_save
;
6247 /* Resolve an expression from an iterator. They must be scalar and have
6248 INTEGER or (optionally) REAL type. */
6251 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6252 const char *name_msgid
)
6254 if (gfc_resolve_expr (expr
) == FAILURE
)
6257 if (expr
->rank
!= 0)
6259 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6263 if (expr
->ts
.type
!= BT_INTEGER
)
6265 if (expr
->ts
.type
== BT_REAL
)
6268 return gfc_notify_std (GFC_STD_F95_DEL
,
6269 "Deleted feature: %s at %L must be integer",
6270 _(name_msgid
), &expr
->where
);
6273 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6280 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6288 /* Resolve the expressions in an iterator structure. If REAL_OK is
6289 false allow only INTEGER type iterators, otherwise allow REAL types. */
6292 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6294 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6298 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6302 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6303 "Start expression in DO loop") == FAILURE
)
6306 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6307 "End expression in DO loop") == FAILURE
)
6310 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6311 "Step expression in DO loop") == FAILURE
)
6314 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6316 if ((iter
->step
->ts
.type
== BT_INTEGER
6317 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6318 || (iter
->step
->ts
.type
== BT_REAL
6319 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6321 gfc_error ("Step expression in DO loop at %L cannot be zero",
6322 &iter
->step
->where
);
6327 /* Convert start, end, and step to the same type as var. */
6328 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6329 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6330 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6332 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6333 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6334 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6336 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6337 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6338 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6340 if (iter
->start
->expr_type
== EXPR_CONSTANT
6341 && iter
->end
->expr_type
== EXPR_CONSTANT
6342 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6345 if (iter
->start
->ts
.type
== BT_INTEGER
)
6347 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6348 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6352 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6353 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6355 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6356 gfc_warning ("DO loop at %L will be executed zero times",
6357 &iter
->step
->where
);
6364 /* Traversal function for find_forall_index. f == 2 signals that
6365 that variable itself is not to be checked - only the references. */
6368 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6370 if (expr
->expr_type
!= EXPR_VARIABLE
)
6373 /* A scalar assignment */
6374 if (!expr
->ref
|| *f
== 1)
6376 if (expr
->symtree
->n
.sym
== sym
)
6388 /* Check whether the FORALL index appears in the expression or not.
6389 Returns SUCCESS if SYM is found in EXPR. */
6392 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6394 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6401 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6402 to be a scalar INTEGER variable. The subscripts and stride are scalar
6403 INTEGERs, and if stride is a constant it must be nonzero.
6404 Furthermore "A subscript or stride in a forall-triplet-spec shall
6405 not contain a reference to any index-name in the
6406 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6409 resolve_forall_iterators (gfc_forall_iterator
*it
)
6411 gfc_forall_iterator
*iter
, *iter2
;
6413 for (iter
= it
; iter
; iter
= iter
->next
)
6415 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6416 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6417 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6420 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6421 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6422 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6423 &iter
->start
->where
);
6424 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6425 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6427 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6428 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6429 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6431 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6432 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6434 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6436 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6437 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6438 &iter
->stride
->where
, "INTEGER");
6440 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6441 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6442 gfc_error ("FORALL stride expression at %L cannot be zero",
6443 &iter
->stride
->where
);
6445 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6446 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6449 for (iter
= it
; iter
; iter
= iter
->next
)
6450 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6452 if (find_forall_index (iter2
->start
,
6453 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6454 || find_forall_index (iter2
->end
,
6455 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6456 || find_forall_index (iter2
->stride
,
6457 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6458 gfc_error ("FORALL index '%s' may not appear in triplet "
6459 "specification at %L", iter
->var
->symtree
->name
,
6460 &iter2
->start
->where
);
6465 /* Given a pointer to a symbol that is a derived type, see if it's
6466 inaccessible, i.e. if it's defined in another module and the components are
6467 PRIVATE. The search is recursive if necessary. Returns zero if no
6468 inaccessible components are found, nonzero otherwise. */
6471 derived_inaccessible (gfc_symbol
*sym
)
6475 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6478 for (c
= sym
->components
; c
; c
= c
->next
)
6480 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6488 /* Resolve the argument of a deallocate expression. The expression must be
6489 a pointer or a full array. */
6492 resolve_deallocate_expr (gfc_expr
*e
)
6494 symbol_attribute attr
;
6495 int allocatable
, pointer
;
6500 if (gfc_resolve_expr (e
) == FAILURE
)
6503 if (e
->expr_type
!= EXPR_VARIABLE
)
6506 sym
= e
->symtree
->n
.sym
;
6508 if (sym
->ts
.type
== BT_CLASS
)
6510 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6511 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6515 allocatable
= sym
->attr
.allocatable
;
6516 pointer
= sym
->attr
.pointer
;
6518 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6523 if (ref
->u
.ar
.type
!= AR_FULL
6524 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6525 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6530 c
= ref
->u
.c
.component
;
6531 if (c
->ts
.type
== BT_CLASS
)
6533 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6534 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6538 allocatable
= c
->attr
.allocatable
;
6539 pointer
= c
->attr
.pointer
;
6549 attr
= gfc_expr_attr (e
);
6551 if (allocatable
== 0 && attr
.pointer
== 0)
6554 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6560 if (gfc_is_coindexed (e
))
6562 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6567 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6570 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6578 /* Returns true if the expression e contains a reference to the symbol sym. */
6580 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6582 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6589 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6591 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6595 /* Given the expression node e for an allocatable/pointer of derived type to be
6596 allocated, get the expression node to be initialized afterwards (needed for
6597 derived types with default initializers, and derived types with allocatable
6598 components that need nullification.) */
6601 gfc_expr_to_initialize (gfc_expr
*e
)
6607 result
= gfc_copy_expr (e
);
6609 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6610 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6611 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6613 ref
->u
.ar
.type
= AR_FULL
;
6615 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6616 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6621 gfc_free_shape (&result
->shape
, result
->rank
);
6623 /* Recalculate rank, shape, etc. */
6624 gfc_resolve_expr (result
);
6629 /* If the last ref of an expression is an array ref, return a copy of the
6630 expression with that one removed. Otherwise, a copy of the original
6631 expression. This is used for allocate-expressions and pointer assignment
6632 LHS, where there may be an array specification that needs to be stripped
6633 off when using gfc_check_vardef_context. */
6636 remove_last_array_ref (gfc_expr
* e
)
6641 e2
= gfc_copy_expr (e
);
6642 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6643 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6645 gfc_free_ref_list (*r
);
6654 /* Used in resolve_allocate_expr to check that a allocation-object and
6655 a source-expr are conformable. This does not catch all possible
6656 cases; in particular a runtime checking is needed. */
6659 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6662 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6664 /* First compare rank. */
6665 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6667 gfc_error ("Source-expr at %L must be scalar or have the "
6668 "same rank as the allocate-object at %L",
6669 &e1
->where
, &e2
->where
);
6680 for (i
= 0; i
< e1
->rank
; i
++)
6682 if (tail
->u
.ar
.end
[i
])
6684 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6685 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6686 mpz_add_ui (s
, s
, 1);
6690 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6693 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6695 gfc_error ("Source-expr at %L and allocate-object at %L must "
6696 "have the same shape", &e1
->where
, &e2
->where
);
6709 /* Resolve the expression in an ALLOCATE statement, doing the additional
6710 checks to see whether the expression is OK or not. The expression must
6711 have a trailing array reference that gives the size of the array. */
6714 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6716 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6719 symbol_attribute attr
;
6720 gfc_ref
*ref
, *ref2
;
6723 gfc_symbol
*sym
= NULL
;
6728 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6729 checking of coarrays. */
6730 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6731 if (ref
->next
== NULL
)
6734 if (ref
&& ref
->type
== REF_ARRAY
)
6735 ref
->u
.ar
.in_allocate
= true;
6737 if (gfc_resolve_expr (e
) == FAILURE
)
6740 /* Make sure the expression is allocatable or a pointer. If it is
6741 pointer, the next-to-last reference must be a pointer. */
6745 sym
= e
->symtree
->n
.sym
;
6747 /* Check whether ultimate component is abstract and CLASS. */
6750 if (e
->expr_type
!= EXPR_VARIABLE
)
6753 attr
= gfc_expr_attr (e
);
6754 pointer
= attr
.pointer
;
6755 dimension
= attr
.dimension
;
6756 codimension
= attr
.codimension
;
6760 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6762 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6763 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6764 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6765 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6766 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6770 allocatable
= sym
->attr
.allocatable
;
6771 pointer
= sym
->attr
.pointer
;
6772 dimension
= sym
->attr
.dimension
;
6773 codimension
= sym
->attr
.codimension
;
6778 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6783 if (ref
->u
.ar
.codimen
> 0)
6786 for (n
= ref
->u
.ar
.dimen
;
6787 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6788 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6795 if (ref
->next
!= NULL
)
6803 gfc_error ("Coindexed allocatable object at %L",
6808 c
= ref
->u
.c
.component
;
6809 if (c
->ts
.type
== BT_CLASS
)
6811 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6812 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6813 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6814 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6815 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6819 allocatable
= c
->attr
.allocatable
;
6820 pointer
= c
->attr
.pointer
;
6821 dimension
= c
->attr
.dimension
;
6822 codimension
= c
->attr
.codimension
;
6823 is_abstract
= c
->attr
.abstract
;
6835 if (allocatable
== 0 && pointer
== 0)
6837 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6842 /* Some checks for the SOURCE tag. */
6845 /* Check F03:C631. */
6846 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6848 gfc_error ("Type of entity at %L is type incompatible with "
6849 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6853 /* Check F03:C632 and restriction following Note 6.18. */
6854 if (code
->expr3
->rank
> 0
6855 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
6858 /* Check F03:C633. */
6859 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
6861 gfc_error ("The allocate-object at %L and the source-expr at %L "
6862 "shall have the same kind type parameter",
6863 &e
->where
, &code
->expr3
->where
);
6867 /* Check F2008, C642. */
6868 if (code
->expr3
->ts
.type
== BT_DERIVED
6869 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6870 || (code
->expr3
->ts
.u
.derived
->from_intmod
6871 == INTMOD_ISO_FORTRAN_ENV
6872 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6873 == ISOFORTRAN_LOCK_TYPE
)))
6875 gfc_error ("The source-expr at %L shall neither be of type "
6876 "LOCK_TYPE nor have a LOCK_TYPE component if "
6877 "allocate-object at %L is a coarray",
6878 &code
->expr3
->where
, &e
->where
);
6883 /* Check F08:C629. */
6884 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6887 gcc_assert (e
->ts
.type
== BT_CLASS
);
6888 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6889 "type-spec or source-expr", sym
->name
, &e
->where
);
6893 /* In the variable definition context checks, gfc_expr_attr is used
6894 on the expression. This is fooled by the array specification
6895 present in e, thus we have to eliminate that one temporarily. */
6896 e2
= remove_last_array_ref (e
);
6898 if (t
== SUCCESS
&& pointer
)
6899 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
6901 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
6906 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6907 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6909 /* For class arrays, the initialization with SOURCE is done
6910 using _copy and trans_call. It is convenient to exploit that
6911 when the allocated type is different from the declared type but
6912 no SOURCE exists by setting expr3. */
6913 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6915 else if (!code
->expr3
)
6917 /* Set up default initializer if needed. */
6921 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6922 ts
= code
->ext
.alloc
.ts
;
6926 if (ts
.type
== BT_CLASS
)
6927 ts
= ts
.u
.derived
->components
->ts
;
6929 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6931 gfc_code
*init_st
= gfc_get_code ();
6932 init_st
->loc
= code
->loc
;
6933 init_st
->op
= EXEC_INIT_ASSIGN
;
6934 init_st
->expr1
= gfc_expr_to_initialize (e
);
6935 init_st
->expr2
= init_e
;
6936 init_st
->next
= code
->next
;
6937 code
->next
= init_st
;
6940 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6942 /* Default initialization via MOLD (non-polymorphic). */
6943 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6944 gfc_resolve_expr (rhs
);
6945 gfc_free_expr (code
->expr3
);
6949 if (e
->ts
.type
== BT_CLASS
)
6951 /* Make sure the vtab symbol is present when
6952 the module variables are generated. */
6953 gfc_typespec ts
= e
->ts
;
6955 ts
= code
->expr3
->ts
;
6956 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6957 ts
= code
->ext
.alloc
.ts
;
6958 gfc_find_derived_vtab (ts
.u
.derived
);
6960 e
= gfc_expr_to_initialize (e
);
6963 if (dimension
== 0 && codimension
== 0)
6966 /* Make sure the last reference node is an array specifiction. */
6968 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6969 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6971 gfc_error ("Array specification required in ALLOCATE statement "
6972 "at %L", &e
->where
);
6976 /* Make sure that the array section reference makes sense in the
6977 context of an ALLOCATE specification. */
6982 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6983 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6985 gfc_error ("Coarray specification required in ALLOCATE statement "
6986 "at %L", &e
->where
);
6990 for (i
= 0; i
< ar
->dimen
; i
++)
6992 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6995 switch (ar
->dimen_type
[i
])
7001 if (ar
->start
[i
] != NULL
7002 && ar
->end
[i
] != NULL
7003 && ar
->stride
[i
] == NULL
)
7006 /* Fall Through... */
7011 case DIMEN_THIS_IMAGE
:
7012 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7018 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7020 sym
= a
->expr
->symtree
->n
.sym
;
7022 /* TODO - check derived type components. */
7023 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7026 if ((ar
->start
[i
] != NULL
7027 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7028 || (ar
->end
[i
] != NULL
7029 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7031 gfc_error ("'%s' must not appear in the array specification at "
7032 "%L in the same ALLOCATE statement where it is "
7033 "itself allocated", sym
->name
, &ar
->where
);
7039 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7041 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7042 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7044 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7046 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7047 "statement at %L", &e
->where
);
7053 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7054 && ar
->stride
[i
] == NULL
)
7057 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7070 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7072 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7073 gfc_alloc
*a
, *p
, *q
;
7076 errmsg
= code
->expr2
;
7078 /* Check the stat variable. */
7081 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7083 if ((stat
->ts
.type
!= BT_INTEGER
7084 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7085 || stat
->ref
->type
== REF_COMPONENT
)))
7087 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7088 "variable", &stat
->where
);
7090 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7091 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7093 gfc_ref
*ref1
, *ref2
;
7096 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7097 ref1
= ref1
->next
, ref2
= ref2
->next
)
7099 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7101 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7110 gfc_error ("Stat-variable at %L shall not be %sd within "
7111 "the same %s statement", &stat
->where
, fcn
, fcn
);
7117 /* Check the errmsg variable. */
7121 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7124 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7126 if ((errmsg
->ts
.type
!= BT_CHARACTER
7128 && (errmsg
->ref
->type
== REF_ARRAY
7129 || errmsg
->ref
->type
== REF_COMPONENT
)))
7130 || errmsg
->rank
> 0 )
7131 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7132 "variable", &errmsg
->where
);
7134 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7135 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7137 gfc_ref
*ref1
, *ref2
;
7140 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7141 ref1
= ref1
->next
, ref2
= ref2
->next
)
7143 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7145 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7154 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7155 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7161 /* Check that an allocate-object appears only once in the statement.
7162 FIXME: Checking derived types is disabled. */
7163 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7166 for (q
= p
->next
; q
; q
= q
->next
)
7169 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7171 /* This is a potential collision. */
7172 gfc_ref
*pr
= pe
->ref
;
7173 gfc_ref
*qr
= qe
->ref
;
7175 /* Follow the references until
7176 a) They start to differ, in which case there is no error;
7177 you can deallocate a%b and a%c in a single statement
7178 b) Both of them stop, which is an error
7179 c) One of them stops, which is also an error. */
7182 if (pr
== NULL
&& qr
== NULL
)
7184 gfc_error ("Allocate-object at %L also appears at %L",
7185 &pe
->where
, &qe
->where
);
7188 else if (pr
!= NULL
&& qr
== NULL
)
7190 gfc_error ("Allocate-object at %L is subobject of"
7191 " object at %L", &pe
->where
, &qe
->where
);
7194 else if (pr
== NULL
&& qr
!= NULL
)
7196 gfc_error ("Allocate-object at %L is subobject of"
7197 " object at %L", &qe
->where
, &pe
->where
);
7200 /* Here, pr != NULL && qr != NULL */
7201 gcc_assert(pr
->type
== qr
->type
);
7202 if (pr
->type
== REF_ARRAY
)
7204 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7206 gcc_assert (qr
->type
== REF_ARRAY
);
7208 if (pr
->next
&& qr
->next
)
7210 gfc_array_ref
*par
= &(pr
->u
.ar
);
7211 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7212 if (gfc_dep_compare_expr (par
->start
[0],
7213 qar
->start
[0]) != 0)
7219 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7230 if (strcmp (fcn
, "ALLOCATE") == 0)
7232 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7233 resolve_allocate_expr (a
->expr
, code
);
7237 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7238 resolve_deallocate_expr (a
->expr
);
7243 /************ SELECT CASE resolution subroutines ************/
7245 /* Callback function for our mergesort variant. Determines interval
7246 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7247 op1 > op2. Assumes we're not dealing with the default case.
7248 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7249 There are nine situations to check. */
7252 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7256 if (op1
->low
== NULL
) /* op1 = (:L) */
7258 /* op2 = (:N), so overlap. */
7260 /* op2 = (M:) or (M:N), L < M */
7261 if (op2
->low
!= NULL
7262 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7265 else if (op1
->high
== NULL
) /* op1 = (K:) */
7267 /* op2 = (M:), so overlap. */
7269 /* op2 = (:N) or (M:N), K > N */
7270 if (op2
->high
!= NULL
7271 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7274 else /* op1 = (K:L) */
7276 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7277 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7279 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7280 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7282 else /* op2 = (M:N) */
7286 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7289 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7298 /* Merge-sort a double linked case list, detecting overlap in the
7299 process. LIST is the head of the double linked case list before it
7300 is sorted. Returns the head of the sorted list if we don't see any
7301 overlap, or NULL otherwise. */
7304 check_case_overlap (gfc_case
*list
)
7306 gfc_case
*p
, *q
, *e
, *tail
;
7307 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7309 /* If the passed list was empty, return immediately. */
7316 /* Loop unconditionally. The only exit from this loop is a return
7317 statement, when we've finished sorting the case list. */
7324 /* Count the number of merges we do in this pass. */
7327 /* Loop while there exists a merge to be done. */
7332 /* Count this merge. */
7335 /* Cut the list in two pieces by stepping INSIZE places
7336 forward in the list, starting from P. */
7339 for (i
= 0; i
< insize
; i
++)
7348 /* Now we have two lists. Merge them! */
7349 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7351 /* See from which the next case to merge comes from. */
7354 /* P is empty so the next case must come from Q. */
7359 else if (qsize
== 0 || q
== NULL
)
7368 cmp
= compare_cases (p
, q
);
7371 /* The whole case range for P is less than the
7379 /* The whole case range for Q is greater than
7380 the case range for P. */
7387 /* The cases overlap, or they are the same
7388 element in the list. Either way, we must
7389 issue an error and get the next case from P. */
7390 /* FIXME: Sort P and Q by line number. */
7391 gfc_error ("CASE label at %L overlaps with CASE "
7392 "label at %L", &p
->where
, &q
->where
);
7400 /* Add the next element to the merged list. */
7409 /* P has now stepped INSIZE places along, and so has Q. So
7410 they're the same. */
7415 /* If we have done only one merge or none at all, we've
7416 finished sorting the cases. */
7425 /* Otherwise repeat, merging lists twice the size. */
7431 /* Check to see if an expression is suitable for use in a CASE statement.
7432 Makes sure that all case expressions are scalar constants of the same
7433 type. Return FAILURE if anything is wrong. */
7436 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7438 if (e
== NULL
) return SUCCESS
;
7440 if (e
->ts
.type
!= case_expr
->ts
.type
)
7442 gfc_error ("Expression in CASE statement at %L must be of type %s",
7443 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7447 /* C805 (R808) For a given case-construct, each case-value shall be of
7448 the same type as case-expr. For character type, length differences
7449 are allowed, but the kind type parameters shall be the same. */
7451 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7453 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7454 &e
->where
, case_expr
->ts
.kind
);
7458 /* Convert the case value kind to that of case expression kind,
7461 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7462 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7466 gfc_error ("Expression in CASE statement at %L must be scalar",
7475 /* Given a completely parsed select statement, we:
7477 - Validate all expressions and code within the SELECT.
7478 - Make sure that the selection expression is not of the wrong type.
7479 - Make sure that no case ranges overlap.
7480 - Eliminate unreachable cases and unreachable code resulting from
7481 removing case labels.
7483 The standard does allow unreachable cases, e.g. CASE (5:3). But
7484 they are a hassle for code generation, and to prevent that, we just
7485 cut them out here. This is not necessary for overlapping cases
7486 because they are illegal and we never even try to generate code.
7488 We have the additional caveat that a SELECT construct could have
7489 been a computed GOTO in the source code. Fortunately we can fairly
7490 easily work around that here: The case_expr for a "real" SELECT CASE
7491 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7492 we have to do is make sure that the case_expr is a scalar integer
7496 resolve_select (gfc_code
*code
)
7499 gfc_expr
*case_expr
;
7500 gfc_case
*cp
, *default_case
, *tail
, *head
;
7501 int seen_unreachable
;
7507 if (code
->expr1
== NULL
)
7509 /* This was actually a computed GOTO statement. */
7510 case_expr
= code
->expr2
;
7511 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7512 gfc_error ("Selection expression in computed GOTO statement "
7513 "at %L must be a scalar integer expression",
7516 /* Further checking is not necessary because this SELECT was built
7517 by the compiler, so it should always be OK. Just move the
7518 case_expr from expr2 to expr so that we can handle computed
7519 GOTOs as normal SELECTs from here on. */
7520 code
->expr1
= code
->expr2
;
7525 case_expr
= code
->expr1
;
7527 type
= case_expr
->ts
.type
;
7528 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7530 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7531 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7533 /* Punt. Going on here just produce more garbage error messages. */
7537 /* Raise a warning if an INTEGER case value exceeds the range of
7538 the case-expr. Later, all expressions will be promoted to the
7539 largest kind of all case-labels. */
7541 if (type
== BT_INTEGER
)
7542 for (body
= code
->block
; body
; body
= body
->block
)
7543 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7546 && gfc_check_integer_range (cp
->low
->value
.integer
,
7547 case_expr
->ts
.kind
) != ARITH_OK
)
7548 gfc_warning ("Expression in CASE statement at %L is "
7549 "not in the range of %s", &cp
->low
->where
,
7550 gfc_typename (&case_expr
->ts
));
7553 && cp
->low
!= cp
->high
7554 && gfc_check_integer_range (cp
->high
->value
.integer
,
7555 case_expr
->ts
.kind
) != ARITH_OK
)
7556 gfc_warning ("Expression in CASE statement at %L is "
7557 "not in the range of %s", &cp
->high
->where
,
7558 gfc_typename (&case_expr
->ts
));
7561 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7562 of the SELECT CASE expression and its CASE values. Walk the lists
7563 of case values, and if we find a mismatch, promote case_expr to
7564 the appropriate kind. */
7566 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7568 for (body
= code
->block
; body
; body
= body
->block
)
7570 /* Walk the case label list. */
7571 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7573 /* Intercept the DEFAULT case. It does not have a kind. */
7574 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7577 /* Unreachable case ranges are discarded, so ignore. */
7578 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7579 && cp
->low
!= cp
->high
7580 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7584 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7585 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7587 if (cp
->high
!= NULL
7588 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7589 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7594 /* Assume there is no DEFAULT case. */
7595 default_case
= NULL
;
7600 for (body
= code
->block
; body
; body
= body
->block
)
7602 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7604 seen_unreachable
= 0;
7606 /* Walk the case label list, making sure that all case labels
7608 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7610 /* Count the number of cases in the whole construct. */
7613 /* Intercept the DEFAULT case. */
7614 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7616 if (default_case
!= NULL
)
7618 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7619 "by a second DEFAULT CASE at %L",
7620 &default_case
->where
, &cp
->where
);
7631 /* Deal with single value cases and case ranges. Errors are
7632 issued from the validation function. */
7633 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7634 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7640 if (type
== BT_LOGICAL
7641 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7642 || cp
->low
!= cp
->high
))
7644 gfc_error ("Logical range in CASE statement at %L is not "
7645 "allowed", &cp
->low
->where
);
7650 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7653 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7654 if (value
& seen_logical
)
7656 gfc_error ("Constant logical value in CASE statement "
7657 "is repeated at %L",
7662 seen_logical
|= value
;
7665 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7666 && cp
->low
!= cp
->high
7667 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7669 if (gfc_option
.warn_surprising
)
7670 gfc_warning ("Range specification at %L can never "
7671 "be matched", &cp
->where
);
7673 cp
->unreachable
= 1;
7674 seen_unreachable
= 1;
7678 /* If the case range can be matched, it can also overlap with
7679 other cases. To make sure it does not, we put it in a
7680 double linked list here. We sort that with a merge sort
7681 later on to detect any overlapping cases. */
7685 head
->right
= head
->left
= NULL
;
7690 tail
->right
->left
= tail
;
7697 /* It there was a failure in the previous case label, give up
7698 for this case label list. Continue with the next block. */
7702 /* See if any case labels that are unreachable have been seen.
7703 If so, we eliminate them. This is a bit of a kludge because
7704 the case lists for a single case statement (label) is a
7705 single forward linked lists. */
7706 if (seen_unreachable
)
7708 /* Advance until the first case in the list is reachable. */
7709 while (body
->ext
.block
.case_list
!= NULL
7710 && body
->ext
.block
.case_list
->unreachable
)
7712 gfc_case
*n
= body
->ext
.block
.case_list
;
7713 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7715 gfc_free_case_list (n
);
7718 /* Strip all other unreachable cases. */
7719 if (body
->ext
.block
.case_list
)
7721 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7723 if (cp
->next
->unreachable
)
7725 gfc_case
*n
= cp
->next
;
7726 cp
->next
= cp
->next
->next
;
7728 gfc_free_case_list (n
);
7735 /* See if there were overlapping cases. If the check returns NULL,
7736 there was overlap. In that case we don't do anything. If head
7737 is non-NULL, we prepend the DEFAULT case. The sorted list can
7738 then used during code generation for SELECT CASE constructs with
7739 a case expression of a CHARACTER type. */
7742 head
= check_case_overlap (head
);
7744 /* Prepend the default_case if it is there. */
7745 if (head
!= NULL
&& default_case
)
7747 default_case
->left
= NULL
;
7748 default_case
->right
= head
;
7749 head
->left
= default_case
;
7753 /* Eliminate dead blocks that may be the result if we've seen
7754 unreachable case labels for a block. */
7755 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7757 if (body
->block
->ext
.block
.case_list
== NULL
)
7759 /* Cut the unreachable block from the code chain. */
7760 gfc_code
*c
= body
->block
;
7761 body
->block
= c
->block
;
7763 /* Kill the dead block, but not the blocks below it. */
7765 gfc_free_statements (c
);
7769 /* More than two cases is legal but insane for logical selects.
7770 Issue a warning for it. */
7771 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7773 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7778 /* Check if a derived type is extensible. */
7781 gfc_type_is_extensible (gfc_symbol
*sym
)
7783 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7787 /* Resolve an associate name: Resolve target and ensure the type-spec is
7788 correct as well as possibly the array-spec. */
7791 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7795 gcc_assert (sym
->assoc
);
7796 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7798 /* If this is for SELECT TYPE, the target may not yet be set. In that
7799 case, return. Resolution will be called later manually again when
7801 target
= sym
->assoc
->target
;
7804 gcc_assert (!sym
->assoc
->dangling
);
7806 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7809 /* For variable targets, we get some attributes from the target. */
7810 if (target
->expr_type
== EXPR_VARIABLE
)
7814 gcc_assert (target
->symtree
);
7815 tsym
= target
->symtree
->n
.sym
;
7817 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7818 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7820 if (tsym
->ts
.type
== BT_CLASS
)
7821 sym
->attr
.target
= tsym
->attr
.target
|| CLASS_DATA (tsym
)->attr
.pointer
;
7823 sym
->attr
.target
= tsym
->attr
.target
|| tsym
->attr
.pointer
;
7825 if (sym
->ts
.type
== BT_DERIVED
&& tsym
->ts
.type
== BT_CLASS
)
7826 target
->rank
= sym
->as
? sym
->as
->rank
: 0;
7829 /* Get type if this was not already set. Note that it can be
7830 some other type than the target in case this is a SELECT TYPE
7831 selector! So we must not update when the type is already there. */
7832 if (sym
->ts
.type
== BT_UNKNOWN
)
7833 sym
->ts
= target
->ts
;
7834 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7836 /* See if this is a valid association-to-variable. */
7837 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7838 && !gfc_has_vector_subscript (target
));
7840 /* Finally resolve if this is an array or not. */
7841 if (sym
->attr
.dimension
7842 && (target
->ts
.type
== BT_CLASS
7843 ? !CLASS_DATA (target
)->attr
.dimension
7844 : target
->rank
== 0))
7846 gfc_error ("Associate-name '%s' at %L is used as array",
7847 sym
->name
, &sym
->declared_at
);
7848 sym
->attr
.dimension
= 0;
7851 if (target
->rank
> 0)
7852 sym
->attr
.dimension
= 1;
7854 if (sym
->attr
.dimension
)
7856 sym
->as
= gfc_get_array_spec ();
7857 sym
->as
->rank
= target
->rank
;
7858 sym
->as
->type
= AS_DEFERRED
;
7860 /* Target must not be coindexed, thus the associate-variable
7862 sym
->as
->corank
= 0;
7867 /* Resolve a SELECT TYPE statement. */
7870 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7872 gfc_symbol
*selector_type
;
7873 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7874 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7877 char name
[GFC_MAX_SYMBOL_LEN
];
7881 ns
= code
->ext
.block
.ns
;
7884 /* Check for F03:C813. */
7885 if (code
->expr1
->ts
.type
!= BT_CLASS
7886 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7888 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7889 "at %L", &code
->loc
);
7893 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7898 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7899 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7900 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7903 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7905 /* Loop over TYPE IS / CLASS IS cases. */
7906 for (body
= code
->block
; body
; body
= body
->block
)
7908 c
= body
->ext
.block
.case_list
;
7910 /* Check F03:C815. */
7911 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7912 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7914 gfc_error ("Derived type '%s' at %L must be extensible",
7915 c
->ts
.u
.derived
->name
, &c
->where
);
7920 /* Check F03:C816. */
7921 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7922 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
7924 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7925 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7930 /* Intercept the DEFAULT case. */
7931 if (c
->ts
.type
== BT_UNKNOWN
)
7933 /* Check F03:C818. */
7936 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7937 "by a second DEFAULT CASE at %L",
7938 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7943 default_case
= body
;
7950 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7951 target if present. If there are any EXIT statements referring to the
7952 SELECT TYPE construct, this is no problem because the gfc_code
7953 reference stays the same and EXIT is equally possible from the BLOCK
7954 it is changed to. */
7955 code
->op
= EXEC_BLOCK
;
7958 gfc_association_list
* assoc
;
7960 assoc
= gfc_get_association_list ();
7961 assoc
->st
= code
->expr1
->symtree
;
7962 assoc
->target
= gfc_copy_expr (code
->expr2
);
7963 assoc
->target
->where
= code
->expr2
->where
;
7964 /* assoc->variable will be set by resolve_assoc_var. */
7966 code
->ext
.block
.assoc
= assoc
;
7967 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
7969 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
7972 code
->ext
.block
.assoc
= NULL
;
7974 /* Add EXEC_SELECT to switch on type. */
7975 new_st
= gfc_get_code ();
7976 new_st
->op
= code
->op
;
7977 new_st
->expr1
= code
->expr1
;
7978 new_st
->expr2
= code
->expr2
;
7979 new_st
->block
= code
->block
;
7980 code
->expr1
= code
->expr2
= NULL
;
7985 ns
->code
->next
= new_st
;
7987 code
->op
= EXEC_SELECT
;
7988 gfc_add_vptr_component (code
->expr1
);
7989 gfc_add_hash_component (code
->expr1
);
7991 /* Loop over TYPE IS / CLASS IS cases. */
7992 for (body
= code
->block
; body
; body
= body
->block
)
7994 c
= body
->ext
.block
.case_list
;
7996 if (c
->ts
.type
== BT_DERIVED
)
7997 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7998 c
->ts
.u
.derived
->hash_value
);
8000 else if (c
->ts
.type
== BT_UNKNOWN
)
8003 /* Associate temporary to selector. This should only be done
8004 when this case is actually true, so build a new ASSOCIATE
8005 that does precisely this here (instead of using the
8008 if (c
->ts
.type
== BT_CLASS
)
8009 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8011 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8012 st
= gfc_find_symtree (ns
->sym_root
, name
);
8013 gcc_assert (st
->n
.sym
->assoc
);
8014 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8015 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8016 if (c
->ts
.type
== BT_DERIVED
)
8017 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8019 new_st
= gfc_get_code ();
8020 new_st
->op
= EXEC_BLOCK
;
8021 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8022 new_st
->ext
.block
.ns
->code
= body
->next
;
8023 body
->next
= new_st
;
8025 /* Chain in the new list only if it is marked as dangling. Otherwise
8026 there is a CASE label overlap and this is already used. Just ignore,
8027 the error is diagonsed elsewhere. */
8028 if (st
->n
.sym
->assoc
->dangling
)
8030 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8031 st
->n
.sym
->assoc
->dangling
= 0;
8034 resolve_assoc_var (st
->n
.sym
, false);
8037 /* Take out CLASS IS cases for separate treatment. */
8039 while (body
&& body
->block
)
8041 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8043 /* Add to class_is list. */
8044 if (class_is
== NULL
)
8046 class_is
= body
->block
;
8051 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8052 tail
->block
= body
->block
;
8055 /* Remove from EXEC_SELECT list. */
8056 body
->block
= body
->block
->block
;
8069 /* Add a default case to hold the CLASS IS cases. */
8070 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8071 tail
->block
= gfc_get_code ();
8073 tail
->op
= EXEC_SELECT_TYPE
;
8074 tail
->ext
.block
.case_list
= gfc_get_case ();
8075 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8077 default_case
= tail
;
8080 /* More than one CLASS IS block? */
8081 if (class_is
->block
)
8085 /* Sort CLASS IS blocks by extension level. */
8089 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8092 /* F03:C817 (check for doubles). */
8093 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8094 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8096 gfc_error ("Double CLASS IS block in SELECT TYPE "
8098 &c2
->ext
.block
.case_list
->where
);
8101 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8102 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8105 (*c1
)->block
= c2
->block
;
8115 /* Generate IF chain. */
8116 if_st
= gfc_get_code ();
8117 if_st
->op
= EXEC_IF
;
8119 for (body
= class_is
; body
; body
= body
->block
)
8121 new_st
->block
= gfc_get_code ();
8122 new_st
= new_st
->block
;
8123 new_st
->op
= EXEC_IF
;
8124 /* Set up IF condition: Call _gfortran_is_extension_of. */
8125 new_st
->expr1
= gfc_get_expr ();
8126 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8127 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8128 new_st
->expr1
->ts
.kind
= 4;
8129 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8130 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8131 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8132 /* Set up arguments. */
8133 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8134 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8135 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8136 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8137 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8138 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8139 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8140 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8141 new_st
->next
= body
->next
;
8143 if (default_case
->next
)
8145 new_st
->block
= gfc_get_code ();
8146 new_st
= new_st
->block
;
8147 new_st
->op
= EXEC_IF
;
8148 new_st
->next
= default_case
->next
;
8151 /* Replace CLASS DEFAULT code by the IF chain. */
8152 default_case
->next
= if_st
;
8155 /* Resolve the internal code. This can not be done earlier because
8156 it requires that the sym->assoc of selectors is set already. */
8157 gfc_current_ns
= ns
;
8158 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8159 gfc_current_ns
= old_ns
;
8161 resolve_select (code
);
8165 /* Resolve a transfer statement. This is making sure that:
8166 -- a derived type being transferred has only non-pointer components
8167 -- a derived type being transferred doesn't have private components, unless
8168 it's being transferred from the module where the type was defined
8169 -- we're not trying to transfer a whole assumed size array. */
8172 resolve_transfer (gfc_code
*code
)
8181 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8182 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8183 exp
= exp
->value
.op
.op1
;
8185 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8187 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8188 "MOLD=", &exp
->where
);
8192 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8193 && exp
->expr_type
!= EXPR_FUNCTION
))
8196 /* If we are reading, the variable will be changed. Note that
8197 code->ext.dt may be NULL if the TRANSFER is related to
8198 an INQUIRE statement -- but in this case, we are not reading, either. */
8199 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8200 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8204 sym
= exp
->symtree
->n
.sym
;
8207 /* Go to actual component transferred. */
8208 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8209 if (ref
->type
== REF_COMPONENT
)
8210 ts
= &ref
->u
.c
.component
->ts
;
8212 if (ts
->type
== BT_CLASS
)
8214 /* FIXME: Test for defined input/output. */
8215 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8216 "it is processed by a defined input/output procedure",
8221 if (ts
->type
== BT_DERIVED
)
8223 /* Check that transferred derived type doesn't contain POINTER
8225 if (ts
->u
.derived
->attr
.pointer_comp
)
8227 gfc_error ("Data transfer element at %L cannot have POINTER "
8228 "components unless it is processed by a defined "
8229 "input/output procedure", &code
->loc
);
8234 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8236 gfc_error ("Data transfer element at %L cannot have "
8237 "procedure pointer components", &code
->loc
);
8241 if (ts
->u
.derived
->attr
.alloc_comp
)
8243 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8244 "components unless it is processed by a defined "
8245 "input/output procedure", &code
->loc
);
8249 if (derived_inaccessible (ts
->u
.derived
))
8251 gfc_error ("Data transfer element at %L cannot have "
8252 "PRIVATE components",&code
->loc
);
8257 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8258 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8260 gfc_error ("Data transfer element at %L cannot be a full reference to "
8261 "an assumed-size array", &code
->loc
);
8267 /*********** Toplevel code resolution subroutines ***********/
8269 /* Find the set of labels that are reachable from this block. We also
8270 record the last statement in each block. */
8273 find_reachable_labels (gfc_code
*block
)
8280 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8282 /* Collect labels in this block. We don't keep those corresponding
8283 to END {IF|SELECT}, these are checked in resolve_branch by going
8284 up through the code_stack. */
8285 for (c
= block
; c
; c
= c
->next
)
8287 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8288 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8291 /* Merge with labels from parent block. */
8294 gcc_assert (cs_base
->prev
->reachable_labels
);
8295 bitmap_ior_into (cs_base
->reachable_labels
,
8296 cs_base
->prev
->reachable_labels
);
8302 resolve_lock_unlock (gfc_code
*code
)
8304 if (code
->expr1
->ts
.type
!= BT_DERIVED
8305 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8306 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8307 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8308 || code
->expr1
->rank
!= 0
8309 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8310 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8311 &code
->expr1
->where
);
8315 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8316 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8317 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8318 &code
->expr2
->where
);
8321 && gfc_check_vardef_context (code
->expr2
, false, false,
8322 _("STAT variable")) == FAILURE
)
8327 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8328 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8329 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8330 &code
->expr3
->where
);
8333 && gfc_check_vardef_context (code
->expr3
, false, false,
8334 _("ERRMSG variable")) == FAILURE
)
8337 /* Check ACQUIRED_LOCK. */
8339 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8340 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8341 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8342 "variable", &code
->expr4
->where
);
8345 && gfc_check_vardef_context (code
->expr4
, false, false,
8346 _("ACQUIRED_LOCK variable")) == FAILURE
)
8352 resolve_sync (gfc_code
*code
)
8354 /* Check imageset. The * case matches expr1 == NULL. */
8357 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8358 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8359 "INTEGER expression", &code
->expr1
->where
);
8360 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8361 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8362 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8363 &code
->expr1
->where
);
8364 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8365 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8367 gfc_constructor
*cons
;
8368 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8369 for (; cons
; cons
= gfc_constructor_next (cons
))
8370 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8371 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8372 gfc_error ("Imageset argument at %L must between 1 and "
8373 "num_images()", &cons
->expr
->where
);
8379 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8380 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8381 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8382 &code
->expr2
->where
);
8386 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8387 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8388 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8389 &code
->expr3
->where
);
8393 /* Given a branch to a label, see if the branch is conforming.
8394 The code node describes where the branch is located. */
8397 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8404 /* Step one: is this a valid branching target? */
8406 if (label
->defined
== ST_LABEL_UNKNOWN
)
8408 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8413 if (label
->defined
!= ST_LABEL_TARGET
)
8415 gfc_error ("Statement at %L is not a valid branch target statement "
8416 "for the branch statement at %L", &label
->where
, &code
->loc
);
8420 /* Step two: make sure this branch is not a branch to itself ;-) */
8422 if (code
->here
== label
)
8424 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8428 /* Step three: See if the label is in the same block as the
8429 branching statement. The hard work has been done by setting up
8430 the bitmap reachable_labels. */
8432 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8434 /* Check now whether there is a CRITICAL construct; if so, check
8435 whether the label is still visible outside of the CRITICAL block,
8436 which is invalid. */
8437 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8439 if (stack
->current
->op
== EXEC_CRITICAL
8440 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8441 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8442 "label at %L", &code
->loc
, &label
->where
);
8443 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8444 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8445 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8446 "for label at %L", &code
->loc
, &label
->where
);
8452 /* Step four: If we haven't found the label in the bitmap, it may
8453 still be the label of the END of the enclosing block, in which
8454 case we find it by going up the code_stack. */
8456 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8458 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8460 if (stack
->current
->op
== EXEC_CRITICAL
)
8462 /* Note: A label at END CRITICAL does not leave the CRITICAL
8463 construct as END CRITICAL is still part of it. */
8464 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8465 " at %L", &code
->loc
, &label
->where
);
8468 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8470 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8471 "label at %L", &code
->loc
, &label
->where
);
8478 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8482 /* The label is not in an enclosing block, so illegal. This was
8483 allowed in Fortran 66, so we allow it as extension. No
8484 further checks are necessary in this case. */
8485 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8486 "as the GOTO statement at %L", &label
->where
,
8492 /* Check whether EXPR1 has the same shape as EXPR2. */
8495 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8497 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8498 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8499 gfc_try result
= FAILURE
;
8502 /* Compare the rank. */
8503 if (expr1
->rank
!= expr2
->rank
)
8506 /* Compare the size of each dimension. */
8507 for (i
=0; i
<expr1
->rank
; i
++)
8509 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8512 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8515 if (mpz_cmp (shape
[i
], shape2
[i
]))
8519 /* When either of the two expression is an assumed size array, we
8520 ignore the comparison of dimension sizes. */
8525 gfc_clear_shape (shape
, i
);
8526 gfc_clear_shape (shape2
, i
);
8531 /* Check whether a WHERE assignment target or a WHERE mask expression
8532 has the same shape as the outmost WHERE mask expression. */
8535 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8541 cblock
= code
->block
;
8543 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8544 In case of nested WHERE, only the outmost one is stored. */
8545 if (mask
== NULL
) /* outmost WHERE */
8547 else /* inner WHERE */
8554 /* Check if the mask-expr has a consistent shape with the
8555 outmost WHERE mask-expr. */
8556 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8557 gfc_error ("WHERE mask at %L has inconsistent shape",
8558 &cblock
->expr1
->where
);
8561 /* the assignment statement of a WHERE statement, or the first
8562 statement in where-body-construct of a WHERE construct */
8563 cnext
= cblock
->next
;
8568 /* WHERE assignment statement */
8571 /* Check shape consistent for WHERE assignment target. */
8572 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8573 gfc_error ("WHERE assignment target at %L has "
8574 "inconsistent shape", &cnext
->expr1
->where
);
8578 case EXEC_ASSIGN_CALL
:
8579 resolve_call (cnext
);
8580 if (!cnext
->resolved_sym
->attr
.elemental
)
8581 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8582 &cnext
->ext
.actual
->expr
->where
);
8585 /* WHERE or WHERE construct is part of a where-body-construct */
8587 resolve_where (cnext
, e
);
8591 gfc_error ("Unsupported statement inside WHERE at %L",
8594 /* the next statement within the same where-body-construct */
8595 cnext
= cnext
->next
;
8597 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8598 cblock
= cblock
->block
;
8603 /* Resolve assignment in FORALL construct.
8604 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8605 FORALL index variables. */
8608 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8612 for (n
= 0; n
< nvar
; n
++)
8614 gfc_symbol
*forall_index
;
8616 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8618 /* Check whether the assignment target is one of the FORALL index
8620 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8621 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8622 gfc_error ("Assignment to a FORALL index variable at %L",
8623 &code
->expr1
->where
);
8626 /* If one of the FORALL index variables doesn't appear in the
8627 assignment variable, then there could be a many-to-one
8628 assignment. Emit a warning rather than an error because the
8629 mask could be resolving this problem. */
8630 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8631 gfc_warning ("The FORALL with index '%s' is not used on the "
8632 "left side of the assignment at %L and so might "
8633 "cause multiple assignment to this object",
8634 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8640 /* Resolve WHERE statement in FORALL construct. */
8643 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8644 gfc_expr
**var_expr
)
8649 cblock
= code
->block
;
8652 /* the assignment statement of a WHERE statement, or the first
8653 statement in where-body-construct of a WHERE construct */
8654 cnext
= cblock
->next
;
8659 /* WHERE assignment statement */
8661 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8664 /* WHERE operator assignment statement */
8665 case EXEC_ASSIGN_CALL
:
8666 resolve_call (cnext
);
8667 if (!cnext
->resolved_sym
->attr
.elemental
)
8668 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8669 &cnext
->ext
.actual
->expr
->where
);
8672 /* WHERE or WHERE construct is part of a where-body-construct */
8674 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8678 gfc_error ("Unsupported statement inside WHERE at %L",
8681 /* the next statement within the same where-body-construct */
8682 cnext
= cnext
->next
;
8684 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8685 cblock
= cblock
->block
;
8690 /* Traverse the FORALL body to check whether the following errors exist:
8691 1. For assignment, check if a many-to-one assignment happens.
8692 2. For WHERE statement, check the WHERE body to see if there is any
8693 many-to-one assignment. */
8696 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8700 c
= code
->block
->next
;
8706 case EXEC_POINTER_ASSIGN
:
8707 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8710 case EXEC_ASSIGN_CALL
:
8714 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8715 there is no need to handle it here. */
8719 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8724 /* The next statement in the FORALL body. */
8730 /* Counts the number of iterators needed inside a forall construct, including
8731 nested forall constructs. This is used to allocate the needed memory
8732 in gfc_resolve_forall. */
8735 gfc_count_forall_iterators (gfc_code
*code
)
8737 int max_iters
, sub_iters
, current_iters
;
8738 gfc_forall_iterator
*fa
;
8740 gcc_assert(code
->op
== EXEC_FORALL
);
8744 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8747 code
= code
->block
->next
;
8751 if (code
->op
== EXEC_FORALL
)
8753 sub_iters
= gfc_count_forall_iterators (code
);
8754 if (sub_iters
> max_iters
)
8755 max_iters
= sub_iters
;
8760 return current_iters
+ max_iters
;
8764 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8765 gfc_resolve_forall_body to resolve the FORALL body. */
8768 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8770 static gfc_expr
**var_expr
;
8771 static int total_var
= 0;
8772 static int nvar
= 0;
8774 gfc_forall_iterator
*fa
;
8779 /* Start to resolve a FORALL construct */
8780 if (forall_save
== 0)
8782 /* Count the total number of FORALL index in the nested FORALL
8783 construct in order to allocate the VAR_EXPR with proper size. */
8784 total_var
= gfc_count_forall_iterators (code
);
8786 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8787 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8790 /* The information about FORALL iterator, including FORALL index start, end
8791 and stride. The FORALL index can not appear in start, end or stride. */
8792 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8794 /* Check if any outer FORALL index name is the same as the current
8796 for (i
= 0; i
< nvar
; i
++)
8798 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8800 gfc_error ("An outer FORALL construct already has an index "
8801 "with this name %L", &fa
->var
->where
);
8805 /* Record the current FORALL index. */
8806 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8810 /* No memory leak. */
8811 gcc_assert (nvar
<= total_var
);
8814 /* Resolve the FORALL body. */
8815 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8817 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8818 gfc_resolve_blocks (code
->block
, ns
);
8822 /* Free only the VAR_EXPRs allocated in this frame. */
8823 for (i
= nvar
; i
< tmp
; i
++)
8824 gfc_free_expr (var_expr
[i
]);
8828 /* We are in the outermost FORALL construct. */
8829 gcc_assert (forall_save
== 0);
8831 /* VAR_EXPR is not needed any more. */
8838 /* Resolve a BLOCK construct statement. */
8841 resolve_block_construct (gfc_code
* code
)
8843 /* Resolve the BLOCK's namespace. */
8844 gfc_resolve (code
->ext
.block
.ns
);
8846 /* For an ASSOCIATE block, the associations (and their targets) are already
8847 resolved during resolve_symbol. */
8851 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8854 static void resolve_code (gfc_code
*, gfc_namespace
*);
8857 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8861 for (; b
; b
= b
->block
)
8863 t
= gfc_resolve_expr (b
->expr1
);
8864 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
8870 if (t
== SUCCESS
&& b
->expr1
!= NULL
8871 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8872 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8879 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8880 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8885 resolve_branch (b
->label1
, b
);
8889 resolve_block_construct (b
);
8893 case EXEC_SELECT_TYPE
:
8897 case EXEC_DO_CONCURRENT
:
8905 case EXEC_OMP_ATOMIC
:
8906 case EXEC_OMP_CRITICAL
:
8908 case EXEC_OMP_MASTER
:
8909 case EXEC_OMP_ORDERED
:
8910 case EXEC_OMP_PARALLEL
:
8911 case EXEC_OMP_PARALLEL_DO
:
8912 case EXEC_OMP_PARALLEL_SECTIONS
:
8913 case EXEC_OMP_PARALLEL_WORKSHARE
:
8914 case EXEC_OMP_SECTIONS
:
8915 case EXEC_OMP_SINGLE
:
8917 case EXEC_OMP_TASKWAIT
:
8918 case EXEC_OMP_TASKYIELD
:
8919 case EXEC_OMP_WORKSHARE
:
8923 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8926 resolve_code (b
->next
, ns
);
8931 /* Does everything to resolve an ordinary assignment. Returns true
8932 if this is an interface assignment. */
8934 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
8944 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
8948 if (code
->op
== EXEC_ASSIGN_CALL
)
8950 lhs
= code
->ext
.actual
->expr
;
8951 rhsptr
= &code
->ext
.actual
->next
->expr
;
8955 gfc_actual_arglist
* args
;
8956 gfc_typebound_proc
* tbp
;
8958 gcc_assert (code
->op
== EXEC_COMPCALL
);
8960 args
= code
->expr1
->value
.compcall
.actual
;
8962 rhsptr
= &args
->next
->expr
;
8964 tbp
= code
->expr1
->value
.compcall
.tbp
;
8965 gcc_assert (!tbp
->is_generic
);
8968 /* Make a temporary rhs when there is a default initializer
8969 and rhs is the same symbol as the lhs. */
8970 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
8971 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
8972 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
8973 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
8974 *rhsptr
= gfc_get_parentheses (*rhsptr
);
8983 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
8984 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8985 &code
->loc
) == FAILURE
)
8988 /* Handle the case of a BOZ literal on the RHS. */
8989 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
8992 if (gfc_option
.warn_surprising
)
8993 gfc_warning ("BOZ literal at %L is bitwise transferred "
8994 "non-integer symbol '%s'", &code
->loc
,
8995 lhs
->symtree
->n
.sym
->name
);
8997 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
8999 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9001 if (rc
== ARITH_UNDERFLOW
)
9002 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9003 ". This check can be disabled with the option "
9004 "-fno-range-check", &rhs
->where
);
9005 else if (rc
== ARITH_OVERFLOW
)
9006 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9007 ". This check can be disabled with the option "
9008 "-fno-range-check", &rhs
->where
);
9009 else if (rc
== ARITH_NAN
)
9010 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9011 ". This check can be disabled with the option "
9012 "-fno-range-check", &rhs
->where
);
9017 if (lhs
->ts
.type
== BT_CHARACTER
9018 && gfc_option
.warn_character_truncation
)
9020 if (lhs
->ts
.u
.cl
!= NULL
9021 && lhs
->ts
.u
.cl
->length
!= NULL
9022 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9023 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9025 if (rhs
->expr_type
== EXPR_CONSTANT
)
9026 rlen
= rhs
->value
.character
.length
;
9028 else if (rhs
->ts
.u
.cl
!= NULL
9029 && rhs
->ts
.u
.cl
->length
!= NULL
9030 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9031 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9033 if (rlen
&& llen
&& rlen
> llen
)
9034 gfc_warning_now ("CHARACTER expression will be truncated "
9035 "in assignment (%d/%d) at %L",
9036 llen
, rlen
, &code
->loc
);
9039 /* Ensure that a vector index expression for the lvalue is evaluated
9040 to a temporary if the lvalue symbol is referenced in it. */
9043 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9044 if (ref
->type
== REF_ARRAY
)
9046 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9047 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9048 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9049 ref
->u
.ar
.start
[n
]))
9051 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9055 if (gfc_pure (NULL
))
9057 if (lhs
->ts
.type
== BT_DERIVED
9058 && lhs
->expr_type
== EXPR_VARIABLE
9059 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9060 && rhs
->expr_type
== EXPR_VARIABLE
9061 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9062 || gfc_is_coindexed (rhs
)))
9065 if (gfc_is_coindexed (rhs
))
9066 gfc_error ("Coindexed expression at %L is assigned to "
9067 "a derived type variable with a POINTER "
9068 "component in a PURE procedure",
9071 gfc_error ("The impure variable at %L is assigned to "
9072 "a derived type variable with a POINTER "
9073 "component in a PURE procedure (12.6)",
9078 /* Fortran 2008, C1283. */
9079 if (gfc_is_coindexed (lhs
))
9081 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9082 "procedure", &rhs
->where
);
9087 if (gfc_implicit_pure (NULL
))
9089 if (lhs
->expr_type
== EXPR_VARIABLE
9090 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9091 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9092 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9094 if (lhs
->ts
.type
== BT_DERIVED
9095 && lhs
->expr_type
== EXPR_VARIABLE
9096 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9097 && rhs
->expr_type
== EXPR_VARIABLE
9098 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9099 || gfc_is_coindexed (rhs
)))
9100 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9102 /* Fortran 2008, C1283. */
9103 if (gfc_is_coindexed (lhs
))
9104 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9108 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9109 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9110 if (lhs
->ts
.type
== BT_CLASS
)
9112 gfc_error ("Variable must not be polymorphic in assignment at %L",
9117 /* F2008, Section 7.2.1.2. */
9118 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9120 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9121 "component in assignment at %L", &lhs
->where
);
9125 gfc_check_assign (lhs
, rhs
, 1);
9130 /* Given a block of code, recursively resolve everything pointed to by this
9134 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9136 int omp_workshare_save
;
9137 int forall_save
, do_concurrent_save
;
9141 frame
.prev
= cs_base
;
9145 find_reachable_labels (code
);
9147 for (; code
; code
= code
->next
)
9149 frame
.current
= code
;
9150 forall_save
= forall_flag
;
9151 do_concurrent_save
= do_concurrent_flag
;
9153 if (code
->op
== EXEC_FORALL
)
9156 gfc_resolve_forall (code
, ns
, forall_save
);
9159 else if (code
->block
)
9161 omp_workshare_save
= -1;
9164 case EXEC_OMP_PARALLEL_WORKSHARE
:
9165 omp_workshare_save
= omp_workshare_flag
;
9166 omp_workshare_flag
= 1;
9167 gfc_resolve_omp_parallel_blocks (code
, ns
);
9169 case EXEC_OMP_PARALLEL
:
9170 case EXEC_OMP_PARALLEL_DO
:
9171 case EXEC_OMP_PARALLEL_SECTIONS
:
9173 omp_workshare_save
= omp_workshare_flag
;
9174 omp_workshare_flag
= 0;
9175 gfc_resolve_omp_parallel_blocks (code
, ns
);
9178 gfc_resolve_omp_do_blocks (code
, ns
);
9180 case EXEC_SELECT_TYPE
:
9181 /* Blocks are handled in resolve_select_type because we have
9182 to transform the SELECT TYPE into ASSOCIATE first. */
9184 case EXEC_DO_CONCURRENT
:
9185 do_concurrent_flag
= 1;
9186 gfc_resolve_blocks (code
->block
, ns
);
9187 do_concurrent_flag
= 2;
9189 case EXEC_OMP_WORKSHARE
:
9190 omp_workshare_save
= omp_workshare_flag
;
9191 omp_workshare_flag
= 1;
9194 gfc_resolve_blocks (code
->block
, ns
);
9198 if (omp_workshare_save
!= -1)
9199 omp_workshare_flag
= omp_workshare_save
;
9203 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9204 t
= gfc_resolve_expr (code
->expr1
);
9205 forall_flag
= forall_save
;
9206 do_concurrent_flag
= do_concurrent_save
;
9208 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9211 if (code
->op
== EXEC_ALLOCATE
9212 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9218 case EXEC_END_BLOCK
:
9219 case EXEC_END_NESTED_BLOCK
:
9223 case EXEC_ERROR_STOP
:
9227 case EXEC_ASSIGN_CALL
:
9232 case EXEC_SYNC_IMAGES
:
9233 case EXEC_SYNC_MEMORY
:
9234 resolve_sync (code
);
9239 resolve_lock_unlock (code
);
9243 /* Keep track of which entry we are up to. */
9244 current_entry_id
= code
->ext
.entry
->id
;
9248 resolve_where (code
, NULL
);
9252 if (code
->expr1
!= NULL
)
9254 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9255 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9256 "INTEGER variable", &code
->expr1
->where
);
9257 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9258 gfc_error ("Variable '%s' has not been assigned a target "
9259 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9260 &code
->expr1
->where
);
9263 resolve_branch (code
->label1
, code
);
9267 if (code
->expr1
!= NULL
9268 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9269 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9270 "INTEGER return specifier", &code
->expr1
->where
);
9273 case EXEC_INIT_ASSIGN
:
9274 case EXEC_END_PROCEDURE
:
9281 if (gfc_check_vardef_context (code
->expr1
, false, false,
9282 _("assignment")) == FAILURE
)
9285 if (resolve_ordinary_assign (code
, ns
))
9287 if (code
->op
== EXEC_COMPCALL
)
9294 case EXEC_LABEL_ASSIGN
:
9295 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9296 gfc_error ("Label %d referenced at %L is never defined",
9297 code
->label1
->value
, &code
->label1
->where
);
9299 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9300 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9301 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9302 != gfc_default_integer_kind
9303 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9304 gfc_error ("ASSIGN statement at %L requires a scalar "
9305 "default INTEGER variable", &code
->expr1
->where
);
9308 case EXEC_POINTER_ASSIGN
:
9315 /* This is both a variable definition and pointer assignment
9316 context, so check both of them. For rank remapping, a final
9317 array ref may be present on the LHS and fool gfc_expr_attr
9318 used in gfc_check_vardef_context. Remove it. */
9319 e
= remove_last_array_ref (code
->expr1
);
9320 t
= gfc_check_vardef_context (e
, true, false,
9321 _("pointer assignment"));
9323 t
= gfc_check_vardef_context (e
, false, false,
9324 _("pointer assignment"));
9329 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9333 case EXEC_ARITHMETIC_IF
:
9335 && code
->expr1
->ts
.type
!= BT_INTEGER
9336 && code
->expr1
->ts
.type
!= BT_REAL
)
9337 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9338 "expression", &code
->expr1
->where
);
9340 resolve_branch (code
->label1
, code
);
9341 resolve_branch (code
->label2
, code
);
9342 resolve_branch (code
->label3
, code
);
9346 if (t
== SUCCESS
&& code
->expr1
!= NULL
9347 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9348 || code
->expr1
->rank
!= 0))
9349 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9350 &code
->expr1
->where
);
9355 resolve_call (code
);
9360 resolve_typebound_subroutine (code
);
9364 resolve_ppc_call (code
);
9368 /* Select is complicated. Also, a SELECT construct could be
9369 a transformed computed GOTO. */
9370 resolve_select (code
);
9373 case EXEC_SELECT_TYPE
:
9374 resolve_select_type (code
, ns
);
9378 resolve_block_construct (code
);
9382 if (code
->ext
.iterator
!= NULL
)
9384 gfc_iterator
*iter
= code
->ext
.iterator
;
9385 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9386 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9391 if (code
->expr1
== NULL
)
9392 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9394 && (code
->expr1
->rank
!= 0
9395 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9396 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9397 "a scalar LOGICAL expression", &code
->expr1
->where
);
9402 resolve_allocate_deallocate (code
, "ALLOCATE");
9406 case EXEC_DEALLOCATE
:
9408 resolve_allocate_deallocate (code
, "DEALLOCATE");
9413 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9416 resolve_branch (code
->ext
.open
->err
, code
);
9420 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9423 resolve_branch (code
->ext
.close
->err
, code
);
9426 case EXEC_BACKSPACE
:
9430 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9433 resolve_branch (code
->ext
.filepos
->err
, code
);
9437 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9440 resolve_branch (code
->ext
.inquire
->err
, code
);
9444 gcc_assert (code
->ext
.inquire
!= NULL
);
9445 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9448 resolve_branch (code
->ext
.inquire
->err
, code
);
9452 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9455 resolve_branch (code
->ext
.wait
->err
, code
);
9456 resolve_branch (code
->ext
.wait
->end
, code
);
9457 resolve_branch (code
->ext
.wait
->eor
, code
);
9462 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9465 resolve_branch (code
->ext
.dt
->err
, code
);
9466 resolve_branch (code
->ext
.dt
->end
, code
);
9467 resolve_branch (code
->ext
.dt
->eor
, code
);
9471 resolve_transfer (code
);
9474 case EXEC_DO_CONCURRENT
:
9476 resolve_forall_iterators (code
->ext
.forall_iterator
);
9478 if (code
->expr1
!= NULL
9479 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9480 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9481 "expression", &code
->expr1
->where
);
9484 case EXEC_OMP_ATOMIC
:
9485 case EXEC_OMP_BARRIER
:
9486 case EXEC_OMP_CRITICAL
:
9487 case EXEC_OMP_FLUSH
:
9489 case EXEC_OMP_MASTER
:
9490 case EXEC_OMP_ORDERED
:
9491 case EXEC_OMP_SECTIONS
:
9492 case EXEC_OMP_SINGLE
:
9493 case EXEC_OMP_TASKWAIT
:
9494 case EXEC_OMP_TASKYIELD
:
9495 case EXEC_OMP_WORKSHARE
:
9496 gfc_resolve_omp_directive (code
, ns
);
9499 case EXEC_OMP_PARALLEL
:
9500 case EXEC_OMP_PARALLEL_DO
:
9501 case EXEC_OMP_PARALLEL_SECTIONS
:
9502 case EXEC_OMP_PARALLEL_WORKSHARE
:
9504 omp_workshare_save
= omp_workshare_flag
;
9505 omp_workshare_flag
= 0;
9506 gfc_resolve_omp_directive (code
, ns
);
9507 omp_workshare_flag
= omp_workshare_save
;
9511 gfc_internal_error ("resolve_code(): Bad statement code");
9515 cs_base
= frame
.prev
;
9519 /* Resolve initial values and make sure they are compatible with
9523 resolve_values (gfc_symbol
*sym
)
9527 if (sym
->value
== NULL
|| sym
->attr
.use_assoc
)
9530 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9531 t
= resolve_structure_cons (sym
->value
, 1);
9533 t
= gfc_resolve_expr (sym
->value
);
9538 gfc_check_assign_symbol (sym
, sym
->value
);
9542 /* Verify the binding labels for common blocks that are BIND(C). The label
9543 for a BIND(C) common block must be identical in all scoping units in which
9544 the common block is declared. Further, the binding label can not collide
9545 with any other global entity in the program. */
9548 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9550 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9552 gfc_gsymbol
*binding_label_gsym
;
9553 gfc_gsymbol
*comm_name_gsym
;
9555 /* See if a global symbol exists by the common block's name. It may
9556 be NULL if the common block is use-associated. */
9557 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9558 comm_block_tree
->n
.common
->name
);
9559 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9560 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9561 "with the global entity '%s' at %L",
9562 comm_block_tree
->n
.common
->binding_label
,
9563 comm_block_tree
->n
.common
->name
,
9564 &(comm_block_tree
->n
.common
->where
),
9565 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9566 else if (comm_name_gsym
!= NULL
9567 && strcmp (comm_name_gsym
->name
,
9568 comm_block_tree
->n
.common
->name
) == 0)
9570 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9572 if (comm_name_gsym
->binding_label
== NULL
)
9573 /* No binding label for common block stored yet; save this one. */
9574 comm_name_gsym
->binding_label
=
9575 comm_block_tree
->n
.common
->binding_label
;
9577 if (strcmp (comm_name_gsym
->binding_label
,
9578 comm_block_tree
->n
.common
->binding_label
) != 0)
9580 /* Common block names match but binding labels do not. */
9581 gfc_error ("Binding label '%s' for common block '%s' at %L "
9582 "does not match the binding label '%s' for common "
9584 comm_block_tree
->n
.common
->binding_label
,
9585 comm_block_tree
->n
.common
->name
,
9586 &(comm_block_tree
->n
.common
->where
),
9587 comm_name_gsym
->binding_label
,
9588 comm_name_gsym
->name
,
9589 &(comm_name_gsym
->where
));
9594 /* There is no binding label (NAME="") so we have nothing further to
9595 check and nothing to add as a global symbol for the label. */
9596 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
9599 binding_label_gsym
=
9600 gfc_find_gsymbol (gfc_gsym_root
,
9601 comm_block_tree
->n
.common
->binding_label
);
9602 if (binding_label_gsym
== NULL
)
9604 /* Need to make a global symbol for the binding label to prevent
9605 it from colliding with another. */
9606 binding_label_gsym
=
9607 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9608 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9609 binding_label_gsym
->type
= GSYM_COMMON
;
9613 /* If comm_name_gsym is NULL, the name common block is use
9614 associated and the name could be colliding. */
9615 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9616 gfc_error ("Binding label '%s' for common block '%s' at %L "
9617 "collides with the global entity '%s' at %L",
9618 comm_block_tree
->n
.common
->binding_label
,
9619 comm_block_tree
->n
.common
->name
,
9620 &(comm_block_tree
->n
.common
->where
),
9621 binding_label_gsym
->name
,
9622 &(binding_label_gsym
->where
));
9623 else if (comm_name_gsym
!= NULL
9624 && (strcmp (binding_label_gsym
->name
,
9625 comm_name_gsym
->binding_label
) != 0)
9626 && (strcmp (binding_label_gsym
->sym_name
,
9627 comm_name_gsym
->name
) != 0))
9628 gfc_error ("Binding label '%s' for common block '%s' at %L "
9629 "collides with global entity '%s' at %L",
9630 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9631 &(comm_block_tree
->n
.common
->where
),
9632 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9640 /* Verify any BIND(C) derived types in the namespace so we can report errors
9641 for them once, rather than for each variable declared of that type. */
9644 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9646 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9647 && derived_sym
->attr
.is_bind_c
== 1)
9648 verify_bind_c_derived_type (derived_sym
);
9654 /* Verify that any binding labels used in a given namespace do not collide
9655 with the names or binding labels of any global symbols. */
9658 gfc_verify_binding_labels (gfc_symbol
*sym
)
9662 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9663 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
9665 gfc_gsymbol
*bind_c_sym
;
9667 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9668 if (bind_c_sym
!= NULL
9669 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9671 if (sym
->attr
.if_source
== IFSRC_DECL
9672 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9673 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9674 && ((sym
->attr
.contained
== 1
9675 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9676 || (sym
->attr
.use_assoc
== 1
9677 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9679 /* Make sure global procedures don't collide with anything. */
9680 gfc_error ("Binding label '%s' at %L collides with the global "
9681 "entity '%s' at %L", sym
->binding_label
,
9682 &(sym
->declared_at
), bind_c_sym
->name
,
9683 &(bind_c_sym
->where
));
9686 else if (sym
->attr
.contained
== 0
9687 && (sym
->attr
.if_source
== IFSRC_IFBODY
9688 && sym
->attr
.flavor
== FL_PROCEDURE
)
9689 && (bind_c_sym
->sym_name
!= NULL
9690 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9692 /* Make sure procedures in interface bodies don't collide. */
9693 gfc_error ("Binding label '%s' in interface body at %L collides "
9694 "with the global entity '%s' at %L",
9696 &(sym
->declared_at
), bind_c_sym
->name
,
9697 &(bind_c_sym
->where
));
9700 else if (sym
->attr
.contained
== 0
9701 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9702 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9703 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9704 || sym
->attr
.use_assoc
== 0)
9706 gfc_error ("Binding label '%s' at %L collides with global "
9707 "entity '%s' at %L", sym
->binding_label
,
9708 &(sym
->declared_at
), bind_c_sym
->name
,
9709 &(bind_c_sym
->where
));
9714 /* Clear the binding label to prevent checking multiple times. */
9715 sym
->binding_label
[0] = '\0';
9717 else if (bind_c_sym
== NULL
)
9719 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9720 bind_c_sym
->where
= sym
->declared_at
;
9721 bind_c_sym
->sym_name
= sym
->name
;
9723 if (sym
->attr
.use_assoc
== 1)
9724 bind_c_sym
->mod_name
= sym
->module
;
9726 if (sym
->ns
->proc_name
!= NULL
)
9727 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9729 if (sym
->attr
.contained
== 0)
9731 if (sym
->attr
.subroutine
)
9732 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9733 else if (sym
->attr
.function
)
9734 bind_c_sym
->type
= GSYM_FUNCTION
;
9742 /* Resolve an index expression. */
9745 resolve_index_expr (gfc_expr
*e
)
9747 if (gfc_resolve_expr (e
) == FAILURE
)
9750 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9753 if (gfc_specification_expr (e
) == FAILURE
)
9760 /* Resolve a charlen structure. */
9763 resolve_charlen (gfc_charlen
*cl
)
9772 specification_expr
= 1;
9774 if (resolve_index_expr (cl
->length
) == FAILURE
)
9776 specification_expr
= 0;
9780 /* "If the character length parameter value evaluates to a negative
9781 value, the length of character entities declared is zero." */
9782 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9784 if (gfc_option
.warn_surprising
)
9785 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9786 " the length has been set to zero",
9787 &cl
->length
->where
, i
);
9788 gfc_replace_expr (cl
->length
,
9789 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9792 /* Check that the character length is not too large. */
9793 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9794 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9795 && cl
->length
->ts
.type
== BT_INTEGER
9796 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9798 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9806 /* Test for non-constant shape arrays. */
9809 is_non_constant_shape_array (gfc_symbol
*sym
)
9815 not_constant
= false;
9816 if (sym
->as
!= NULL
)
9818 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9819 has not been simplified; parameter array references. Do the
9820 simplification now. */
9821 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
9823 e
= sym
->as
->lower
[i
];
9824 if (e
&& (resolve_index_expr (e
) == FAILURE
9825 || !gfc_is_constant_expr (e
)))
9826 not_constant
= true;
9827 e
= sym
->as
->upper
[i
];
9828 if (e
&& (resolve_index_expr (e
) == FAILURE
9829 || !gfc_is_constant_expr (e
)))
9830 not_constant
= true;
9833 return not_constant
;
9836 /* Given a symbol and an initialization expression, add code to initialize
9837 the symbol to the function entry. */
9839 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
9843 gfc_namespace
*ns
= sym
->ns
;
9845 /* Search for the function namespace if this is a contained
9846 function without an explicit result. */
9847 if (sym
->attr
.function
&& sym
== sym
->result
9848 && sym
->name
!= sym
->ns
->proc_name
->name
)
9851 for (;ns
; ns
= ns
->sibling
)
9852 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
9858 gfc_free_expr (init
);
9862 /* Build an l-value expression for the result. */
9863 lval
= gfc_lval_expr_from_sym (sym
);
9865 /* Add the code at scope entry. */
9866 init_st
= gfc_get_code ();
9867 init_st
->next
= ns
->code
;
9870 /* Assign the default initializer to the l-value. */
9871 init_st
->loc
= sym
->declared_at
;
9872 init_st
->op
= EXEC_INIT_ASSIGN
;
9873 init_st
->expr1
= lval
;
9874 init_st
->expr2
= init
;
9877 /* Assign the default initializer to a derived type variable or result. */
9880 apply_default_init (gfc_symbol
*sym
)
9882 gfc_expr
*init
= NULL
;
9884 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9887 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
9888 init
= gfc_default_initializer (&sym
->ts
);
9890 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
9893 build_init_assign (sym
, init
);
9894 sym
->attr
.referenced
= 1;
9897 /* Build an initializer for a local integer, real, complex, logical, or
9898 character variable, based on the command line flags finit-local-zero,
9899 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9900 null if the symbol should not have a default initialization. */
9902 build_default_init_expr (gfc_symbol
*sym
)
9905 gfc_expr
*init_expr
;
9908 /* These symbols should never have a default initialization. */
9909 if (sym
->attr
.allocatable
9910 || sym
->attr
.external
9912 || sym
->attr
.pointer
9913 || sym
->attr
.in_equivalence
9914 || sym
->attr
.in_common
9917 || sym
->attr
.cray_pointee
9918 || sym
->attr
.cray_pointer
)
9921 /* Now we'll try to build an initializer expression. */
9922 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
9925 /* We will only initialize integers, reals, complex, logicals, and
9926 characters, and only if the corresponding command-line flags
9927 were set. Otherwise, we free init_expr and return null. */
9928 switch (sym
->ts
.type
)
9931 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
9932 mpz_set_si (init_expr
->value
.integer
,
9933 gfc_option
.flag_init_integer_value
);
9936 gfc_free_expr (init_expr
);
9942 switch (gfc_option
.flag_init_real
)
9944 case GFC_INIT_REAL_SNAN
:
9945 init_expr
->is_snan
= 1;
9947 case GFC_INIT_REAL_NAN
:
9948 mpfr_set_nan (init_expr
->value
.real
);
9951 case GFC_INIT_REAL_INF
:
9952 mpfr_set_inf (init_expr
->value
.real
, 1);
9955 case GFC_INIT_REAL_NEG_INF
:
9956 mpfr_set_inf (init_expr
->value
.real
, -1);
9959 case GFC_INIT_REAL_ZERO
:
9960 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
9964 gfc_free_expr (init_expr
);
9971 switch (gfc_option
.flag_init_real
)
9973 case GFC_INIT_REAL_SNAN
:
9974 init_expr
->is_snan
= 1;
9976 case GFC_INIT_REAL_NAN
:
9977 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
9978 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
9981 case GFC_INIT_REAL_INF
:
9982 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
9983 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
9986 case GFC_INIT_REAL_NEG_INF
:
9987 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
9988 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
9991 case GFC_INIT_REAL_ZERO
:
9992 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
9996 gfc_free_expr (init_expr
);
10003 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10004 init_expr
->value
.logical
= 0;
10005 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10006 init_expr
->value
.logical
= 1;
10009 gfc_free_expr (init_expr
);
10015 /* For characters, the length must be constant in order to
10016 create a default initializer. */
10017 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10018 && sym
->ts
.u
.cl
->length
10019 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10021 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10022 init_expr
->value
.character
.length
= char_len
;
10023 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10024 for (i
= 0; i
< char_len
; i
++)
10025 init_expr
->value
.character
.string
[i
]
10026 = (unsigned char) gfc_option
.flag_init_character_value
;
10030 gfc_free_expr (init_expr
);
10036 gfc_free_expr (init_expr
);
10042 /* Add an initialization expression to a local variable. */
10044 apply_default_init_local (gfc_symbol
*sym
)
10046 gfc_expr
*init
= NULL
;
10048 /* The symbol should be a variable or a function return value. */
10049 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10050 || (sym
->attr
.function
&& sym
->result
!= sym
))
10053 /* Try to build the initializer expression. If we can't initialize
10054 this symbol, then init will be NULL. */
10055 init
= build_default_init_expr (sym
);
10059 /* For saved variables, we don't want to add an initializer at
10060 function entry, so we just add a static initializer. */
10061 if (sym
->attr
.save
|| sym
->ns
->save_all
10062 || gfc_option
.flag_max_stack_var_size
== 0)
10064 /* Don't clobber an existing initializer! */
10065 gcc_assert (sym
->value
== NULL
);
10070 build_init_assign (sym
, init
);
10074 /* Resolution of common features of flavors variable and procedure. */
10077 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10079 gfc_array_spec
*as
;
10081 /* Avoid double diagnostics for function result symbols. */
10082 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10083 && (sym
->ns
!= gfc_current_ns
))
10086 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10087 as
= CLASS_DATA (sym
)->as
;
10091 /* Constraints on deferred shape variable. */
10092 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10094 bool pointer
, allocatable
, dimension
;
10096 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10098 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10099 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10100 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10104 pointer
= sym
->attr
.pointer
;
10105 allocatable
= sym
->attr
.allocatable
;
10106 dimension
= sym
->attr
.dimension
;
10113 gfc_error ("Allocatable array '%s' at %L must have "
10114 "a deferred shape", sym
->name
, &sym
->declared_at
);
10117 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
10118 "may not be ALLOCATABLE", sym
->name
,
10119 &sym
->declared_at
) == FAILURE
)
10123 if (pointer
&& dimension
)
10125 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10126 sym
->name
, &sym
->declared_at
);
10132 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10133 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10135 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10136 sym
->name
, &sym
->declared_at
);
10141 /* Constraints on polymorphic variables. */
10142 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10145 if (sym
->attr
.class_ok
10146 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10148 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10149 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10150 &sym
->declared_at
);
10155 /* Assume that use associated symbols were checked in the module ns.
10156 Class-variables that are associate-names are also something special
10157 and excepted from the test. */
10158 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10160 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10161 "or pointer", sym
->name
, &sym
->declared_at
);
10170 /* Additional checks for symbols with flavor variable and derived
10171 type. To be called from resolve_fl_variable. */
10174 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10176 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10178 /* Check to see if a derived type is blocked from being host
10179 associated by the presence of another class I symbol in the same
10180 namespace. 14.6.1.3 of the standard and the discussion on
10181 comp.lang.fortran. */
10182 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10183 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10186 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10187 if (s
&& s
->attr
.generic
)
10188 s
= gfc_find_dt_in_generic (s
);
10189 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10191 gfc_error ("The type '%s' cannot be host associated at %L "
10192 "because it is blocked by an incompatible object "
10193 "of the same name declared at %L",
10194 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10200 /* 4th constraint in section 11.3: "If an object of a type for which
10201 component-initialization is specified (R429) appears in the
10202 specification-part of a module and does not have the ALLOCATABLE
10203 or POINTER attribute, the object shall have the SAVE attribute."
10205 The check for initializers is performed with
10206 gfc_has_default_initializer because gfc_default_initializer generates
10207 a hidden default for allocatable components. */
10208 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10209 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10210 && !sym
->ns
->save_all
&& !sym
->attr
.save
10211 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10212 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10213 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
10214 "module variable '%s' at %L, needed due to "
10215 "the default initialization", sym
->name
,
10216 &sym
->declared_at
) == FAILURE
)
10219 /* Assign default initializer. */
10220 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10221 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10223 sym
->value
= gfc_default_initializer (&sym
->ts
);
10230 /* Resolve symbols with flavor variable. */
10233 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10235 int no_init_flag
, automatic_flag
;
10237 const char *auto_save_msg
;
10239 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10242 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10245 /* Set this flag to check that variables are parameters of all entries.
10246 This check is effected by the call to gfc_resolve_expr through
10247 is_non_constant_shape_array. */
10248 specification_expr
= 1;
10250 if (sym
->ns
->proc_name
10251 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10252 || sym
->ns
->proc_name
->attr
.is_main_program
)
10253 && !sym
->attr
.use_assoc
10254 && !sym
->attr
.allocatable
10255 && !sym
->attr
.pointer
10256 && is_non_constant_shape_array (sym
))
10258 /* The shape of a main program or module array needs to be
10260 gfc_error ("The module or main program array '%s' at %L must "
10261 "have constant shape", sym
->name
, &sym
->declared_at
);
10262 specification_expr
= 0;
10266 /* Constraints on deferred type parameter. */
10267 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10269 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10270 "requires either the pointer or allocatable attribute",
10271 sym
->name
, &sym
->declared_at
);
10275 if (sym
->ts
.type
== BT_CHARACTER
)
10277 /* Make sure that character string variables with assumed length are
10278 dummy arguments. */
10279 e
= sym
->ts
.u
.cl
->length
;
10280 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10281 && !sym
->ts
.deferred
)
10283 gfc_error ("Entity with assumed character length at %L must be a "
10284 "dummy argument or a PARAMETER", &sym
->declared_at
);
10288 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10290 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10294 if (!gfc_is_constant_expr (e
)
10295 && !(e
->expr_type
== EXPR_VARIABLE
10296 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10298 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10299 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10300 || sym
->ns
->proc_name
->attr
.is_main_program
))
10302 gfc_error ("'%s' at %L must have constant character length "
10303 "in this context", sym
->name
, &sym
->declared_at
);
10306 if (sym
->attr
.in_common
)
10308 gfc_error ("COMMON variable '%s' at %L must have constant "
10309 "character length", sym
->name
, &sym
->declared_at
);
10315 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10316 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10318 /* Determine if the symbol may not have an initializer. */
10319 no_init_flag
= automatic_flag
= 0;
10320 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10321 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10323 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10324 && is_non_constant_shape_array (sym
))
10326 no_init_flag
= automatic_flag
= 1;
10328 /* Also, they must not have the SAVE attribute.
10329 SAVE_IMPLICIT is checked below. */
10330 if (sym
->as
&& sym
->attr
.codimension
)
10332 int corank
= sym
->as
->corank
;
10333 sym
->as
->corank
= 0;
10334 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10335 sym
->as
->corank
= corank
;
10337 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10339 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10344 /* Ensure that any initializer is simplified. */
10346 gfc_simplify_expr (sym
->value
, 1);
10348 /* Reject illegal initializers. */
10349 if (!sym
->mark
&& sym
->value
)
10351 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10352 && CLASS_DATA (sym
)->attr
.allocatable
))
10353 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10354 sym
->name
, &sym
->declared_at
);
10355 else if (sym
->attr
.external
)
10356 gfc_error ("External '%s' at %L cannot have an initializer",
10357 sym
->name
, &sym
->declared_at
);
10358 else if (sym
->attr
.dummy
10359 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10360 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10361 sym
->name
, &sym
->declared_at
);
10362 else if (sym
->attr
.intrinsic
)
10363 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10364 sym
->name
, &sym
->declared_at
);
10365 else if (sym
->attr
.result
)
10366 gfc_error ("Function result '%s' at %L cannot have an initializer",
10367 sym
->name
, &sym
->declared_at
);
10368 else if (automatic_flag
)
10369 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10370 sym
->name
, &sym
->declared_at
);
10372 goto no_init_error
;
10377 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10378 return resolve_fl_variable_derived (sym
, no_init_flag
);
10384 /* Resolve a procedure. */
10387 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10389 gfc_formal_arglist
*arg
;
10391 if (sym
->attr
.function
10392 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10395 if (sym
->ts
.type
== BT_CHARACTER
)
10397 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10399 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10400 && resolve_charlen (cl
) == FAILURE
)
10403 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10404 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10406 gfc_error ("Character-valued statement function '%s' at %L must "
10407 "have constant length", sym
->name
, &sym
->declared_at
);
10412 /* Ensure that derived type for are not of a private type. Internal
10413 module procedures are excluded by 2.2.3.3 - i.e., they are not
10414 externally accessible and can access all the objects accessible in
10416 if (!(sym
->ns
->parent
10417 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10418 && gfc_check_symbol_access (sym
))
10420 gfc_interface
*iface
;
10422 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10425 && arg
->sym
->ts
.type
== BT_DERIVED
10426 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10427 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10428 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10429 "PRIVATE type and cannot be a dummy argument"
10430 " of '%s', which is PUBLIC at %L",
10431 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10434 /* Stop this message from recurring. */
10435 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10440 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10441 PRIVATE to the containing module. */
10442 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10444 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10447 && arg
->sym
->ts
.type
== BT_DERIVED
10448 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10449 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10450 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10451 "'%s' in PUBLIC interface '%s' at %L "
10452 "takes dummy arguments of '%s' which is "
10453 "PRIVATE", iface
->sym
->name
, sym
->name
,
10454 &iface
->sym
->declared_at
,
10455 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10457 /* Stop this message from recurring. */
10458 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10464 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10465 PRIVATE to the containing module. */
10466 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10468 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10471 && arg
->sym
->ts
.type
== BT_DERIVED
10472 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10473 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10474 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10475 "'%s' in PUBLIC interface '%s' at %L "
10476 "takes dummy arguments of '%s' which is "
10477 "PRIVATE", iface
->sym
->name
, sym
->name
,
10478 &iface
->sym
->declared_at
,
10479 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10481 /* Stop this message from recurring. */
10482 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10489 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10490 && !sym
->attr
.proc_pointer
)
10492 gfc_error ("Function '%s' at %L cannot have an initializer",
10493 sym
->name
, &sym
->declared_at
);
10497 /* An external symbol may not have an initializer because it is taken to be
10498 a procedure. Exception: Procedure Pointers. */
10499 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10501 gfc_error ("External object '%s' at %L may not have an initializer",
10502 sym
->name
, &sym
->declared_at
);
10506 /* An elemental function is required to return a scalar 12.7.1 */
10507 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10509 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10510 "result", sym
->name
, &sym
->declared_at
);
10511 /* Reset so that the error only occurs once. */
10512 sym
->attr
.elemental
= 0;
10516 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10517 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10519 gfc_error ("Statement function '%s' at %L may not have pointer or "
10520 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10524 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10525 char-len-param shall not be array-valued, pointer-valued, recursive
10526 or pure. ....snip... A character value of * may only be used in the
10527 following ways: (i) Dummy arg of procedure - dummy associates with
10528 actual length; (ii) To declare a named constant; or (iii) External
10529 function - but length must be declared in calling scoping unit. */
10530 if (sym
->attr
.function
10531 && sym
->ts
.type
== BT_CHARACTER
10532 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10534 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10535 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10537 if (sym
->as
&& sym
->as
->rank
)
10538 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10539 "array-valued", sym
->name
, &sym
->declared_at
);
10541 if (sym
->attr
.pointer
)
10542 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10543 "pointer-valued", sym
->name
, &sym
->declared_at
);
10545 if (sym
->attr
.pure
)
10546 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10547 "pure", sym
->name
, &sym
->declared_at
);
10549 if (sym
->attr
.recursive
)
10550 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10551 "recursive", sym
->name
, &sym
->declared_at
);
10556 /* Appendix B.2 of the standard. Contained functions give an
10557 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10558 character length is an F2003 feature. */
10559 if (!sym
->attr
.contained
10560 && gfc_current_form
!= FORM_FIXED
10561 && !sym
->ts
.deferred
)
10562 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10563 "CHARACTER(*) function '%s' at %L",
10564 sym
->name
, &sym
->declared_at
);
10567 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10569 gfc_formal_arglist
*curr_arg
;
10570 int has_non_interop_arg
= 0;
10572 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10573 sym
->common_block
) == FAILURE
)
10575 /* Clear these to prevent looking at them again if there was an
10577 sym
->attr
.is_bind_c
= 0;
10578 sym
->attr
.is_c_interop
= 0;
10579 sym
->ts
.is_c_interop
= 0;
10583 /* So far, no errors have been found. */
10584 sym
->attr
.is_c_interop
= 1;
10585 sym
->ts
.is_c_interop
= 1;
10588 curr_arg
= sym
->formal
;
10589 while (curr_arg
!= NULL
)
10591 /* Skip implicitly typed dummy args here. */
10592 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10593 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10594 /* If something is found to fail, record the fact so we
10595 can mark the symbol for the procedure as not being
10596 BIND(C) to try and prevent multiple errors being
10598 has_non_interop_arg
= 1;
10600 curr_arg
= curr_arg
->next
;
10603 /* See if any of the arguments were not interoperable and if so, clear
10604 the procedure symbol to prevent duplicate error messages. */
10605 if (has_non_interop_arg
!= 0)
10607 sym
->attr
.is_c_interop
= 0;
10608 sym
->ts
.is_c_interop
= 0;
10609 sym
->attr
.is_bind_c
= 0;
10613 if (!sym
->attr
.proc_pointer
)
10615 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10617 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10618 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10621 if (sym
->attr
.intent
)
10623 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10624 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10627 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10629 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10630 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10633 if (sym
->attr
.external
&& sym
->attr
.function
10634 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10635 || sym
->attr
.contained
))
10637 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10638 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10641 if (strcmp ("ppr@", sym
->name
) == 0)
10643 gfc_error ("Procedure pointer result '%s' at %L "
10644 "is missing the pointer attribute",
10645 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10654 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10655 been defined and we now know their defined arguments, check that they fulfill
10656 the requirements of the standard for procedures used as finalizers. */
10659 gfc_resolve_finalizers (gfc_symbol
* derived
)
10661 gfc_finalizer
* list
;
10662 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10663 gfc_try result
= SUCCESS
;
10664 bool seen_scalar
= false;
10666 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10669 /* Walk over the list of finalizer-procedures, check them, and if any one
10670 does not fit in with the standard's definition, print an error and remove
10671 it from the list. */
10672 prev_link
= &derived
->f2k_derived
->finalizers
;
10673 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10679 /* Skip this finalizer if we already resolved it. */
10680 if (list
->proc_tree
)
10682 prev_link
= &(list
->next
);
10686 /* Check this exists and is a SUBROUTINE. */
10687 if (!list
->proc_sym
->attr
.subroutine
)
10689 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10690 list
->proc_sym
->name
, &list
->where
);
10694 /* We should have exactly one argument. */
10695 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10697 gfc_error ("FINAL procedure at %L must have exactly one argument",
10701 arg
= list
->proc_sym
->formal
->sym
;
10703 /* This argument must be of our type. */
10704 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10706 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10707 &arg
->declared_at
, derived
->name
);
10711 /* It must neither be a pointer nor allocatable nor optional. */
10712 if (arg
->attr
.pointer
)
10714 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10715 &arg
->declared_at
);
10718 if (arg
->attr
.allocatable
)
10720 gfc_error ("Argument of FINAL procedure at %L must not be"
10721 " ALLOCATABLE", &arg
->declared_at
);
10724 if (arg
->attr
.optional
)
10726 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10727 &arg
->declared_at
);
10731 /* It must not be INTENT(OUT). */
10732 if (arg
->attr
.intent
== INTENT_OUT
)
10734 gfc_error ("Argument of FINAL procedure at %L must not be"
10735 " INTENT(OUT)", &arg
->declared_at
);
10739 /* Warn if the procedure is non-scalar and not assumed shape. */
10740 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10741 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10742 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10743 " shape argument", &arg
->declared_at
);
10745 /* Check that it does not match in kind and rank with a FINAL procedure
10746 defined earlier. To really loop over the *earlier* declarations,
10747 we need to walk the tail of the list as new ones were pushed at the
10749 /* TODO: Handle kind parameters once they are implemented. */
10750 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10751 for (i
= list
->next
; i
; i
= i
->next
)
10753 /* Argument list might be empty; that is an error signalled earlier,
10754 but we nevertheless continued resolving. */
10755 if (i
->proc_sym
->formal
)
10757 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10758 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10759 if (i_rank
== my_rank
)
10761 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10762 " rank (%d) as '%s'",
10763 list
->proc_sym
->name
, &list
->where
, my_rank
,
10764 i
->proc_sym
->name
);
10770 /* Is this the/a scalar finalizer procedure? */
10771 if (!arg
->as
|| arg
->as
->rank
== 0)
10772 seen_scalar
= true;
10774 /* Find the symtree for this procedure. */
10775 gcc_assert (!list
->proc_tree
);
10776 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10778 prev_link
= &list
->next
;
10781 /* Remove wrong nodes immediately from the list so we don't risk any
10782 troubles in the future when they might fail later expectations. */
10786 *prev_link
= list
->next
;
10787 gfc_free_finalizer (i
);
10790 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10791 were nodes in the list, must have been for arrays. It is surely a good
10792 idea to have a scalar version there if there's something to finalize. */
10793 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10794 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10795 " defined at %L, suggest also scalar one",
10796 derived
->name
, &derived
->declared_at
);
10798 /* TODO: Remove this error when finalization is finished. */
10799 gfc_error ("Finalization at %L is not yet implemented",
10800 &derived
->declared_at
);
10806 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10809 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
10810 const char* generic_name
, locus where
)
10815 gcc_assert (t1
->specific
&& t2
->specific
);
10816 gcc_assert (!t1
->specific
->is_generic
);
10817 gcc_assert (!t2
->specific
->is_generic
);
10819 sym1
= t1
->specific
->u
.specific
->n
.sym
;
10820 sym2
= t2
->specific
->u
.specific
->n
.sym
;
10825 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10826 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
10827 || sym1
->attr
.function
!= sym2
->attr
.function
)
10829 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10830 " GENERIC '%s' at %L",
10831 sym1
->name
, sym2
->name
, generic_name
, &where
);
10835 /* Compare the interfaces. */
10836 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, 1, 0, NULL
, 0))
10838 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10839 sym1
->name
, sym2
->name
, generic_name
, &where
);
10847 /* Worker function for resolving a generic procedure binding; this is used to
10848 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10850 The difference between those cases is finding possible inherited bindings
10851 that are overridden, as one has to look for them in tb_sym_root,
10852 tb_uop_root or tb_op, respectively. Thus the caller must already find
10853 the super-type and set p->overridden correctly. */
10856 resolve_tb_generic_targets (gfc_symbol
* super_type
,
10857 gfc_typebound_proc
* p
, const char* name
)
10859 gfc_tbp_generic
* target
;
10860 gfc_symtree
* first_target
;
10861 gfc_symtree
* inherited
;
10863 gcc_assert (p
&& p
->is_generic
);
10865 /* Try to find the specific bindings for the symtrees in our target-list. */
10866 gcc_assert (p
->u
.generic
);
10867 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10868 if (!target
->specific
)
10870 gfc_typebound_proc
* overridden_tbp
;
10871 gfc_tbp_generic
* g
;
10872 const char* target_name
;
10874 target_name
= target
->specific_st
->name
;
10876 /* Defined for this type directly. */
10877 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
10879 target
->specific
= target
->specific_st
->n
.tb
;
10880 goto specific_found
;
10883 /* Look for an inherited specific binding. */
10886 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
10891 gcc_assert (inherited
->n
.tb
);
10892 target
->specific
= inherited
->n
.tb
;
10893 goto specific_found
;
10897 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10898 " at %L", target_name
, name
, &p
->where
);
10901 /* Once we've found the specific binding, check it is not ambiguous with
10902 other specifics already found or inherited for the same GENERIC. */
10904 gcc_assert (target
->specific
);
10906 /* This must really be a specific binding! */
10907 if (target
->specific
->is_generic
)
10909 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10910 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
10914 /* Check those already resolved on this type directly. */
10915 for (g
= p
->u
.generic
; g
; g
= g
->next
)
10916 if (g
!= target
&& g
->specific
10917 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
10921 /* Check for ambiguity with inherited specific targets. */
10922 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
10923 overridden_tbp
= overridden_tbp
->overridden
)
10924 if (overridden_tbp
->is_generic
)
10926 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
10928 gcc_assert (g
->specific
);
10929 if (check_generic_tbp_ambiguity (target
, g
,
10930 name
, p
->where
) == FAILURE
)
10936 /* If we attempt to "overwrite" a specific binding, this is an error. */
10937 if (p
->overridden
&& !p
->overridden
->is_generic
)
10939 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10940 " the same name", name
, &p
->where
);
10944 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10945 all must have the same attributes here. */
10946 first_target
= p
->u
.generic
->specific
->u
.specific
;
10947 gcc_assert (first_target
);
10948 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
10949 p
->function
= first_target
->n
.sym
->attr
.function
;
10955 /* Resolve a GENERIC procedure binding for a derived type. */
10958 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
10960 gfc_symbol
* super_type
;
10962 /* Find the overridden binding if any. */
10963 st
->n
.tb
->overridden
= NULL
;
10964 super_type
= gfc_get_derived_super_type (derived
);
10967 gfc_symtree
* overridden
;
10968 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
10971 if (overridden
&& overridden
->n
.tb
)
10972 st
->n
.tb
->overridden
= overridden
->n
.tb
;
10975 /* Resolve using worker function. */
10976 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
10980 /* Retrieve the target-procedure of an operator binding and do some checks in
10981 common for intrinsic and user-defined type-bound operators. */
10984 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
10986 gfc_symbol
* target_proc
;
10988 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
10989 target_proc
= target
->specific
->u
.specific
->n
.sym
;
10990 gcc_assert (target_proc
);
10992 /* All operator bindings must have a passed-object dummy argument. */
10993 if (target
->specific
->nopass
)
10995 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
10999 return target_proc
;
11003 /* Resolve a type-bound intrinsic operator. */
11006 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11007 gfc_typebound_proc
* p
)
11009 gfc_symbol
* super_type
;
11010 gfc_tbp_generic
* target
;
11012 /* If there's already an error here, do nothing (but don't fail again). */
11016 /* Operators should always be GENERIC bindings. */
11017 gcc_assert (p
->is_generic
);
11019 /* Look for an overridden binding. */
11020 super_type
= gfc_get_derived_super_type (derived
);
11021 if (super_type
&& super_type
->f2k_derived
)
11022 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11025 p
->overridden
= NULL
;
11027 /* Resolve general GENERIC properties using worker function. */
11028 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11031 /* Check the targets to be procedures of correct interface. */
11032 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11034 gfc_symbol
* target_proc
;
11036 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11040 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11052 /* Resolve a type-bound user operator (tree-walker callback). */
11054 static gfc_symbol
* resolve_bindings_derived
;
11055 static gfc_try resolve_bindings_result
;
11057 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11060 resolve_typebound_user_op (gfc_symtree
* stree
)
11062 gfc_symbol
* super_type
;
11063 gfc_tbp_generic
* target
;
11065 gcc_assert (stree
&& stree
->n
.tb
);
11067 if (stree
->n
.tb
->error
)
11070 /* Operators should always be GENERIC bindings. */
11071 gcc_assert (stree
->n
.tb
->is_generic
);
11073 /* Find overridden procedure, if any. */
11074 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11075 if (super_type
&& super_type
->f2k_derived
)
11077 gfc_symtree
* overridden
;
11078 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11079 stree
->name
, true, NULL
);
11081 if (overridden
&& overridden
->n
.tb
)
11082 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11085 stree
->n
.tb
->overridden
= NULL
;
11087 /* Resolve basically using worker function. */
11088 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11092 /* Check the targets to be functions of correct interface. */
11093 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11095 gfc_symbol
* target_proc
;
11097 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11101 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11108 resolve_bindings_result
= FAILURE
;
11109 stree
->n
.tb
->error
= 1;
11113 /* Resolve the type-bound procedures for a derived type. */
11116 resolve_typebound_procedure (gfc_symtree
* stree
)
11120 gfc_symbol
* me_arg
;
11121 gfc_symbol
* super_type
;
11122 gfc_component
* comp
;
11124 gcc_assert (stree
);
11126 /* Undefined specific symbol from GENERIC target definition. */
11130 if (stree
->n
.tb
->error
)
11133 /* If this is a GENERIC binding, use that routine. */
11134 if (stree
->n
.tb
->is_generic
)
11136 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11142 /* Get the target-procedure to check it. */
11143 gcc_assert (!stree
->n
.tb
->is_generic
);
11144 gcc_assert (stree
->n
.tb
->u
.specific
);
11145 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11146 where
= stree
->n
.tb
->where
;
11148 /* Default access should already be resolved from the parser. */
11149 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11151 /* It should be a module procedure or an external procedure with explicit
11152 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11153 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11154 || (proc
->attr
.proc
!= PROC_MODULE
11155 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11156 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11158 gfc_error ("'%s' must be a module procedure or an external procedure with"
11159 " an explicit interface at %L", proc
->name
, &where
);
11162 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11163 stree
->n
.tb
->function
= proc
->attr
.function
;
11165 /* Find the super-type of the current derived type. We could do this once and
11166 store in a global if speed is needed, but as long as not I believe this is
11167 more readable and clearer. */
11168 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11170 /* If PASS, resolve and check arguments if not already resolved / loaded
11171 from a .mod file. */
11172 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11174 if (stree
->n
.tb
->pass_arg
)
11176 gfc_formal_arglist
* i
;
11178 /* If an explicit passing argument name is given, walk the arg-list
11179 and look for it. */
11182 stree
->n
.tb
->pass_arg_num
= 1;
11183 for (i
= proc
->formal
; i
; i
= i
->next
)
11185 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11190 ++stree
->n
.tb
->pass_arg_num
;
11195 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11197 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11198 stree
->n
.tb
->pass_arg
);
11204 /* Otherwise, take the first one; there should in fact be at least
11206 stree
->n
.tb
->pass_arg_num
= 1;
11209 gfc_error ("Procedure '%s' with PASS at %L must have at"
11210 " least one argument", proc
->name
, &where
);
11213 me_arg
= proc
->formal
->sym
;
11216 /* Now check that the argument-type matches and the passed-object
11217 dummy argument is generally fine. */
11219 gcc_assert (me_arg
);
11221 if (me_arg
->ts
.type
!= BT_CLASS
)
11223 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11224 " at %L", proc
->name
, &where
);
11228 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11229 != resolve_bindings_derived
)
11231 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11232 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11233 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11237 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11238 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11240 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11241 " scalar", proc
->name
, &where
);
11244 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11246 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11247 " be ALLOCATABLE", proc
->name
, &where
);
11250 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11252 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11253 " be POINTER", proc
->name
, &where
);
11258 /* If we are extending some type, check that we don't override a procedure
11259 flagged NON_OVERRIDABLE. */
11260 stree
->n
.tb
->overridden
= NULL
;
11263 gfc_symtree
* overridden
;
11264 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11265 stree
->name
, true, NULL
);
11269 if (overridden
->n
.tb
)
11270 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11272 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11277 /* See if there's a name collision with a component directly in this type. */
11278 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11279 if (!strcmp (comp
->name
, stree
->name
))
11281 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11283 stree
->name
, &where
, resolve_bindings_derived
->name
);
11287 /* Try to find a name collision with an inherited component. */
11288 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11290 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11291 " component of '%s'",
11292 stree
->name
, &where
, resolve_bindings_derived
->name
);
11296 stree
->n
.tb
->error
= 0;
11300 resolve_bindings_result
= FAILURE
;
11301 stree
->n
.tb
->error
= 1;
11306 resolve_typebound_procedures (gfc_symbol
* derived
)
11309 gfc_symbol
* super_type
;
11311 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11314 super_type
= gfc_get_derived_super_type (derived
);
11316 resolve_typebound_procedures (super_type
);
11318 resolve_bindings_derived
= derived
;
11319 resolve_bindings_result
= SUCCESS
;
11321 /* Make sure the vtab has been generated. */
11322 gfc_find_derived_vtab (derived
);
11324 if (derived
->f2k_derived
->tb_sym_root
)
11325 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11326 &resolve_typebound_procedure
);
11328 if (derived
->f2k_derived
->tb_uop_root
)
11329 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11330 &resolve_typebound_user_op
);
11332 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11334 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11335 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11337 resolve_bindings_result
= FAILURE
;
11340 return resolve_bindings_result
;
11344 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11345 to give all identical derived types the same backend_decl. */
11347 add_dt_to_dt_list (gfc_symbol
*derived
)
11349 gfc_dt_list
*dt_list
;
11351 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11352 if (derived
== dt_list
->derived
)
11355 dt_list
= gfc_get_dt_list ();
11356 dt_list
->next
= gfc_derived_types
;
11357 dt_list
->derived
= derived
;
11358 gfc_derived_types
= dt_list
;
11362 /* Ensure that a derived-type is really not abstract, meaning that every
11363 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11366 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11371 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11373 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11376 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11378 gfc_symtree
* overriding
;
11379 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11382 gcc_assert (overriding
->n
.tb
);
11383 if (overriding
->n
.tb
->deferred
)
11385 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11386 " '%s' is DEFERRED and not overridden",
11387 sub
->name
, &sub
->declared_at
, st
->name
);
11396 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11398 /* The algorithm used here is to recursively travel up the ancestry of sub
11399 and for each ancestor-type, check all bindings. If any of them is
11400 DEFERRED, look it up starting from sub and see if the found (overriding)
11401 binding is not DEFERRED.
11402 This is not the most efficient way to do this, but it should be ok and is
11403 clearer than something sophisticated. */
11405 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11407 if (!ancestor
->attr
.abstract
)
11410 /* Walk bindings of this ancestor. */
11411 if (ancestor
->f2k_derived
)
11414 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11419 /* Find next ancestor type and recurse on it. */
11420 ancestor
= gfc_get_derived_super_type (ancestor
);
11422 return ensure_not_abstract (sub
, ancestor
);
11428 /* Resolve the components of a derived type. This does not have to wait until
11429 resolution stage, but can be done as soon as the dt declaration has been
11433 resolve_fl_derived0 (gfc_symbol
*sym
)
11435 gfc_symbol
* super_type
;
11438 super_type
= gfc_get_derived_super_type (sym
);
11441 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11443 gfc_error ("As extending type '%s' at %L has a coarray component, "
11444 "parent type '%s' shall also have one", sym
->name
,
11445 &sym
->declared_at
, super_type
->name
);
11449 /* Ensure the extended type gets resolved before we do. */
11450 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11453 /* An ABSTRACT type must be extensible. */
11454 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11456 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11457 sym
->name
, &sym
->declared_at
);
11461 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11464 for ( ; c
!= NULL
; c
= c
->next
)
11466 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11467 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
)
11469 gfc_error ("Deferred-length character component '%s' at %L is not "
11470 "yet supported", c
->name
, &c
->loc
);
11475 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11476 && c
->attr
.codimension
11477 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11479 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11480 "deferred shape", c
->name
, &c
->loc
);
11485 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11486 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11488 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11489 "shall not be a coarray", c
->name
, &c
->loc
);
11494 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11495 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11496 || c
->attr
.allocatable
))
11498 gfc_error ("Component '%s' at %L with coarray component "
11499 "shall be a nonpointer, nonallocatable scalar",
11505 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11507 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11508 "is not an array pointer", c
->name
, &c
->loc
);
11512 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11514 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11515 gfc_error ("Interface '%s', used by procedure pointer component "
11516 "'%s' at %L, is declared in a later PROCEDURE statement",
11517 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11519 /* Get the attributes from the interface (now resolved). */
11520 if (c
->ts
.interface
->attr
.if_source
11521 || c
->ts
.interface
->attr
.intrinsic
)
11523 gfc_symbol
*ifc
= c
->ts
.interface
;
11525 if (ifc
->formal
&& !ifc
->formal_ns
)
11526 resolve_symbol (ifc
);
11528 if (ifc
->attr
.intrinsic
)
11529 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11533 c
->ts
= ifc
->result
->ts
;
11534 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11535 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11536 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11537 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11542 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11543 c
->attr
.pointer
= ifc
->attr
.pointer
;
11544 c
->attr
.dimension
= ifc
->attr
.dimension
;
11545 c
->as
= gfc_copy_array_spec (ifc
->as
);
11547 c
->ts
.interface
= ifc
;
11548 c
->attr
.function
= ifc
->attr
.function
;
11549 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11550 gfc_copy_formal_args_ppc (c
, ifc
);
11552 c
->attr
.pure
= ifc
->attr
.pure
;
11553 c
->attr
.elemental
= ifc
->attr
.elemental
;
11554 c
->attr
.recursive
= ifc
->attr
.recursive
;
11555 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11556 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11557 /* Replace symbols in array spec. */
11561 for (i
= 0; i
< c
->as
->rank
; i
++)
11563 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11564 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11567 /* Copy char length. */
11568 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11570 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11571 gfc_expr_replace_comp (cl
->length
, c
);
11572 if (cl
->length
&& !cl
->resolved
11573 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11578 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11580 gfc_error ("Interface '%s' of procedure pointer component "
11581 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11586 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11588 /* Since PPCs are not implicitly typed, a PPC without an explicit
11589 interface must be a subroutine. */
11590 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11593 /* Procedure pointer components: Check PASS arg. */
11594 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11595 && !sym
->attr
.vtype
)
11597 gfc_symbol
* me_arg
;
11599 if (c
->tb
->pass_arg
)
11601 gfc_formal_arglist
* i
;
11603 /* If an explicit passing argument name is given, walk the arg-list
11604 and look for it. */
11607 c
->tb
->pass_arg_num
= 1;
11608 for (i
= c
->formal
; i
; i
= i
->next
)
11610 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11615 c
->tb
->pass_arg_num
++;
11620 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11621 "at %L has no argument '%s'", c
->name
,
11622 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11629 /* Otherwise, take the first one; there should in fact be at least
11631 c
->tb
->pass_arg_num
= 1;
11634 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11635 "must have at least one argument",
11640 me_arg
= c
->formal
->sym
;
11643 /* Now check that the argument-type matches. */
11644 gcc_assert (me_arg
);
11645 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11646 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11647 || (me_arg
->ts
.type
== BT_CLASS
11648 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11650 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11651 " the derived type '%s'", me_arg
->name
, c
->name
,
11652 me_arg
->name
, &c
->loc
, sym
->name
);
11657 /* Check for C453. */
11658 if (me_arg
->attr
.dimension
)
11660 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11661 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11667 if (me_arg
->attr
.pointer
)
11669 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11670 "may not have the POINTER attribute", me_arg
->name
,
11671 c
->name
, me_arg
->name
, &c
->loc
);
11676 if (me_arg
->attr
.allocatable
)
11678 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11679 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11680 me_arg
->name
, &c
->loc
);
11685 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11686 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11687 " at %L", c
->name
, &c
->loc
);
11691 /* Check type-spec if this is not the parent-type component. */
11692 if (((sym
->attr
.is_class
11693 && (!sym
->components
->ts
.u
.derived
->attr
.extension
11694 || c
!= sym
->components
->ts
.u
.derived
->components
))
11695 || (!sym
->attr
.is_class
11696 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
11697 && !sym
->attr
.vtype
11698 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11701 /* If this type is an extension, set the accessibility of the parent
11704 && ((sym
->attr
.is_class
11705 && c
== sym
->components
->ts
.u
.derived
->components
)
11706 || (!sym
->attr
.is_class
&& c
== sym
->components
))
11707 && strcmp (super_type
->name
, c
->name
) == 0)
11708 c
->attr
.access
= super_type
->attr
.access
;
11710 /* If this type is an extension, see if this component has the same name
11711 as an inherited type-bound procedure. */
11712 if (super_type
&& !sym
->attr
.is_class
11713 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11715 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11716 " inherited type-bound procedure",
11717 c
->name
, sym
->name
, &c
->loc
);
11721 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11722 && !c
->ts
.deferred
)
11724 if (c
->ts
.u
.cl
->length
== NULL
11725 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11726 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11728 gfc_error ("Character length of component '%s' needs to "
11729 "be a constant specification expression at %L",
11731 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11736 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11737 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11739 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11740 "length must be a POINTER or ALLOCATABLE",
11741 c
->name
, sym
->name
, &c
->loc
);
11745 if (c
->ts
.type
== BT_DERIVED
11746 && sym
->component_access
!= ACCESS_PRIVATE
11747 && gfc_check_symbol_access (sym
)
11748 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11749 && !c
->ts
.u
.derived
->attr
.use_assoc
11750 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
11751 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11752 "is a PRIVATE type and cannot be a component of "
11753 "'%s', which is PUBLIC at %L", c
->name
,
11754 sym
->name
, &sym
->declared_at
) == FAILURE
)
11757 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11759 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11760 "type %s", c
->name
, &c
->loc
, sym
->name
);
11764 if (sym
->attr
.sequence
)
11766 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11768 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11769 "not have the SEQUENCE attribute",
11770 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11775 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
11776 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
11777 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11778 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
11779 CLASS_DATA (c
)->ts
.u
.derived
11780 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
11782 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11783 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11784 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11786 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11787 "that has not been declared", c
->name
, sym
->name
,
11792 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11793 && CLASS_DATA (c
)->attr
.class_pointer
11794 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11795 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11797 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11798 "that has not been declared", c
->name
, sym
->name
,
11804 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
11805 && (!c
->attr
.class_ok
11806 || !(CLASS_DATA (c
)->attr
.class_pointer
11807 || CLASS_DATA (c
)->attr
.allocatable
)))
11809 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11810 "or pointer", c
->name
, &c
->loc
);
11814 /* Ensure that all the derived type components are put on the
11815 derived type list; even in formal namespaces, where derived type
11816 pointer components might not have been declared. */
11817 if (c
->ts
.type
== BT_DERIVED
11819 && c
->ts
.u
.derived
->components
11821 && sym
!= c
->ts
.u
.derived
)
11822 add_dt_to_dt_list (c
->ts
.u
.derived
);
11824 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
11825 || c
->attr
.proc_pointer
11826 || c
->attr
.allocatable
)) == FAILURE
)
11830 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11831 all DEFERRED bindings are overridden. */
11832 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
11833 && !sym
->attr
.is_class
11834 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
11837 /* Add derived type to the derived type list. */
11838 add_dt_to_dt_list (sym
);
11844 /* The following procedure does the full resolution of a derived type,
11845 including resolution of all type-bound procedures (if present). In contrast
11846 to 'resolve_fl_derived0' this can only be done after the module has been
11847 parsed completely. */
11850 resolve_fl_derived (gfc_symbol
*sym
)
11852 gfc_symbol
*gen_dt
= NULL
;
11854 if (!sym
->attr
.is_class
)
11855 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
11856 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
11857 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Generic name '%s' of "
11858 "function '%s' at %L being the same name as derived "
11859 "type at %L", sym
->name
,
11860 gen_dt
->generic
->sym
== sym
11861 ? gen_dt
->generic
->next
->sym
->name
11862 : gen_dt
->generic
->sym
->name
,
11863 gen_dt
->generic
->sym
== sym
11864 ? &gen_dt
->generic
->next
->sym
->declared_at
11865 : &gen_dt
->generic
->sym
->declared_at
,
11866 &sym
->declared_at
) == FAILURE
)
11869 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
11871 /* Fix up incomplete CLASS symbols. */
11872 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
11873 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
11874 if (vptr
->ts
.u
.derived
== NULL
)
11876 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
11878 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
11882 if (resolve_fl_derived0 (sym
) == FAILURE
)
11885 /* Resolve the type-bound procedures. */
11886 if (resolve_typebound_procedures (sym
) == FAILURE
)
11889 /* Resolve the finalizer procedures. */
11890 if (gfc_resolve_finalizers (sym
) == FAILURE
)
11898 resolve_fl_namelist (gfc_symbol
*sym
)
11903 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11905 /* Check again, the check in match only works if NAMELIST comes
11907 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
11909 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11910 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11914 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
11915 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11916 "object '%s' with assumed shape in namelist "
11917 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11918 &sym
->declared_at
) == FAILURE
)
11921 if (is_non_constant_shape_array (nl
->sym
)
11922 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11923 "object '%s' with nonconstant shape in namelist "
11924 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11925 &sym
->declared_at
) == FAILURE
)
11928 if (nl
->sym
->ts
.type
== BT_CHARACTER
11929 && (nl
->sym
->ts
.u
.cl
->length
== NULL
11930 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
11931 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11932 "'%s' with nonconstant character length in "
11933 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
11934 &sym
->declared_at
) == FAILURE
)
11937 /* FIXME: Once UDDTIO is implemented, the following can be
11939 if (nl
->sym
->ts
.type
== BT_CLASS
)
11941 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11942 "polymorphic and requires a defined input/output "
11943 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11947 if (nl
->sym
->ts
.type
== BT_DERIVED
11948 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
11949 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
11951 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11952 "'%s' in namelist '%s' at %L with ALLOCATABLE "
11953 "or POINTER components", nl
->sym
->name
,
11954 sym
->name
, &sym
->declared_at
) == FAILURE
)
11957 /* FIXME: Once UDDTIO is implemented, the following can be
11959 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11960 "ALLOCATABLE or POINTER components and thus requires "
11961 "a defined input/output procedure", nl
->sym
->name
,
11962 sym
->name
, &sym
->declared_at
);
11967 /* Reject PRIVATE objects in a PUBLIC namelist. */
11968 if (gfc_check_symbol_access (sym
))
11970 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11972 if (!nl
->sym
->attr
.use_assoc
11973 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
11974 && !gfc_check_symbol_access (nl
->sym
))
11976 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11977 "cannot be member of PUBLIC namelist '%s' at %L",
11978 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11982 /* Types with private components that came here by USE-association. */
11983 if (nl
->sym
->ts
.type
== BT_DERIVED
11984 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
11986 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11987 "components and cannot be member of namelist '%s' at %L",
11988 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11992 /* Types with private components that are defined in the same module. */
11993 if (nl
->sym
->ts
.type
== BT_DERIVED
11994 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
11995 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
11997 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11998 "cannot be a member of PUBLIC namelist '%s' at %L",
11999 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12006 /* 14.1.2 A module or internal procedure represent local entities
12007 of the same type as a namelist member and so are not allowed. */
12008 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12010 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12013 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12014 if ((nl
->sym
== sym
->ns
->proc_name
)
12016 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12020 if (nl
->sym
&& nl
->sym
->name
)
12021 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12022 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12024 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12025 "attribute in '%s' at %L", nlsym
->name
,
12026 &sym
->declared_at
);
12036 resolve_fl_parameter (gfc_symbol
*sym
)
12038 /* A parameter array's shape needs to be constant. */
12039 if (sym
->as
!= NULL
12040 && (sym
->as
->type
== AS_DEFERRED
12041 || is_non_constant_shape_array (sym
)))
12043 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12044 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12048 /* Make sure a parameter that has been implicitly typed still
12049 matches the implicit type, since PARAMETER statements can precede
12050 IMPLICIT statements. */
12051 if (sym
->attr
.implicit_type
12052 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12055 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12056 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12060 /* Make sure the types of derived parameters are consistent. This
12061 type checking is deferred until resolution because the type may
12062 refer to a derived type from the host. */
12063 if (sym
->ts
.type
== BT_DERIVED
&& sym
->value
12064 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12066 gfc_error ("Incompatible derived type in PARAMETER at %L",
12067 &sym
->value
->where
);
12074 /* Do anything necessary to resolve a symbol. Right now, we just
12075 assume that an otherwise unknown symbol is a variable. This sort
12076 of thing commonly happens for symbols in module. */
12079 resolve_symbol (gfc_symbol
*sym
)
12081 int check_constant
, mp_flag
;
12082 gfc_symtree
*symtree
;
12083 gfc_symtree
*this_symtree
;
12086 symbol_attribute class_attr
;
12087 gfc_array_spec
*as
;
12089 if (sym
->attr
.flavor
== FL_UNKNOWN
)
12092 /* If we find that a flavorless symbol is an interface in one of the
12093 parent namespaces, find its symtree in this namespace, free the
12094 symbol and set the symtree to point to the interface symbol. */
12095 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12097 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12098 if (symtree
&& (symtree
->n
.sym
->generic
||
12099 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12100 && sym
->ns
->construct_entities
)))
12102 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12104 gfc_release_symbol (sym
);
12105 symtree
->n
.sym
->refs
++;
12106 this_symtree
->n
.sym
= symtree
->n
.sym
;
12111 /* Otherwise give it a flavor according to such attributes as
12113 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
12114 sym
->attr
.flavor
= FL_VARIABLE
;
12117 sym
->attr
.flavor
= FL_PROCEDURE
;
12118 if (sym
->attr
.dimension
)
12119 sym
->attr
.function
= 1;
12123 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12124 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12126 if (sym
->attr
.procedure
&& sym
->ts
.interface
12127 && sym
->attr
.if_source
!= IFSRC_DECL
12128 && resolve_procedure_interface (sym
) == FAILURE
)
12131 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12132 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12134 if (sym
->attr
.external
)
12135 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12136 "at %L", &sym
->declared_at
);
12138 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12139 "at %L", &sym
->declared_at
);
12144 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12147 /* Symbols that are module procedures with results (functions) have
12148 the types and array specification copied for type checking in
12149 procedures that call them, as well as for saving to a module
12150 file. These symbols can't stand the scrutiny that their results
12152 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12154 /* Make sure that the intrinsic is consistent with its internal
12155 representation. This needs to be done before assigning a default
12156 type to avoid spurious warnings. */
12157 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12158 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12161 /* Resolve associate names. */
12163 resolve_assoc_var (sym
, true);
12165 /* Assign default type to symbols that need one and don't have one. */
12166 if (sym
->ts
.type
== BT_UNKNOWN
)
12168 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12170 gfc_set_default_type (sym
, 1, NULL
);
12173 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12174 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12175 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12176 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12178 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12180 /* The specific case of an external procedure should emit an error
12181 in the case that there is no implicit type. */
12183 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12186 /* Result may be in another namespace. */
12187 resolve_symbol (sym
->result
);
12189 if (!sym
->result
->attr
.proc_pointer
)
12191 sym
->ts
= sym
->result
->ts
;
12192 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12193 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12194 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12195 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12196 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12201 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12202 gfc_resolve_array_spec (sym
->result
->as
, false);
12204 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12206 as
= CLASS_DATA (sym
)->as
;
12207 class_attr
= CLASS_DATA (sym
)->attr
;
12208 class_attr
.pointer
= class_attr
.class_pointer
;
12212 class_attr
= sym
->attr
;
12217 if (sym
->attr
.contiguous
12218 && (!class_attr
.dimension
12219 || (as
->type
!= AS_ASSUMED_SHAPE
&& !class_attr
.pointer
)))
12221 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12222 "array pointer or an assumed-shape array", sym
->name
,
12223 &sym
->declared_at
);
12227 /* Assumed size arrays and assumed shape arrays must be dummy
12228 arguments. Array-spec's of implied-shape should have been resolved to
12229 AS_EXPLICIT already. */
12233 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12234 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12235 || as
->type
== AS_ASSUMED_SHAPE
)
12236 && sym
->attr
.dummy
== 0)
12238 if (as
->type
== AS_ASSUMED_SIZE
)
12239 gfc_error ("Assumed size array at %L must be a dummy argument",
12240 &sym
->declared_at
);
12242 gfc_error ("Assumed shape array at %L must be a dummy argument",
12243 &sym
->declared_at
);
12248 /* Make sure symbols with known intent or optional are really dummy
12249 variable. Because of ENTRY statement, this has to be deferred
12250 until resolution time. */
12252 if (!sym
->attr
.dummy
12253 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12255 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12259 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12261 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12262 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12266 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12268 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12269 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12271 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12272 "attribute must have constant length",
12273 sym
->name
, &sym
->declared_at
);
12277 if (sym
->ts
.is_c_interop
12278 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12280 gfc_error ("C interoperable character dummy variable '%s' at %L "
12281 "with VALUE attribute must have length one",
12282 sym
->name
, &sym
->declared_at
);
12287 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12288 && sym
->ts
.u
.derived
->attr
.generic
)
12290 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12291 if (!sym
->ts
.u
.derived
)
12293 gfc_error ("The derived type '%s' at %L is of type '%s', "
12294 "which has not been defined", sym
->name
,
12295 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12296 sym
->ts
.type
= BT_UNKNOWN
;
12301 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12302 do this for something that was implicitly typed because that is handled
12303 in gfc_set_default_type. Handle dummy arguments and procedure
12304 definitions separately. Also, anything that is use associated is not
12305 handled here but instead is handled in the module it is declared in.
12306 Finally, derived type definitions are allowed to be BIND(C) since that
12307 only implies that they're interoperable, and they are checked fully for
12308 interoperability when a variable is declared of that type. */
12309 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12310 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12311 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12313 gfc_try t
= SUCCESS
;
12315 /* First, make sure the variable is declared at the
12316 module-level scope (J3/04-007, Section 15.3). */
12317 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12318 sym
->attr
.in_common
== 0)
12320 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12321 "is neither a COMMON block nor declared at the "
12322 "module level scope", sym
->name
, &(sym
->declared_at
));
12325 else if (sym
->common_head
!= NULL
)
12327 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12331 /* If type() declaration, we need to verify that the components
12332 of the given type are all C interoperable, etc. */
12333 if (sym
->ts
.type
== BT_DERIVED
&&
12334 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12336 /* Make sure the user marked the derived type as BIND(C). If
12337 not, call the verify routine. This could print an error
12338 for the derived type more than once if multiple variables
12339 of that type are declared. */
12340 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12341 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12345 /* Verify the variable itself as C interoperable if it
12346 is BIND(C). It is not possible for this to succeed if
12347 the verify_bind_c_derived_type failed, so don't have to handle
12348 any error returned by verify_bind_c_derived_type. */
12349 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12350 sym
->common_block
);
12355 /* clear the is_bind_c flag to prevent reporting errors more than
12356 once if something failed. */
12357 sym
->attr
.is_bind_c
= 0;
12362 /* If a derived type symbol has reached this point, without its
12363 type being declared, we have an error. Notice that most
12364 conditions that produce undefined derived types have already
12365 been dealt with. However, the likes of:
12366 implicit type(t) (t) ..... call foo (t) will get us here if
12367 the type is not declared in the scope of the implicit
12368 statement. Change the type to BT_UNKNOWN, both because it is so
12369 and to prevent an ICE. */
12370 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12371 && sym
->ts
.u
.derived
->components
== NULL
12372 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12374 gfc_error ("The derived type '%s' at %L is of type '%s', "
12375 "which has not been defined", sym
->name
,
12376 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12377 sym
->ts
.type
= BT_UNKNOWN
;
12381 /* Make sure that the derived type has been resolved and that the
12382 derived type is visible in the symbol's namespace, if it is a
12383 module function and is not PRIVATE. */
12384 if (sym
->ts
.type
== BT_DERIVED
12385 && sym
->ts
.u
.derived
->attr
.use_assoc
12386 && sym
->ns
->proc_name
12387 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12388 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12391 /* Unless the derived-type declaration is use associated, Fortran 95
12392 does not allow public entries of private derived types.
12393 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12394 161 in 95-006r3. */
12395 if (sym
->ts
.type
== BT_DERIVED
12396 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12397 && !sym
->ts
.u
.derived
->attr
.use_assoc
12398 && gfc_check_symbol_access (sym
)
12399 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12400 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12401 "of PRIVATE derived type '%s'",
12402 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12403 : "variable", sym
->name
, &sym
->declared_at
,
12404 sym
->ts
.u
.derived
->name
) == FAILURE
)
12407 /* F2008, C1302. */
12408 if (sym
->ts
.type
== BT_DERIVED
12409 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12410 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12411 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12412 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12414 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12415 "type LOCK_TYPE must be a coarray", sym
->name
,
12416 &sym
->declared_at
);
12420 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12421 default initialization is defined (5.1.2.4.4). */
12422 if (sym
->ts
.type
== BT_DERIVED
12424 && sym
->attr
.intent
== INTENT_OUT
12426 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12428 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12430 if (c
->initializer
)
12432 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12433 "ASSUMED SIZE and so cannot have a default initializer",
12434 sym
->name
, &sym
->declared_at
);
12441 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12442 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12444 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12445 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12450 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12451 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12452 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12453 || class_attr
.codimension
)
12454 && (sym
->attr
.result
|| sym
->result
== sym
))
12456 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12457 "a coarray component", sym
->name
, &sym
->declared_at
);
12462 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12463 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12465 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12466 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12471 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12472 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12473 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12474 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12475 || class_attr
.allocatable
))
12477 gfc_error ("Variable '%s' at %L with coarray component "
12478 "shall be a nonpointer, nonallocatable scalar",
12479 sym
->name
, &sym
->declared_at
);
12483 /* F2008, C526. The function-result case was handled above. */
12484 if (class_attr
.codimension
12485 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12486 || sym
->attr
.select_type_temporary
12487 || sym
->ns
->save_all
12488 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12489 || sym
->ns
->proc_name
->attr
.is_main_program
12490 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12492 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12493 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12497 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
12498 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
12500 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12501 "deferred shape", sym
->name
, &sym
->declared_at
);
12504 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
12505 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
12507 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12508 "deferred shape", sym
->name
, &sym
->declared_at
);
12513 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12514 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12515 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12516 || (class_attr
.codimension
&& class_attr
.allocatable
))
12517 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12519 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12520 "allocatable coarray or have coarray components",
12521 sym
->name
, &sym
->declared_at
);
12525 if (class_attr
.codimension
&& sym
->attr
.dummy
12526 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12528 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12529 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12530 sym
->ns
->proc_name
->name
);
12534 switch (sym
->attr
.flavor
)
12537 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12542 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12547 if (resolve_fl_namelist (sym
) == FAILURE
)
12552 if (resolve_fl_parameter (sym
) == FAILURE
)
12560 /* Resolve array specifier. Check as well some constraints
12561 on COMMON blocks. */
12563 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12565 /* Set the formal_arg_flag so that check_conflict will not throw
12566 an error for host associated variables in the specification
12567 expression for an array_valued function. */
12568 if (sym
->attr
.function
&& sym
->as
)
12569 formal_arg_flag
= 1;
12571 gfc_resolve_array_spec (sym
->as
, check_constant
);
12573 formal_arg_flag
= 0;
12575 /* Resolve formal namespaces. */
12576 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12577 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12578 gfc_resolve (sym
->formal_ns
);
12580 /* Make sure the formal namespace is present. */
12581 if (sym
->formal
&& !sym
->formal_ns
)
12583 gfc_formal_arglist
*formal
= sym
->formal
;
12584 while (formal
&& !formal
->sym
)
12585 formal
= formal
->next
;
12589 sym
->formal_ns
= formal
->sym
->ns
;
12590 sym
->formal_ns
->refs
++;
12594 /* Check threadprivate restrictions. */
12595 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12596 && (!sym
->attr
.in_common
12597 && sym
->module
== NULL
12598 && (sym
->ns
->proc_name
== NULL
12599 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12600 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12602 /* If we have come this far we can apply default-initializers, as
12603 described in 14.7.5, to those variables that have not already
12604 been assigned one. */
12605 if (sym
->ts
.type
== BT_DERIVED
12606 && sym
->ns
== gfc_current_ns
12608 && !sym
->attr
.allocatable
12609 && !sym
->attr
.alloc_comp
)
12611 symbol_attribute
*a
= &sym
->attr
;
12613 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12614 && !a
->in_common
&& !a
->use_assoc
12615 && (a
->referenced
|| a
->result
)
12616 && !(a
->function
&& sym
!= sym
->result
))
12617 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12618 apply_default_init (sym
);
12621 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12622 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12623 && !CLASS_DATA (sym
)->attr
.class_pointer
12624 && !CLASS_DATA (sym
)->attr
.allocatable
)
12625 apply_default_init (sym
);
12627 /* If this symbol has a type-spec, check it. */
12628 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12629 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12630 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12636 /************* Resolve DATA statements *************/
12640 gfc_data_value
*vnode
;
12646 /* Advance the values structure to point to the next value in the data list. */
12649 next_data_value (void)
12651 while (mpz_cmp_ui (values
.left
, 0) == 0)
12654 if (values
.vnode
->next
== NULL
)
12657 values
.vnode
= values
.vnode
->next
;
12658 mpz_set (values
.left
, values
.vnode
->repeat
);
12666 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12672 ar_type mark
= AR_UNKNOWN
;
12674 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12680 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12684 mpz_init_set_si (offset
, 0);
12687 if (e
->expr_type
!= EXPR_VARIABLE
)
12688 gfc_internal_error ("check_data_variable(): Bad expression");
12690 sym
= e
->symtree
->n
.sym
;
12692 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12694 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12695 sym
->name
, &sym
->declared_at
);
12698 if (e
->ref
== NULL
&& sym
->as
)
12700 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12701 " declaration", sym
->name
, where
);
12705 has_pointer
= sym
->attr
.pointer
;
12707 if (gfc_is_coindexed (e
))
12709 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
12714 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12716 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12720 && ref
->type
== REF_ARRAY
12721 && ref
->u
.ar
.type
!= AR_FULL
)
12723 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12724 "be a full array", sym
->name
, where
);
12729 if (e
->rank
== 0 || has_pointer
)
12731 mpz_init_set_ui (size
, 1);
12738 /* Find the array section reference. */
12739 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12741 if (ref
->type
!= REF_ARRAY
)
12743 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12749 /* Set marks according to the reference pattern. */
12750 switch (ref
->u
.ar
.type
)
12758 /* Get the start position of array section. */
12759 gfc_get_section_index (ar
, section_index
, &offset
);
12764 gcc_unreachable ();
12767 if (gfc_array_size (e
, &size
) == FAILURE
)
12769 gfc_error ("Nonconstant array section at %L in DATA statement",
12771 mpz_clear (offset
);
12778 while (mpz_cmp_ui (size
, 0) > 0)
12780 if (next_data_value () == FAILURE
)
12782 gfc_error ("DATA statement at %L has more variables than values",
12788 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
12792 /* If we have more than one element left in the repeat count,
12793 and we have more than one element left in the target variable,
12794 then create a range assignment. */
12795 /* FIXME: Only done for full arrays for now, since array sections
12797 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
12798 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
12802 if (mpz_cmp (size
, values
.left
) >= 0)
12804 mpz_init_set (range
, values
.left
);
12805 mpz_sub (size
, size
, values
.left
);
12806 mpz_set_ui (values
.left
, 0);
12810 mpz_init_set (range
, size
);
12811 mpz_sub (values
.left
, values
.left
, size
);
12812 mpz_set_ui (size
, 0);
12815 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
12818 mpz_add (offset
, offset
, range
);
12825 /* Assign initial value to symbol. */
12828 mpz_sub_ui (values
.left
, values
.left
, 1);
12829 mpz_sub_ui (size
, size
, 1);
12831 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
12836 if (mark
== AR_FULL
)
12837 mpz_add_ui (offset
, offset
, 1);
12839 /* Modify the array section indexes and recalculate the offset
12840 for next element. */
12841 else if (mark
== AR_SECTION
)
12842 gfc_advance_section (section_index
, ar
, &offset
);
12846 if (mark
== AR_SECTION
)
12848 for (i
= 0; i
< ar
->dimen
; i
++)
12849 mpz_clear (section_index
[i
]);
12853 mpz_clear (offset
);
12859 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
12861 /* Iterate over a list of elements in a DATA statement. */
12864 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
12867 iterator_stack frame
;
12868 gfc_expr
*e
, *start
, *end
, *step
;
12869 gfc_try retval
= SUCCESS
;
12871 mpz_init (frame
.value
);
12874 start
= gfc_copy_expr (var
->iter
.start
);
12875 end
= gfc_copy_expr (var
->iter
.end
);
12876 step
= gfc_copy_expr (var
->iter
.step
);
12878 if (gfc_simplify_expr (start
, 1) == FAILURE
12879 || start
->expr_type
!= EXPR_CONSTANT
)
12881 gfc_error ("start of implied-do loop at %L could not be "
12882 "simplified to a constant value", &start
->where
);
12886 if (gfc_simplify_expr (end
, 1) == FAILURE
12887 || end
->expr_type
!= EXPR_CONSTANT
)
12889 gfc_error ("end of implied-do loop at %L could not be "
12890 "simplified to a constant value", &start
->where
);
12894 if (gfc_simplify_expr (step
, 1) == FAILURE
12895 || step
->expr_type
!= EXPR_CONSTANT
)
12897 gfc_error ("step of implied-do loop at %L could not be "
12898 "simplified to a constant value", &start
->where
);
12903 mpz_set (trip
, end
->value
.integer
);
12904 mpz_sub (trip
, trip
, start
->value
.integer
);
12905 mpz_add (trip
, trip
, step
->value
.integer
);
12907 mpz_div (trip
, trip
, step
->value
.integer
);
12909 mpz_set (frame
.value
, start
->value
.integer
);
12911 frame
.prev
= iter_stack
;
12912 frame
.variable
= var
->iter
.var
->symtree
;
12913 iter_stack
= &frame
;
12915 while (mpz_cmp_ui (trip
, 0) > 0)
12917 if (traverse_data_var (var
->list
, where
) == FAILURE
)
12923 e
= gfc_copy_expr (var
->expr
);
12924 if (gfc_simplify_expr (e
, 1) == FAILURE
)
12931 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
12933 mpz_sub_ui (trip
, trip
, 1);
12937 mpz_clear (frame
.value
);
12940 gfc_free_expr (start
);
12941 gfc_free_expr (end
);
12942 gfc_free_expr (step
);
12944 iter_stack
= frame
.prev
;
12949 /* Type resolve variables in the variable list of a DATA statement. */
12952 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
12956 for (; var
; var
= var
->next
)
12958 if (var
->expr
== NULL
)
12959 t
= traverse_data_list (var
, where
);
12961 t
= check_data_variable (var
, where
);
12971 /* Resolve the expressions and iterators associated with a data statement.
12972 This is separate from the assignment checking because data lists should
12973 only be resolved once. */
12976 resolve_data_variables (gfc_data_variable
*d
)
12978 for (; d
; d
= d
->next
)
12980 if (d
->list
== NULL
)
12982 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
12987 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
12990 if (resolve_data_variables (d
->list
) == FAILURE
)
12999 /* Resolve a single DATA statement. We implement this by storing a pointer to
13000 the value list into static variables, and then recursively traversing the
13001 variables list, expanding iterators and such. */
13004 resolve_data (gfc_data
*d
)
13007 if (resolve_data_variables (d
->var
) == FAILURE
)
13010 values
.vnode
= d
->value
;
13011 if (d
->value
== NULL
)
13012 mpz_set_ui (values
.left
, 0);
13014 mpz_set (values
.left
, d
->value
->repeat
);
13016 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13019 /* At this point, we better not have any values left. */
13021 if (next_data_value () == SUCCESS
)
13022 gfc_error ("DATA statement at %L has more values than variables",
13027 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13028 accessed by host or use association, is a dummy argument to a pure function,
13029 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13030 is storage associated with any such variable, shall not be used in the
13031 following contexts: (clients of this function). */
13033 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13034 procedure. Returns zero if assignment is OK, nonzero if there is a
13037 gfc_impure_variable (gfc_symbol
*sym
)
13042 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13045 /* Check if the symbol's ns is inside the pure procedure. */
13046 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13050 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13054 proc
= sym
->ns
->proc_name
;
13055 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13056 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13058 proc
->attr
.function
))
13061 /* TODO: Sort out what can be storage associated, if anything, and include
13062 it here. In principle equivalences should be scanned but it does not
13063 seem to be possible to storage associate an impure variable this way. */
13068 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13069 current namespace is inside a pure procedure. */
13072 gfc_pure (gfc_symbol
*sym
)
13074 symbol_attribute attr
;
13079 /* Check if the current namespace or one of its parents
13080 belongs to a pure procedure. */
13081 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13083 sym
= ns
->proc_name
;
13087 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13095 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13099 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13100 checks if the current namespace is implicitly pure. Note that this
13101 function returns false for a PURE procedure. */
13104 gfc_implicit_pure (gfc_symbol
*sym
)
13106 symbol_attribute attr
;
13110 /* Check if the current namespace is implicit_pure. */
13111 sym
= gfc_current_ns
->proc_name
;
13115 if (attr
.flavor
== FL_PROCEDURE
13116 && attr
.implicit_pure
&& !attr
.pure
)
13123 return attr
.flavor
== FL_PROCEDURE
&& attr
.implicit_pure
&& !attr
.pure
;
13127 /* Test whether the current procedure is elemental or not. */
13130 gfc_elemental (gfc_symbol
*sym
)
13132 symbol_attribute attr
;
13135 sym
= gfc_current_ns
->proc_name
;
13140 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13144 /* Warn about unused labels. */
13147 warn_unused_fortran_label (gfc_st_label
*label
)
13152 warn_unused_fortran_label (label
->left
);
13154 if (label
->defined
== ST_LABEL_UNKNOWN
)
13157 switch (label
->referenced
)
13159 case ST_LABEL_UNKNOWN
:
13160 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13164 case ST_LABEL_BAD_TARGET
:
13165 gfc_warning ("Label %d at %L defined but cannot be used",
13166 label
->value
, &label
->where
);
13173 warn_unused_fortran_label (label
->right
);
13177 /* Returns the sequence type of a symbol or sequence. */
13180 sequence_type (gfc_typespec ts
)
13189 if (ts
.u
.derived
->components
== NULL
)
13190 return SEQ_NONDEFAULT
;
13192 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13193 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13194 if (sequence_type (c
->ts
) != result
)
13200 if (ts
.kind
!= gfc_default_character_kind
)
13201 return SEQ_NONDEFAULT
;
13203 return SEQ_CHARACTER
;
13206 if (ts
.kind
!= gfc_default_integer_kind
)
13207 return SEQ_NONDEFAULT
;
13209 return SEQ_NUMERIC
;
13212 if (!(ts
.kind
== gfc_default_real_kind
13213 || ts
.kind
== gfc_default_double_kind
))
13214 return SEQ_NONDEFAULT
;
13216 return SEQ_NUMERIC
;
13219 if (ts
.kind
!= gfc_default_complex_kind
)
13220 return SEQ_NONDEFAULT
;
13222 return SEQ_NUMERIC
;
13225 if (ts
.kind
!= gfc_default_logical_kind
)
13226 return SEQ_NONDEFAULT
;
13228 return SEQ_NUMERIC
;
13231 return SEQ_NONDEFAULT
;
13236 /* Resolve derived type EQUIVALENCE object. */
13239 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13241 gfc_component
*c
= derived
->components
;
13246 /* Shall not be an object of nonsequence derived type. */
13247 if (!derived
->attr
.sequence
)
13249 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13250 "attribute to be an EQUIVALENCE object", sym
->name
,
13255 /* Shall not have allocatable components. */
13256 if (derived
->attr
.alloc_comp
)
13258 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13259 "components to be an EQUIVALENCE object",sym
->name
,
13264 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13266 gfc_error ("Derived type variable '%s' at %L with default "
13267 "initialization cannot be in EQUIVALENCE with a variable "
13268 "in COMMON", sym
->name
, &e
->where
);
13272 for (; c
; c
= c
->next
)
13274 if (c
->ts
.type
== BT_DERIVED
13275 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13278 /* Shall not be an object of sequence derived type containing a pointer
13279 in the structure. */
13280 if (c
->attr
.pointer
)
13282 gfc_error ("Derived type variable '%s' at %L with pointer "
13283 "component(s) cannot be an EQUIVALENCE object",
13284 sym
->name
, &e
->where
);
13292 /* Resolve equivalence object.
13293 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13294 an allocatable array, an object of nonsequence derived type, an object of
13295 sequence derived type containing a pointer at any level of component
13296 selection, an automatic object, a function name, an entry name, a result
13297 name, a named constant, a structure component, or a subobject of any of
13298 the preceding objects. A substring shall not have length zero. A
13299 derived type shall not have components with default initialization nor
13300 shall two objects of an equivalence group be initialized.
13301 Either all or none of the objects shall have an protected attribute.
13302 The simple constraints are done in symbol.c(check_conflict) and the rest
13303 are implemented here. */
13306 resolve_equivalence (gfc_equiv
*eq
)
13309 gfc_symbol
*first_sym
;
13312 locus
*last_where
= NULL
;
13313 seq_type eq_type
, last_eq_type
;
13314 gfc_typespec
*last_ts
;
13315 int object
, cnt_protected
;
13318 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13320 first_sym
= eq
->expr
->symtree
->n
.sym
;
13324 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13328 e
->ts
= e
->symtree
->n
.sym
->ts
;
13329 /* match_varspec might not know yet if it is seeing
13330 array reference or substring reference, as it doesn't
13332 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13334 gfc_ref
*ref
= e
->ref
;
13335 sym
= e
->symtree
->n
.sym
;
13337 if (sym
->attr
.dimension
)
13339 ref
->u
.ar
.as
= sym
->as
;
13343 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13344 if (e
->ts
.type
== BT_CHARACTER
13346 && ref
->type
== REF_ARRAY
13347 && ref
->u
.ar
.dimen
== 1
13348 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13349 && ref
->u
.ar
.stride
[0] == NULL
)
13351 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13352 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13355 /* Optimize away the (:) reference. */
13356 if (start
== NULL
&& end
== NULL
)
13359 e
->ref
= ref
->next
;
13361 e
->ref
->next
= ref
->next
;
13366 ref
->type
= REF_SUBSTRING
;
13368 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13370 ref
->u
.ss
.start
= start
;
13371 if (end
== NULL
&& e
->ts
.u
.cl
)
13372 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13373 ref
->u
.ss
.end
= end
;
13374 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13381 /* Any further ref is an error. */
13384 gcc_assert (ref
->type
== REF_ARRAY
);
13385 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13391 if (gfc_resolve_expr (e
) == FAILURE
)
13394 sym
= e
->symtree
->n
.sym
;
13396 if (sym
->attr
.is_protected
)
13398 if (cnt_protected
> 0 && cnt_protected
!= object
)
13400 gfc_error ("Either all or none of the objects in the "
13401 "EQUIVALENCE set at %L shall have the "
13402 "PROTECTED attribute",
13407 /* Shall not equivalence common block variables in a PURE procedure. */
13408 if (sym
->ns
->proc_name
13409 && sym
->ns
->proc_name
->attr
.pure
13410 && sym
->attr
.in_common
)
13412 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13413 "object in the pure procedure '%s'",
13414 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13418 /* Shall not be a named constant. */
13419 if (e
->expr_type
== EXPR_CONSTANT
)
13421 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13422 "object", sym
->name
, &e
->where
);
13426 if (e
->ts
.type
== BT_DERIVED
13427 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13430 /* Check that the types correspond correctly:
13432 A numeric sequence structure may be equivalenced to another sequence
13433 structure, an object of default integer type, default real type, double
13434 precision real type, default logical type such that components of the
13435 structure ultimately only become associated to objects of the same
13436 kind. A character sequence structure may be equivalenced to an object
13437 of default character kind or another character sequence structure.
13438 Other objects may be equivalenced only to objects of the same type and
13439 kind parameters. */
13441 /* Identical types are unconditionally OK. */
13442 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13443 goto identical_types
;
13445 last_eq_type
= sequence_type (*last_ts
);
13446 eq_type
= sequence_type (sym
->ts
);
13448 /* Since the pair of objects is not of the same type, mixed or
13449 non-default sequences can be rejected. */
13451 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13452 "statement at %L with different type objects";
13454 && last_eq_type
== SEQ_MIXED
13455 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13457 || (eq_type
== SEQ_MIXED
13458 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13459 &e
->where
) == FAILURE
))
13462 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13463 "statement at %L with objects of different type";
13465 && last_eq_type
== SEQ_NONDEFAULT
13466 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13467 last_where
) == FAILURE
)
13468 || (eq_type
== SEQ_NONDEFAULT
13469 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13470 &e
->where
) == FAILURE
))
13473 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13474 "EQUIVALENCE statement at %L";
13475 if (last_eq_type
== SEQ_CHARACTER
13476 && eq_type
!= SEQ_CHARACTER
13477 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13478 &e
->where
) == FAILURE
)
13481 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13482 "EQUIVALENCE statement at %L";
13483 if (last_eq_type
== SEQ_NUMERIC
13484 && eq_type
!= SEQ_NUMERIC
13485 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13486 &e
->where
) == FAILURE
)
13491 last_where
= &e
->where
;
13496 /* Shall not be an automatic array. */
13497 if (e
->ref
->type
== REF_ARRAY
13498 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13500 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13501 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13508 /* Shall not be a structure component. */
13509 if (r
->type
== REF_COMPONENT
)
13511 gfc_error ("Structure component '%s' at %L cannot be an "
13512 "EQUIVALENCE object",
13513 r
->u
.c
.component
->name
, &e
->where
);
13517 /* A substring shall not have length zero. */
13518 if (r
->type
== REF_SUBSTRING
)
13520 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13522 gfc_error ("Substring at %L has length zero",
13523 &r
->u
.ss
.start
->where
);
13533 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13536 resolve_fntype (gfc_namespace
*ns
)
13538 gfc_entry_list
*el
;
13541 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13544 /* If there are any entries, ns->proc_name is the entry master
13545 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13547 sym
= ns
->entries
->sym
;
13549 sym
= ns
->proc_name
;
13550 if (sym
->result
== sym
13551 && sym
->ts
.type
== BT_UNKNOWN
13552 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13553 && !sym
->attr
.untyped
)
13555 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13556 sym
->name
, &sym
->declared_at
);
13557 sym
->attr
.untyped
= 1;
13560 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13561 && !sym
->attr
.contained
13562 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13563 && gfc_check_symbol_access (sym
))
13565 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13566 "%L of PRIVATE type '%s'", sym
->name
,
13567 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13571 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13573 if (el
->sym
->result
== el
->sym
13574 && el
->sym
->ts
.type
== BT_UNKNOWN
13575 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13576 && !el
->sym
->attr
.untyped
)
13578 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13579 el
->sym
->name
, &el
->sym
->declared_at
);
13580 el
->sym
->attr
.untyped
= 1;
13586 /* 12.3.2.1.1 Defined operators. */
13589 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13591 gfc_formal_arglist
*formal
;
13593 if (!sym
->attr
.function
)
13595 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13596 sym
->name
, &where
);
13600 if (sym
->ts
.type
== BT_CHARACTER
13601 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13602 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13603 && sym
->result
->ts
.u
.cl
->length
))
13605 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13606 "character length", sym
->name
, &where
);
13610 formal
= sym
->formal
;
13611 if (!formal
|| !formal
->sym
)
13613 gfc_error ("User operator procedure '%s' at %L must have at least "
13614 "one argument", sym
->name
, &where
);
13618 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13620 gfc_error ("First argument of operator interface at %L must be "
13621 "INTENT(IN)", &where
);
13625 if (formal
->sym
->attr
.optional
)
13627 gfc_error ("First argument of operator interface at %L cannot be "
13628 "optional", &where
);
13632 formal
= formal
->next
;
13633 if (!formal
|| !formal
->sym
)
13636 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13638 gfc_error ("Second argument of operator interface at %L must be "
13639 "INTENT(IN)", &where
);
13643 if (formal
->sym
->attr
.optional
)
13645 gfc_error ("Second argument of operator interface at %L cannot be "
13646 "optional", &where
);
13652 gfc_error ("Operator interface at %L must have, at most, two "
13653 "arguments", &where
);
13661 gfc_resolve_uops (gfc_symtree
*symtree
)
13663 gfc_interface
*itr
;
13665 if (symtree
== NULL
)
13668 gfc_resolve_uops (symtree
->left
);
13669 gfc_resolve_uops (symtree
->right
);
13671 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13672 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13676 /* Examine all of the expressions associated with a program unit,
13677 assign types to all intermediate expressions, make sure that all
13678 assignments are to compatible types and figure out which names
13679 refer to which functions or subroutines. It doesn't check code
13680 block, which is handled by resolve_code. */
13683 resolve_types (gfc_namespace
*ns
)
13689 gfc_namespace
* old_ns
= gfc_current_ns
;
13691 /* Check that all IMPLICIT types are ok. */
13692 if (!ns
->seen_implicit_none
)
13695 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13696 if (ns
->set_flag
[letter
]
13697 && resolve_typespec_used (&ns
->default_type
[letter
],
13698 &ns
->implicit_loc
[letter
],
13703 gfc_current_ns
= ns
;
13705 resolve_entries (ns
);
13707 resolve_common_vars (ns
->blank_common
.head
, false);
13708 resolve_common_blocks (ns
->common_root
);
13710 resolve_contained_functions (ns
);
13712 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
13713 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
13714 resolve_formal_arglist (ns
->proc_name
);
13716 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13718 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13719 resolve_charlen (cl
);
13721 gfc_traverse_ns (ns
, resolve_symbol
);
13723 resolve_fntype (ns
);
13725 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13727 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13728 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13729 "also be PURE", n
->proc_name
->name
,
13730 &n
->proc_name
->declared_at
);
13736 do_concurrent_flag
= 0;
13737 gfc_check_interfaces (ns
);
13739 gfc_traverse_ns (ns
, resolve_values
);
13745 for (d
= ns
->data
; d
; d
= d
->next
)
13749 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13751 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13753 if (ns
->common_root
!= NULL
)
13754 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13756 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13757 resolve_equivalence (eq
);
13759 /* Warn about unused labels. */
13760 if (warn_unused_label
)
13761 warn_unused_fortran_label (ns
->st_labels
);
13763 gfc_resolve_uops (ns
->uop_root
);
13765 gfc_current_ns
= old_ns
;
13769 /* Call resolve_code recursively. */
13772 resolve_codes (gfc_namespace
*ns
)
13775 bitmap_obstack old_obstack
;
13777 if (ns
->resolved
== 1)
13780 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13783 gfc_current_ns
= ns
;
13785 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13786 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
13789 /* Set to an out of range value. */
13790 current_entry_id
= -1;
13792 old_obstack
= labels_obstack
;
13793 bitmap_obstack_initialize (&labels_obstack
);
13795 resolve_code (ns
->code
, ns
);
13797 bitmap_obstack_release (&labels_obstack
);
13798 labels_obstack
= old_obstack
;
13802 /* This function is called after a complete program unit has been compiled.
13803 Its purpose is to examine all of the expressions associated with a program
13804 unit, assign types to all intermediate expressions, make sure that all
13805 assignments are to compatible types and figure out which names refer to
13806 which functions or subroutines. */
13809 gfc_resolve (gfc_namespace
*ns
)
13811 gfc_namespace
*old_ns
;
13812 code_stack
*old_cs_base
;
13818 old_ns
= gfc_current_ns
;
13819 old_cs_base
= cs_base
;
13821 resolve_types (ns
);
13822 resolve_codes (ns
);
13824 gfc_current_ns
= old_ns
;
13825 cs_base
= old_cs_base
;
13828 gfc_run_passes (ns
);