1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 static int do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface '%s' at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface '%s' at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface '%s' at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "'%s' at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
394 " of pure function '%s' at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument '%s' of pure function '%s' at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
407 " of pure subroutine '%s' at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (proc
->attr
.implicit_pure
)
421 if (sym
->attr
.flavor
== FL_PROCEDURE
)
424 proc
->attr
.implicit_pure
= 0;
426 else if (!sym
->attr
.pointer
)
428 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
430 proc
->attr
.implicit_pure
= 0;
432 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
434 proc
->attr
.implicit_pure
= 0;
438 if (gfc_elemental (proc
))
441 if (sym
->attr
.codimension
442 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
443 && CLASS_DATA (sym
)->attr
.codimension
))
445 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
446 "procedure", sym
->name
, &sym
->declared_at
);
450 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
451 && CLASS_DATA (sym
)->as
))
453 gfc_error ("Argument '%s' of elemental procedure at %L must "
454 "be scalar", sym
->name
, &sym
->declared_at
);
458 if (sym
->attr
.allocatable
459 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->attr
.allocatable
))
462 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
463 "have the ALLOCATABLE attribute", sym
->name
,
468 if (sym
->attr
.pointer
469 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
470 && CLASS_DATA (sym
)->attr
.class_pointer
))
472 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
473 "have the POINTER attribute", sym
->name
,
478 if (sym
->attr
.flavor
== FL_PROCEDURE
)
480 gfc_error ("Dummy procedure '%s' not allowed in elemental "
481 "procedure '%s' at %L", sym
->name
, proc
->name
,
486 /* Fortran 2008 Corrigendum 1, C1290a. */
487 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
489 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
490 "have its INTENT specified or have the VALUE "
491 "attribute", sym
->name
, proc
->name
,
497 /* Each dummy shall be specified to be scalar. */
498 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
502 gfc_error ("Argument '%s' of statement function at %L must "
503 "be scalar", sym
->name
, &sym
->declared_at
);
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
510 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
512 gfc_error ("Character-valued argument '%s' of statement "
513 "function at %L must have constant length",
514 sym
->name
, &sym
->declared_at
);
524 /* Work function called when searching for symbols that have argument lists
525 associated with them. */
528 find_arglists (gfc_symbol
*sym
)
530 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
531 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
534 resolve_formal_arglist (sym
);
538 /* Given a namespace, resolve all formal argument lists within the namespace.
542 resolve_formal_arglists (gfc_namespace
*ns
)
547 gfc_traverse_ns (ns
, find_arglists
);
552 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
556 /* If this namespace is not a function or an entry master function,
558 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
559 || sym
->attr
.entry_master
)
562 /* Try to find out of what the return type is. */
563 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
565 t
= gfc_set_default_type (sym
->result
, 0, ns
);
567 if (!t
&& !sym
->result
->attr
.untyped
)
569 if (sym
->result
== sym
)
570 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
571 sym
->name
, &sym
->declared_at
);
572 else if (!sym
->result
->attr
.proc_pointer
)
573 gfc_error ("Result '%s' of contained function '%s' at %L has "
574 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
575 &sym
->result
->declared_at
);
576 sym
->result
->attr
.untyped
= 1;
580 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
581 type, lists the only ways a character length value of * can be used:
582 dummy arguments of procedures, named constants, and function results
583 in external functions. Internal function results and results of module
584 procedures are not on this list, ergo, not permitted. */
586 if (sym
->result
->ts
.type
== BT_CHARACTER
)
588 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
589 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
591 /* See if this is a module-procedure and adapt error message
594 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
595 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
597 gfc_error ("Character-valued %s '%s' at %L must not be"
599 module_proc
? _("module procedure")
600 : _("internal function"),
601 sym
->name
, &sym
->declared_at
);
607 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
608 introduce duplicates. */
611 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
613 gfc_formal_arglist
*f
, *new_arglist
;
616 for (; new_args
!= NULL
; new_args
= new_args
->next
)
618 new_sym
= new_args
->sym
;
619 /* See if this arg is already in the formal argument list. */
620 for (f
= proc
->formal
; f
; f
= f
->next
)
622 if (new_sym
== f
->sym
)
629 /* Add a new argument. Argument order is not important. */
630 new_arglist
= gfc_get_formal_arglist ();
631 new_arglist
->sym
= new_sym
;
632 new_arglist
->next
= proc
->formal
;
633 proc
->formal
= new_arglist
;
638 /* Flag the arguments that are not present in all entries. */
641 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
643 gfc_formal_arglist
*f
, *head
;
646 for (f
= proc
->formal
; f
; f
= f
->next
)
651 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
653 if (new_args
->sym
== f
->sym
)
660 f
->sym
->attr
.not_always_present
= 1;
665 /* Resolve alternate entry points. If a symbol has multiple entry points we
666 create a new master symbol for the main routine, and turn the existing
667 symbol into an entry point. */
670 resolve_entries (gfc_namespace
*ns
)
672 gfc_namespace
*old_ns
;
676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
677 static int master_count
= 0;
679 if (ns
->proc_name
== NULL
)
682 /* No need to do anything if this procedure doesn't have alternate entry
687 /* We may already have resolved alternate entry points. */
688 if (ns
->proc_name
->attr
.entry_master
)
691 /* If this isn't a procedure something has gone horribly wrong. */
692 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
694 /* Remember the current namespace. */
695 old_ns
= gfc_current_ns
;
699 /* Add the main entry point to the list of entry points. */
700 el
= gfc_get_entry_list ();
701 el
->sym
= ns
->proc_name
;
703 el
->next
= ns
->entries
;
705 ns
->proc_name
->attr
.entry
= 1;
707 /* If it is a module function, it needs to be in the right namespace
708 so that gfc_get_fake_result_decl can gather up the results. The
709 need for this arose in get_proc_name, where these beasts were
710 left in their own namespace, to keep prior references linked to
711 the entry declaration.*/
712 if (ns
->proc_name
->attr
.function
713 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
716 /* Do the same for entries where the master is not a module
717 procedure. These are retained in the module namespace because
718 of the module procedure declaration. */
719 for (el
= el
->next
; el
; el
= el
->next
)
720 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
721 && el
->sym
->attr
.mod_proc
)
725 /* Add an entry statement for it. */
732 /* Create a new symbol for the master function. */
733 /* Give the internal function a unique name (within this file).
734 Also include the function name so the user has some hope of figuring
735 out what is going on. */
736 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
737 master_count
++, ns
->proc_name
->name
);
738 gfc_get_ha_symbol (name
, &proc
);
739 gcc_assert (proc
!= NULL
);
741 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
742 if (ns
->proc_name
->attr
.subroutine
)
743 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
747 gfc_typespec
*ts
, *fts
;
748 gfc_array_spec
*as
, *fas
;
749 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
751 fas
= ns
->entries
->sym
->as
;
752 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
753 fts
= &ns
->entries
->sym
->result
->ts
;
754 if (fts
->type
== BT_UNKNOWN
)
755 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
756 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
758 ts
= &el
->sym
->result
->ts
;
760 as
= as
? as
: el
->sym
->result
->as
;
761 if (ts
->type
== BT_UNKNOWN
)
762 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
764 if (! gfc_compare_types (ts
, fts
)
765 || (el
->sym
->result
->attr
.dimension
766 != ns
->entries
->sym
->result
->attr
.dimension
)
767 || (el
->sym
->result
->attr
.pointer
768 != ns
->entries
->sym
->result
->attr
.pointer
))
770 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
771 && gfc_compare_array_spec (as
, fas
) == 0)
772 gfc_error ("Function %s at %L has entries with mismatched "
773 "array specifications", ns
->entries
->sym
->name
,
774 &ns
->entries
->sym
->declared_at
);
775 /* The characteristics need to match and thus both need to have
776 the same string length, i.e. both len=*, or both len=4.
777 Having both len=<variable> is also possible, but difficult to
778 check at compile time. */
779 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
780 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
781 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
783 && ts
->u
.cl
->length
->expr_type
784 != fts
->u
.cl
->length
->expr_type
)
786 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
787 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
788 fts
->u
.cl
->length
->value
.integer
) != 0)))
789 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
790 "entries returning variables of different "
791 "string lengths", ns
->entries
->sym
->name
,
792 &ns
->entries
->sym
->declared_at
);
797 sym
= ns
->entries
->sym
->result
;
798 /* All result types the same. */
800 if (sym
->attr
.dimension
)
801 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
802 if (sym
->attr
.pointer
)
803 gfc_add_pointer (&proc
->attr
, NULL
);
807 /* Otherwise the result will be passed through a union by
809 proc
->attr
.mixed_entry_master
= 1;
810 for (el
= ns
->entries
; el
; el
= el
->next
)
812 sym
= el
->sym
->result
;
813 if (sym
->attr
.dimension
)
815 if (el
== ns
->entries
)
816 gfc_error ("FUNCTION result %s can't be an array in "
817 "FUNCTION %s at %L", sym
->name
,
818 ns
->entries
->sym
->name
, &sym
->declared_at
);
820 gfc_error ("ENTRY result %s can't be an array in "
821 "FUNCTION %s at %L", sym
->name
,
822 ns
->entries
->sym
->name
, &sym
->declared_at
);
824 else if (sym
->attr
.pointer
)
826 if (el
== ns
->entries
)
827 gfc_error ("FUNCTION result %s can't be a POINTER in "
828 "FUNCTION %s at %L", sym
->name
,
829 ns
->entries
->sym
->name
, &sym
->declared_at
);
831 gfc_error ("ENTRY result %s can't be a POINTER in "
832 "FUNCTION %s at %L", sym
->name
,
833 ns
->entries
->sym
->name
, &sym
->declared_at
);
838 if (ts
->type
== BT_UNKNOWN
)
839 ts
= gfc_get_default_type (sym
->name
, NULL
);
843 if (ts
->kind
== gfc_default_integer_kind
)
847 if (ts
->kind
== gfc_default_real_kind
848 || ts
->kind
== gfc_default_double_kind
)
852 if (ts
->kind
== gfc_default_complex_kind
)
856 if (ts
->kind
== gfc_default_logical_kind
)
860 /* We will issue error elsewhere. */
868 if (el
== ns
->entries
)
869 gfc_error ("FUNCTION result %s can't be of type %s "
870 "in FUNCTION %s at %L", sym
->name
,
871 gfc_typename (ts
), ns
->entries
->sym
->name
,
874 gfc_error ("ENTRY result %s can't be of type %s "
875 "in FUNCTION %s at %L", sym
->name
,
876 gfc_typename (ts
), ns
->entries
->sym
->name
,
883 proc
->attr
.access
= ACCESS_PRIVATE
;
884 proc
->attr
.entry_master
= 1;
886 /* Merge all the entry point arguments. */
887 for (el
= ns
->entries
; el
; el
= el
->next
)
888 merge_argument_lists (proc
, el
->sym
->formal
);
890 /* Check the master formal arguments for any that are not
891 present in all entry points. */
892 for (el
= ns
->entries
; el
; el
= el
->next
)
893 check_argument_lists (proc
, el
->sym
->formal
);
895 /* Use the master function for the function body. */
896 ns
->proc_name
= proc
;
898 /* Finalize the new symbols. */
899 gfc_commit_symbols ();
901 /* Restore the original namespace. */
902 gfc_current_ns
= old_ns
;
906 /* Resolve common variables. */
908 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
910 gfc_symbol
*csym
= sym
;
912 for (; csym
; csym
= csym
->common_next
)
914 if (csym
->value
|| csym
->attr
.data
)
916 if (!csym
->ns
->is_block_data
)
917 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
918 "but only in BLOCK DATA initialization is "
919 "allowed", csym
->name
, &csym
->declared_at
);
920 else if (!named_common
)
921 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
922 "in a blank COMMON but initialization is only "
923 "allowed in named common blocks", csym
->name
,
927 if (UNLIMITED_POLY (csym
))
928 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
929 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
931 if (csym
->ts
.type
!= BT_DERIVED
)
934 if (!(csym
->ts
.u
.derived
->attr
.sequence
935 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
936 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
937 "has neither the SEQUENCE nor the BIND(C) "
938 "attribute", csym
->name
, &csym
->declared_at
);
939 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
940 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
941 "has an ultimate component that is "
942 "allocatable", csym
->name
, &csym
->declared_at
);
943 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
944 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
945 "may not have default initializer", csym
->name
,
948 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
949 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
953 /* Resolve common blocks. */
955 resolve_common_blocks (gfc_symtree
*common_root
)
960 if (common_root
== NULL
)
963 if (common_root
->left
)
964 resolve_common_blocks (common_root
->left
);
965 if (common_root
->right
)
966 resolve_common_blocks (common_root
->right
);
968 resolve_common_vars (common_root
->n
.common
->head
, true);
970 /* The common name is a global name - in Fortran 2003 also if it has a
971 C binding name, since Fortran 2008 only the C binding name is a global
973 if (!common_root
->n
.common
->binding_label
974 || gfc_notification_std (GFC_STD_F2008
))
976 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
977 common_root
->n
.common
->name
);
979 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
980 && gsym
->type
== GSYM_COMMON
981 && ((common_root
->n
.common
->binding_label
982 && (!gsym
->binding_label
983 || strcmp (common_root
->n
.common
->binding_label
,
984 gsym
->binding_label
) != 0))
985 || (!common_root
->n
.common
->binding_label
986 && gsym
->binding_label
)))
988 gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
989 "identifier and must thus have the same binding name "
990 "as the same-named COMMON block at %L: %s vs %s",
991 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
993 common_root
->n
.common
->binding_label
994 ? common_root
->n
.common
->binding_label
: "(blank)",
995 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
999 if (gsym
&& gsym
->type
!= GSYM_COMMON
1000 && !common_root
->n
.common
->binding_label
)
1002 gfc_error ("COMMON block '%s' at %L uses the same global identifier "
1004 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1008 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1010 gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
1011 "%L sharing the identifier with global non-COMMON-block "
1012 "entity at %L", common_root
->n
.common
->name
,
1013 &common_root
->n
.common
->where
, &gsym
->where
);
1018 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1019 gsym
->type
= GSYM_COMMON
;
1020 gsym
->where
= common_root
->n
.common
->where
;
1026 if (common_root
->n
.common
->binding_label
)
1028 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1029 common_root
->n
.common
->binding_label
);
1030 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1032 gfc_error ("COMMON block at %L with binding label %s uses the same "
1033 "global identifier as entity at %L",
1034 &common_root
->n
.common
->where
,
1035 common_root
->n
.common
->binding_label
, &gsym
->where
);
1040 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1041 gsym
->type
= GSYM_COMMON
;
1042 gsym
->where
= common_root
->n
.common
->where
;
1048 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1052 if (sym
->attr
.flavor
== FL_PARAMETER
)
1053 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
1054 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1056 if (sym
->attr
.external
)
1057 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
1058 sym
->name
, &common_root
->n
.common
->where
);
1060 if (sym
->attr
.intrinsic
)
1061 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
1062 sym
->name
, &common_root
->n
.common
->where
);
1063 else if (sym
->attr
.result
1064 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1065 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1066 "that is also a function result", sym
->name
,
1067 &common_root
->n
.common
->where
);
1068 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1069 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1070 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1071 "that is also a global procedure", sym
->name
,
1072 &common_root
->n
.common
->where
);
1076 /* Resolve contained function types. Because contained functions can call one
1077 another, they have to be worked out before any of the contained procedures
1080 The good news is that if a function doesn't already have a type, the only
1081 way it can get one is through an IMPLICIT type or a RESULT variable, because
1082 by definition contained functions are contained namespace they're contained
1083 in, not in a sibling or parent namespace. */
1086 resolve_contained_functions (gfc_namespace
*ns
)
1088 gfc_namespace
*child
;
1091 resolve_formal_arglists (ns
);
1093 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1095 /* Resolve alternate entry points first. */
1096 resolve_entries (child
);
1098 /* Then check function return types. */
1099 resolve_contained_fntype (child
->proc_name
, child
);
1100 for (el
= child
->entries
; el
; el
= el
->next
)
1101 resolve_contained_fntype (el
->sym
, child
);
1106 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1109 /* Resolve all of the elements of a structure constructor and make sure that
1110 the types are correct. The 'init' flag indicates that the given
1111 constructor is an initializer. */
1114 resolve_structure_cons (gfc_expr
*expr
, int init
)
1116 gfc_constructor
*cons
;
1117 gfc_component
*comp
;
1123 if (expr
->ts
.type
== BT_DERIVED
)
1124 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1126 cons
= gfc_constructor_first (expr
->value
.constructor
);
1128 /* A constructor may have references if it is the result of substituting a
1129 parameter variable. In this case we just pull out the component we
1132 comp
= expr
->ref
->u
.c
.sym
->components
;
1134 comp
= expr
->ts
.u
.derived
->components
;
1136 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1143 if (!gfc_resolve_expr (cons
->expr
))
1149 rank
= comp
->as
? comp
->as
->rank
: 0;
1150 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1151 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1153 gfc_error ("The rank of the element in the structure "
1154 "constructor at %L does not match that of the "
1155 "component (%d/%d)", &cons
->expr
->where
,
1156 cons
->expr
->rank
, rank
);
1160 /* If we don't have the right type, try to convert it. */
1162 if (!comp
->attr
.proc_pointer
&&
1163 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1165 if (strcmp (comp
->name
, "_extends") == 0)
1167 /* Can afford to be brutal with the _extends initializer.
1168 The derived type can get lost because it is PRIVATE
1169 but it is not usage constrained by the standard. */
1170 cons
->expr
->ts
= comp
->ts
;
1172 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1174 gfc_error ("The element in the structure constructor at %L, "
1175 "for pointer component '%s', is %s but should be %s",
1176 &cons
->expr
->where
, comp
->name
,
1177 gfc_basic_typename (cons
->expr
->ts
.type
),
1178 gfc_basic_typename (comp
->ts
.type
));
1183 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1189 /* For strings, the length of the constructor should be the same as
1190 the one of the structure, ensure this if the lengths are known at
1191 compile time and when we are dealing with PARAMETER or structure
1193 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1194 && comp
->ts
.u
.cl
->length
1195 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1196 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1197 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1198 && cons
->expr
->rank
!= 0
1199 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1200 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1202 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1203 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1205 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1206 to make use of the gfc_resolve_character_array_constructor
1207 machinery. The expression is later simplified away to
1208 an array of string literals. */
1209 gfc_expr
*para
= cons
->expr
;
1210 cons
->expr
= gfc_get_expr ();
1211 cons
->expr
->ts
= para
->ts
;
1212 cons
->expr
->where
= para
->where
;
1213 cons
->expr
->expr_type
= EXPR_ARRAY
;
1214 cons
->expr
->rank
= para
->rank
;
1215 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1216 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1217 para
, &cons
->expr
->where
);
1219 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1222 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1223 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1225 gfc_charlen
*cl
, *cl2
;
1228 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1230 if (cl
== cons
->expr
->ts
.u
.cl
)
1238 cl2
->next
= cl
->next
;
1240 gfc_free_expr (cl
->length
);
1244 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1245 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1246 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1247 gfc_resolve_character_array_constructor (cons
->expr
);
1251 if (cons
->expr
->expr_type
== EXPR_NULL
1252 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1253 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1254 || (comp
->ts
.type
== BT_CLASS
1255 && (CLASS_DATA (comp
)->attr
.class_pointer
1256 || CLASS_DATA (comp
)->attr
.allocatable
))))
1259 gfc_error ("The NULL in the structure constructor at %L is "
1260 "being applied to component '%s', which is neither "
1261 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1265 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1267 /* Check procedure pointer interface. */
1268 gfc_symbol
*s2
= NULL
;
1273 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1276 s2
= c2
->ts
.interface
;
1279 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1281 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1282 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1284 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1286 s2
= cons
->expr
->symtree
->n
.sym
;
1287 name
= cons
->expr
->symtree
->n
.sym
->name
;
1290 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1291 err
, sizeof (err
), NULL
, NULL
))
1293 gfc_error ("Interface mismatch for procedure-pointer component "
1294 "'%s' in structure constructor at %L: %s",
1295 comp
->name
, &cons
->expr
->where
, err
);
1300 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1301 || cons
->expr
->expr_type
== EXPR_NULL
)
1304 a
= gfc_expr_attr (cons
->expr
);
1306 if (!a
.pointer
&& !a
.target
)
1309 gfc_error ("The element in the structure constructor at %L, "
1310 "for pointer component '%s' should be a POINTER or "
1311 "a TARGET", &cons
->expr
->where
, comp
->name
);
1316 /* F08:C461. Additional checks for pointer initialization. */
1320 gfc_error ("Pointer initialization target at %L "
1321 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1326 gfc_error ("Pointer initialization target at %L "
1327 "must have the SAVE attribute", &cons
->expr
->where
);
1331 /* F2003, C1272 (3). */
1332 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1333 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1334 || gfc_is_coindexed (cons
->expr
)))
1337 gfc_error ("Invalid expression in the structure constructor for "
1338 "pointer component '%s' at %L in PURE procedure",
1339 comp
->name
, &cons
->expr
->where
);
1342 if (gfc_implicit_pure (NULL
)
1343 && cons
->expr
->expr_type
== EXPR_VARIABLE
1344 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1345 || gfc_is_coindexed (cons
->expr
)))
1346 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1354 /****************** Expression name resolution ******************/
1356 /* Returns 0 if a symbol was not declared with a type or
1357 attribute declaration statement, nonzero otherwise. */
1360 was_declared (gfc_symbol
*sym
)
1366 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1369 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1370 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1371 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1372 || a
.asynchronous
|| a
.codimension
)
1379 /* Determine if a symbol is generic or not. */
1382 generic_sym (gfc_symbol
*sym
)
1386 if (sym
->attr
.generic
||
1387 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1390 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1393 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1400 return generic_sym (s
);
1407 /* Determine if a symbol is specific or not. */
1410 specific_sym (gfc_symbol
*sym
)
1414 if (sym
->attr
.if_source
== IFSRC_IFBODY
1415 || sym
->attr
.proc
== PROC_MODULE
1416 || sym
->attr
.proc
== PROC_INTERNAL
1417 || sym
->attr
.proc
== PROC_ST_FUNCTION
1418 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1419 || sym
->attr
.external
)
1422 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1425 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1427 return (s
== NULL
) ? 0 : specific_sym (s
);
1431 /* Figure out if the procedure is specific, generic or unknown. */
1434 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1438 procedure_kind (gfc_symbol
*sym
)
1440 if (generic_sym (sym
))
1441 return PTYPE_GENERIC
;
1443 if (specific_sym (sym
))
1444 return PTYPE_SPECIFIC
;
1446 return PTYPE_UNKNOWN
;
1449 /* Check references to assumed size arrays. The flag need_full_assumed_size
1450 is nonzero when matching actual arguments. */
1452 static int need_full_assumed_size
= 0;
1455 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1457 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1460 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1461 What should it be? */
1462 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1463 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1464 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1466 gfc_error ("The upper bound in the last dimension must "
1467 "appear in the reference to the assumed size "
1468 "array '%s' at %L", sym
->name
, &e
->where
);
1475 /* Look for bad assumed size array references in argument expressions
1476 of elemental and array valued intrinsic procedures. Since this is
1477 called from procedure resolution functions, it only recurses at
1481 resolve_assumed_size_actual (gfc_expr
*e
)
1486 switch (e
->expr_type
)
1489 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1494 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1495 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1506 /* Check a generic procedure, passed as an actual argument, to see if
1507 there is a matching specific name. If none, it is an error, and if
1508 more than one, the reference is ambiguous. */
1510 count_specific_procs (gfc_expr
*e
)
1517 sym
= e
->symtree
->n
.sym
;
1519 for (p
= sym
->generic
; p
; p
= p
->next
)
1520 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1522 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1528 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1532 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1533 "argument at %L", sym
->name
, &e
->where
);
1539 /* See if a call to sym could possibly be a not allowed RECURSION because of
1540 a missing RECURSIVE declaration. This means that either sym is the current
1541 context itself, or sym is the parent of a contained procedure calling its
1542 non-RECURSIVE containing procedure.
1543 This also works if sym is an ENTRY. */
1546 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1548 gfc_symbol
* proc_sym
;
1549 gfc_symbol
* context_proc
;
1550 gfc_namespace
* real_context
;
1552 if (sym
->attr
.flavor
== FL_PROGRAM
1553 || sym
->attr
.flavor
== FL_DERIVED
)
1556 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1558 /* If we've got an ENTRY, find real procedure. */
1559 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1560 proc_sym
= sym
->ns
->entries
->sym
;
1564 /* If sym is RECURSIVE, all is well of course. */
1565 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1568 /* Find the context procedure's "real" symbol if it has entries.
1569 We look for a procedure symbol, so recurse on the parents if we don't
1570 find one (like in case of a BLOCK construct). */
1571 for (real_context
= context
; ; real_context
= real_context
->parent
)
1573 /* We should find something, eventually! */
1574 gcc_assert (real_context
);
1576 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1577 : real_context
->proc_name
);
1579 /* In some special cases, there may not be a proc_name, like for this
1581 real(bad_kind()) function foo () ...
1582 when checking the call to bad_kind ().
1583 In these cases, we simply return here and assume that the
1588 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1592 /* A call from sym's body to itself is recursion, of course. */
1593 if (context_proc
== proc_sym
)
1596 /* The same is true if context is a contained procedure and sym the
1598 if (context_proc
->attr
.contained
)
1600 gfc_symbol
* parent_proc
;
1602 gcc_assert (context
->parent
);
1603 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1604 : context
->parent
->proc_name
);
1606 if (parent_proc
== proc_sym
)
1614 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1615 its typespec and formal argument list. */
1618 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1620 gfc_intrinsic_sym
* isym
= NULL
;
1626 /* Already resolved. */
1627 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1630 /* We already know this one is an intrinsic, so we don't call
1631 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1632 gfc_find_subroutine directly to check whether it is a function or
1635 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1637 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1638 isym
= gfc_intrinsic_subroutine_by_id (id
);
1640 else if (sym
->intmod_sym_id
)
1642 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1643 isym
= gfc_intrinsic_function_by_id (id
);
1645 else if (!sym
->attr
.subroutine
)
1646 isym
= gfc_find_function (sym
->name
);
1648 if (isym
&& !sym
->attr
.subroutine
)
1650 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1651 && !sym
->attr
.implicit_type
)
1652 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1653 " ignored", sym
->name
, &sym
->declared_at
);
1655 if (!sym
->attr
.function
&&
1656 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1661 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1663 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1665 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1666 " specifier", sym
->name
, &sym
->declared_at
);
1670 if (!sym
->attr
.subroutine
&&
1671 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1676 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1681 gfc_copy_formal_args_intr (sym
, isym
);
1683 /* Check it is actually available in the standard settings. */
1684 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1686 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1687 " available in the current standard settings but %s. Use"
1688 " an appropriate -std=* option or enable -fall-intrinsics"
1689 " in order to use it.",
1690 sym
->name
, &sym
->declared_at
, symstd
);
1698 /* Resolve a procedure expression, like passing it to a called procedure or as
1699 RHS for a procedure pointer assignment. */
1702 resolve_procedure_expression (gfc_expr
* expr
)
1706 if (expr
->expr_type
!= EXPR_VARIABLE
)
1708 gcc_assert (expr
->symtree
);
1710 sym
= expr
->symtree
->n
.sym
;
1712 if (sym
->attr
.intrinsic
)
1713 gfc_resolve_intrinsic (sym
, &expr
->where
);
1715 if (sym
->attr
.flavor
!= FL_PROCEDURE
1716 || (sym
->attr
.function
&& sym
->result
== sym
))
1719 /* A non-RECURSIVE procedure that is used as procedure expression within its
1720 own body is in danger of being called recursively. */
1721 if (is_illegal_recursion (sym
, gfc_current_ns
))
1722 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1723 " itself recursively. Declare it RECURSIVE or use"
1724 " -frecursive", sym
->name
, &expr
->where
);
1730 /* Resolve an actual argument list. Most of the time, this is just
1731 resolving the expressions in the list.
1732 The exception is that we sometimes have to decide whether arguments
1733 that look like procedure arguments are really simple variable
1737 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1738 bool no_formal_args
)
1741 gfc_symtree
*parent_st
;
1743 int save_need_full_assumed_size
;
1744 bool return_value
= false;
1745 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1748 first_actual_arg
= true;
1750 for (; arg
; arg
= arg
->next
)
1755 /* Check the label is a valid branching target. */
1758 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1760 gfc_error ("Label %d referenced at %L is never defined",
1761 arg
->label
->value
, &arg
->label
->where
);
1765 first_actual_arg
= false;
1769 if (e
->expr_type
== EXPR_VARIABLE
1770 && e
->symtree
->n
.sym
->attr
.generic
1772 && count_specific_procs (e
) != 1)
1775 if (e
->ts
.type
!= BT_PROCEDURE
)
1777 save_need_full_assumed_size
= need_full_assumed_size
;
1778 if (e
->expr_type
!= EXPR_VARIABLE
)
1779 need_full_assumed_size
= 0;
1780 if (!gfc_resolve_expr (e
))
1782 need_full_assumed_size
= save_need_full_assumed_size
;
1786 /* See if the expression node should really be a variable reference. */
1788 sym
= e
->symtree
->n
.sym
;
1790 if (sym
->attr
.flavor
== FL_PROCEDURE
1791 || sym
->attr
.intrinsic
1792 || sym
->attr
.external
)
1796 /* If a procedure is not already determined to be something else
1797 check if it is intrinsic. */
1798 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1799 sym
->attr
.intrinsic
= 1;
1801 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1803 gfc_error ("Statement function '%s' at %L is not allowed as an "
1804 "actual argument", sym
->name
, &e
->where
);
1807 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1808 sym
->attr
.subroutine
);
1809 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1811 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1812 "actual argument", sym
->name
, &e
->where
);
1815 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1816 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1818 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1819 " used as actual argument at %L",
1820 sym
->name
, &e
->where
))
1824 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1826 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1827 "allowed as an actual argument at %L", sym
->name
,
1831 /* Check if a generic interface has a specific procedure
1832 with the same name before emitting an error. */
1833 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1836 /* Just in case a specific was found for the expression. */
1837 sym
= e
->symtree
->n
.sym
;
1839 /* If the symbol is the function that names the current (or
1840 parent) scope, then we really have a variable reference. */
1842 if (gfc_is_function_return_value (sym
, sym
->ns
))
1845 /* If all else fails, see if we have a specific intrinsic. */
1846 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1848 gfc_intrinsic_sym
*isym
;
1850 isym
= gfc_find_function (sym
->name
);
1851 if (isym
== NULL
|| !isym
->specific
)
1853 gfc_error ("Unable to find a specific INTRINSIC procedure "
1854 "for the reference '%s' at %L", sym
->name
,
1859 sym
->attr
.intrinsic
= 1;
1860 sym
->attr
.function
= 1;
1863 if (!gfc_resolve_expr (e
))
1868 /* See if the name is a module procedure in a parent unit. */
1870 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1873 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1875 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1879 if (parent_st
== NULL
)
1882 sym
= parent_st
->n
.sym
;
1883 e
->symtree
= parent_st
; /* Point to the right thing. */
1885 if (sym
->attr
.flavor
== FL_PROCEDURE
1886 || sym
->attr
.intrinsic
1887 || sym
->attr
.external
)
1889 if (!gfc_resolve_expr (e
))
1895 e
->expr_type
= EXPR_VARIABLE
;
1897 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1898 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1899 && CLASS_DATA (sym
)->as
))
1901 e
->rank
= sym
->ts
.type
== BT_CLASS
1902 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1903 e
->ref
= gfc_get_ref ();
1904 e
->ref
->type
= REF_ARRAY
;
1905 e
->ref
->u
.ar
.type
= AR_FULL
;
1906 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1907 ? CLASS_DATA (sym
)->as
: sym
->as
;
1910 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1911 primary.c (match_actual_arg). If above code determines that it
1912 is a variable instead, it needs to be resolved as it was not
1913 done at the beginning of this function. */
1914 save_need_full_assumed_size
= need_full_assumed_size
;
1915 if (e
->expr_type
!= EXPR_VARIABLE
)
1916 need_full_assumed_size
= 0;
1917 if (!gfc_resolve_expr (e
))
1919 need_full_assumed_size
= save_need_full_assumed_size
;
1922 /* Check argument list functions %VAL, %LOC and %REF. There is
1923 nothing to do for %REF. */
1924 if (arg
->name
&& arg
->name
[0] == '%')
1926 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1928 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1930 gfc_error ("By-value argument at %L is not of numeric "
1937 gfc_error ("By-value argument at %L cannot be an array or "
1938 "an array section", &e
->where
);
1942 /* Intrinsics are still PROC_UNKNOWN here. However,
1943 since same file external procedures are not resolvable
1944 in gfortran, it is a good deal easier to leave them to
1946 if (ptype
!= PROC_UNKNOWN
1947 && ptype
!= PROC_DUMMY
1948 && ptype
!= PROC_EXTERNAL
1949 && ptype
!= PROC_MODULE
)
1951 gfc_error ("By-value argument at %L is not allowed "
1952 "in this context", &e
->where
);
1957 /* Statement functions have already been excluded above. */
1958 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1959 && e
->ts
.type
== BT_PROCEDURE
)
1961 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1963 gfc_error ("Passing internal procedure at %L by location "
1964 "not allowed", &e
->where
);
1970 /* Fortran 2008, C1237. */
1971 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1972 && gfc_has_ultimate_pointer (e
))
1974 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1975 "component", &e
->where
);
1979 first_actual_arg
= false;
1982 return_value
= true;
1985 actual_arg
= actual_arg_sav
;
1986 first_actual_arg
= first_actual_arg_sav
;
1988 return return_value
;
1992 /* Do the checks of the actual argument list that are specific to elemental
1993 procedures. If called with c == NULL, we have a function, otherwise if
1994 expr == NULL, we have a subroutine. */
1997 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1999 gfc_actual_arglist
*arg0
;
2000 gfc_actual_arglist
*arg
;
2001 gfc_symbol
*esym
= NULL
;
2002 gfc_intrinsic_sym
*isym
= NULL
;
2004 gfc_intrinsic_arg
*iformal
= NULL
;
2005 gfc_formal_arglist
*eformal
= NULL
;
2006 bool formal_optional
= false;
2007 bool set_by_optional
= false;
2011 /* Is this an elemental procedure? */
2012 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2014 if (expr
->value
.function
.esym
!= NULL
2015 && expr
->value
.function
.esym
->attr
.elemental
)
2017 arg0
= expr
->value
.function
.actual
;
2018 esym
= expr
->value
.function
.esym
;
2020 else if (expr
->value
.function
.isym
!= NULL
2021 && expr
->value
.function
.isym
->elemental
)
2023 arg0
= expr
->value
.function
.actual
;
2024 isym
= expr
->value
.function
.isym
;
2029 else if (c
&& c
->ext
.actual
!= NULL
)
2031 arg0
= c
->ext
.actual
;
2033 if (c
->resolved_sym
)
2034 esym
= c
->resolved_sym
;
2036 esym
= c
->symtree
->n
.sym
;
2039 if (!esym
->attr
.elemental
)
2045 /* The rank of an elemental is the rank of its array argument(s). */
2046 for (arg
= arg0
; arg
; arg
= arg
->next
)
2048 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2050 rank
= arg
->expr
->rank
;
2051 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2052 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2053 set_by_optional
= true;
2055 /* Function specific; set the result rank and shape. */
2059 if (!expr
->shape
&& arg
->expr
->shape
)
2061 expr
->shape
= gfc_get_shape (rank
);
2062 for (i
= 0; i
< rank
; i
++)
2063 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2070 /* If it is an array, it shall not be supplied as an actual argument
2071 to an elemental procedure unless an array of the same rank is supplied
2072 as an actual argument corresponding to a nonoptional dummy argument of
2073 that elemental procedure(12.4.1.5). */
2074 formal_optional
= false;
2076 iformal
= isym
->formal
;
2078 eformal
= esym
->formal
;
2080 for (arg
= arg0
; arg
; arg
= arg
->next
)
2084 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2085 formal_optional
= true;
2086 eformal
= eformal
->next
;
2088 else if (isym
&& iformal
)
2090 if (iformal
->optional
)
2091 formal_optional
= true;
2092 iformal
= iformal
->next
;
2095 formal_optional
= true;
2097 if (pedantic
&& arg
->expr
!= NULL
2098 && arg
->expr
->expr_type
== EXPR_VARIABLE
2099 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2102 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2103 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2105 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2106 "MISSING, it cannot be the actual argument of an "
2107 "ELEMENTAL procedure unless there is a non-optional "
2108 "argument with the same rank (12.4.1.5)",
2109 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2113 for (arg
= arg0
; arg
; arg
= arg
->next
)
2115 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2118 /* Being elemental, the last upper bound of an assumed size array
2119 argument must be present. */
2120 if (resolve_assumed_size_actual (arg
->expr
))
2123 /* Elemental procedure's array actual arguments must conform. */
2126 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2133 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2134 is an array, the intent inout/out variable needs to be also an array. */
2135 if (rank
> 0 && esym
&& expr
== NULL
)
2136 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2137 arg
= arg
->next
, eformal
= eformal
->next
)
2138 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2139 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2140 && arg
->expr
&& arg
->expr
->rank
== 0)
2142 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2143 "ELEMENTAL subroutine '%s' is a scalar, but another "
2144 "actual argument is an array", &arg
->expr
->where
,
2145 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2146 : "INOUT", eformal
->sym
->name
, esym
->name
);
2153 /* This function does the checking of references to global procedures
2154 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2155 77 and 95 standards. It checks for a gsymbol for the name, making
2156 one if it does not already exist. If it already exists, then the
2157 reference being resolved must correspond to the type of gsymbol.
2158 Otherwise, the new symbol is equipped with the attributes of the
2159 reference. The corresponding code that is called in creating
2160 global entities is parse.c.
2162 In addition, for all but -std=legacy, the gsymbols are used to
2163 check the interfaces of external procedures from the same file.
2164 The namespace of the gsymbol is resolved and then, once this is
2165 done the interface is checked. */
2169 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2171 if (!gsym_ns
->proc_name
->attr
.recursive
)
2174 if (sym
->ns
== gsym_ns
)
2177 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2184 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2186 if (gsym_ns
->entries
)
2188 gfc_entry_list
*entry
= gsym_ns
->entries
;
2190 for (; entry
; entry
= entry
->next
)
2192 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2194 if (strcmp (gsym_ns
->proc_name
->name
,
2195 sym
->ns
->proc_name
->name
) == 0)
2199 && strcmp (gsym_ns
->proc_name
->name
,
2200 sym
->ns
->parent
->proc_name
->name
) == 0)
2209 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2212 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2214 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2216 for ( ; arg
; arg
= arg
->next
)
2221 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2223 strncpy (errmsg
, _("allocatable argument"), err_len
);
2226 else if (arg
->sym
->attr
.asynchronous
)
2228 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2231 else if (arg
->sym
->attr
.optional
)
2233 strncpy (errmsg
, _("optional argument"), err_len
);
2236 else if (arg
->sym
->attr
.pointer
)
2238 strncpy (errmsg
, _("pointer argument"), err_len
);
2241 else if (arg
->sym
->attr
.target
)
2243 strncpy (errmsg
, _("target argument"), err_len
);
2246 else if (arg
->sym
->attr
.value
)
2248 strncpy (errmsg
, _("value argument"), err_len
);
2251 else if (arg
->sym
->attr
.volatile_
)
2253 strncpy (errmsg
, _("volatile argument"), err_len
);
2256 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2258 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2261 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2263 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2266 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2268 strncpy (errmsg
, _("coarray argument"), err_len
);
2271 else if (false) /* (2d) TODO: parametrized derived type */
2273 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2276 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2278 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2281 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2283 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2286 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2288 /* As assumed-type is unlimited polymorphic (cf. above).
2289 See also TS 29113, Note 6.1. */
2290 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2295 if (sym
->attr
.function
)
2297 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2299 if (res
->attr
.dimension
) /* (3a) */
2301 strncpy (errmsg
, _("array result"), err_len
);
2304 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2306 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2309 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2310 && res
->ts
.u
.cl
->length
2311 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2313 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2318 if (sym
->attr
.elemental
) /* (4) */
2320 strncpy (errmsg
, _("elemental procedure"), err_len
);
2323 else if (sym
->attr
.is_bind_c
) /* (5) */
2325 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2334 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2335 gfc_actual_arglist
**actual
, int sub
)
2339 enum gfc_symbol_type type
;
2342 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2344 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2346 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2347 gfc_global_used (gsym
, where
);
2349 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2350 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2351 && gsym
->type
!= GSYM_UNKNOWN
2353 && gsym
->ns
->resolved
!= -1
2354 && gsym
->ns
->proc_name
2355 && not_in_recursive (sym
, gsym
->ns
)
2356 && not_entry_self_reference (sym
, gsym
->ns
))
2358 gfc_symbol
*def_sym
;
2360 /* Resolve the gsymbol namespace if needed. */
2361 if (!gsym
->ns
->resolved
)
2363 gfc_dt_list
*old_dt_list
;
2364 struct gfc_omp_saved_state old_omp_state
;
2366 /* Stash away derived types so that the backend_decls do not
2368 old_dt_list
= gfc_derived_types
;
2369 gfc_derived_types
= NULL
;
2370 /* And stash away openmp state. */
2371 gfc_omp_save_and_clear_state (&old_omp_state
);
2373 gfc_resolve (gsym
->ns
);
2375 /* Store the new derived types with the global namespace. */
2376 if (gfc_derived_types
)
2377 gsym
->ns
->derived_types
= gfc_derived_types
;
2379 /* Restore the derived types of this namespace. */
2380 gfc_derived_types
= old_dt_list
;
2381 /* And openmp state. */
2382 gfc_omp_restore_state (&old_omp_state
);
2385 /* Make sure that translation for the gsymbol occurs before
2386 the procedure currently being resolved. */
2387 ns
= gfc_global_ns_list
;
2388 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2390 if (ns
->sibling
== gsym
->ns
)
2392 ns
->sibling
= gsym
->ns
->sibling
;
2393 gsym
->ns
->sibling
= gfc_global_ns_list
;
2394 gfc_global_ns_list
= gsym
->ns
;
2399 def_sym
= gsym
->ns
->proc_name
;
2401 /* This can happen if a binding name has been specified. */
2402 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2403 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2405 if (def_sym
->attr
.entry_master
)
2407 gfc_entry_list
*entry
;
2408 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2409 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2411 def_sym
= entry
->sym
;
2416 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2418 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2419 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2420 gfc_typename (&def_sym
->ts
));
2424 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2425 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2427 gfc_error ("Explicit interface required for '%s' at %L: %s",
2428 sym
->name
, &sym
->declared_at
, reason
);
2432 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2433 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2434 gfc_errors_to_warnings (1);
2436 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2437 reason
, sizeof(reason
), NULL
, NULL
))
2439 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2440 sym
->name
, &sym
->declared_at
, reason
);
2445 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2446 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2447 gfc_errors_to_warnings (1);
2449 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2450 gfc_procedure_use (def_sym
, actual
, where
);
2454 gfc_errors_to_warnings (0);
2456 if (gsym
->type
== GSYM_UNKNOWN
)
2459 gsym
->where
= *where
;
2466 /************* Function resolution *************/
2468 /* Resolve a function call known to be generic.
2469 Section 14.1.2.4.1. */
2472 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2476 if (sym
->attr
.generic
)
2478 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2481 expr
->value
.function
.name
= s
->name
;
2482 expr
->value
.function
.esym
= s
;
2484 if (s
->ts
.type
!= BT_UNKNOWN
)
2486 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2487 expr
->ts
= s
->result
->ts
;
2490 expr
->rank
= s
->as
->rank
;
2491 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2492 expr
->rank
= s
->result
->as
->rank
;
2494 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2499 /* TODO: Need to search for elemental references in generic
2503 if (sym
->attr
.intrinsic
)
2504 return gfc_intrinsic_func_interface (expr
, 0);
2511 resolve_generic_f (gfc_expr
*expr
)
2515 gfc_interface
*intr
= NULL
;
2517 sym
= expr
->symtree
->n
.sym
;
2521 m
= resolve_generic_f0 (expr
, sym
);
2524 else if (m
== MATCH_ERROR
)
2529 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2530 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2533 if (sym
->ns
->parent
== NULL
)
2535 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2539 if (!generic_sym (sym
))
2543 /* Last ditch attempt. See if the reference is to an intrinsic
2544 that possesses a matching interface. 14.1.2.4 */
2545 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2547 gfc_error ("There is no specific function for the generic '%s' "
2548 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2554 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2557 return resolve_structure_cons (expr
, 0);
2560 m
= gfc_intrinsic_func_interface (expr
, 0);
2565 gfc_error ("Generic function '%s' at %L is not consistent with a "
2566 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2573 /* Resolve a function call known to be specific. */
2576 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2580 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2582 if (sym
->attr
.dummy
)
2584 sym
->attr
.proc
= PROC_DUMMY
;
2588 sym
->attr
.proc
= PROC_EXTERNAL
;
2592 if (sym
->attr
.proc
== PROC_MODULE
2593 || sym
->attr
.proc
== PROC_ST_FUNCTION
2594 || sym
->attr
.proc
== PROC_INTERNAL
)
2597 if (sym
->attr
.intrinsic
)
2599 m
= gfc_intrinsic_func_interface (expr
, 1);
2603 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2604 "with an intrinsic", sym
->name
, &expr
->where
);
2612 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2615 expr
->ts
= sym
->result
->ts
;
2618 expr
->value
.function
.name
= sym
->name
;
2619 expr
->value
.function
.esym
= sym
;
2620 if (sym
->as
!= NULL
)
2621 expr
->rank
= sym
->as
->rank
;
2628 resolve_specific_f (gfc_expr
*expr
)
2633 sym
= expr
->symtree
->n
.sym
;
2637 m
= resolve_specific_f0 (sym
, expr
);
2640 if (m
== MATCH_ERROR
)
2643 if (sym
->ns
->parent
== NULL
)
2646 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2652 gfc_error ("Unable to resolve the specific function '%s' at %L",
2653 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2659 /* Resolve a procedure call not known to be generic nor specific. */
2662 resolve_unknown_f (gfc_expr
*expr
)
2667 sym
= expr
->symtree
->n
.sym
;
2669 if (sym
->attr
.dummy
)
2671 sym
->attr
.proc
= PROC_DUMMY
;
2672 expr
->value
.function
.name
= sym
->name
;
2676 /* See if we have an intrinsic function reference. */
2678 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2680 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2685 /* The reference is to an external name. */
2687 sym
->attr
.proc
= PROC_EXTERNAL
;
2688 expr
->value
.function
.name
= sym
->name
;
2689 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2691 if (sym
->as
!= NULL
)
2692 expr
->rank
= sym
->as
->rank
;
2694 /* Type of the expression is either the type of the symbol or the
2695 default type of the symbol. */
2698 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2700 if (sym
->ts
.type
!= BT_UNKNOWN
)
2704 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2706 if (ts
->type
== BT_UNKNOWN
)
2708 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2709 sym
->name
, &expr
->where
);
2720 /* Return true, if the symbol is an external procedure. */
2722 is_external_proc (gfc_symbol
*sym
)
2724 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2725 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2726 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2727 && !sym
->attr
.proc_pointer
2728 && !sym
->attr
.use_assoc
2736 /* Figure out if a function reference is pure or not. Also set the name
2737 of the function for a potential error message. Return nonzero if the
2738 function is PURE, zero if not. */
2740 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2743 pure_function (gfc_expr
*e
, const char **name
)
2749 if (e
->symtree
!= NULL
2750 && e
->symtree
->n
.sym
!= NULL
2751 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2752 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2754 if (e
->value
.function
.esym
)
2756 pure
= gfc_pure (e
->value
.function
.esym
);
2757 *name
= e
->value
.function
.esym
->name
;
2759 else if (e
->value
.function
.isym
)
2761 pure
= e
->value
.function
.isym
->pure
2762 || e
->value
.function
.isym
->elemental
;
2763 *name
= e
->value
.function
.isym
->name
;
2767 /* Implicit functions are not pure. */
2769 *name
= e
->value
.function
.name
;
2777 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2778 int *f ATTRIBUTE_UNUSED
)
2782 /* Don't bother recursing into other statement functions
2783 since they will be checked individually for purity. */
2784 if (e
->expr_type
!= EXPR_FUNCTION
2786 || e
->symtree
->n
.sym
== sym
2787 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2790 return pure_function (e
, &name
) ? false : true;
2795 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2797 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2801 /* Resolve a function call, which means resolving the arguments, then figuring
2802 out which entity the name refers to. */
2805 resolve_function (gfc_expr
*expr
)
2807 gfc_actual_arglist
*arg
;
2812 procedure_type p
= PROC_INTRINSIC
;
2813 bool no_formal_args
;
2817 sym
= expr
->symtree
->n
.sym
;
2819 /* If this is a procedure pointer component, it has already been resolved. */
2820 if (gfc_is_proc_ptr_comp (expr
))
2823 if (sym
&& sym
->attr
.intrinsic
2824 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2827 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2829 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2833 /* If this ia a deferred TBP with an abstract interface (which may
2834 of course be referenced), expr->value.function.esym will be set. */
2835 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2837 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2838 sym
->name
, &expr
->where
);
2842 /* Switch off assumed size checking and do this again for certain kinds
2843 of procedure, once the procedure itself is resolved. */
2844 need_full_assumed_size
++;
2846 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2847 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2849 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2850 inquiry_argument
= true;
2851 no_formal_args
= sym
&& is_external_proc (sym
)
2852 && gfc_sym_get_dummy_args (sym
) == NULL
;
2854 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2857 inquiry_argument
= false;
2861 inquiry_argument
= false;
2863 /* Resume assumed_size checking. */
2864 need_full_assumed_size
--;
2866 /* If the procedure is external, check for usage. */
2867 if (sym
&& is_external_proc (sym
))
2868 resolve_global_procedure (sym
, &expr
->where
,
2869 &expr
->value
.function
.actual
, 0);
2871 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2873 && sym
->ts
.u
.cl
->length
== NULL
2875 && !sym
->ts
.deferred
2876 && expr
->value
.function
.esym
== NULL
2877 && !sym
->attr
.contained
)
2879 /* Internal procedures are taken care of in resolve_contained_fntype. */
2880 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2881 "be used at %L since it is not a dummy argument",
2882 sym
->name
, &expr
->where
);
2886 /* See if function is already resolved. */
2888 if (expr
->value
.function
.name
!= NULL
)
2890 if (expr
->ts
.type
== BT_UNKNOWN
)
2896 /* Apply the rules of section 14.1.2. */
2898 switch (procedure_kind (sym
))
2901 t
= resolve_generic_f (expr
);
2904 case PTYPE_SPECIFIC
:
2905 t
= resolve_specific_f (expr
);
2909 t
= resolve_unknown_f (expr
);
2913 gfc_internal_error ("resolve_function(): bad function type");
2917 /* If the expression is still a function (it might have simplified),
2918 then we check to see if we are calling an elemental function. */
2920 if (expr
->expr_type
!= EXPR_FUNCTION
)
2923 temp
= need_full_assumed_size
;
2924 need_full_assumed_size
= 0;
2926 if (!resolve_elemental_actual (expr
, NULL
))
2929 if (omp_workshare_flag
2930 && expr
->value
.function
.esym
2931 && ! gfc_elemental (expr
->value
.function
.esym
))
2933 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2934 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2939 #define GENERIC_ID expr->value.function.isym->id
2940 else if (expr
->value
.function
.actual
!= NULL
2941 && expr
->value
.function
.isym
!= NULL
2942 && GENERIC_ID
!= GFC_ISYM_LBOUND
2943 && GENERIC_ID
!= GFC_ISYM_LEN
2944 && GENERIC_ID
!= GFC_ISYM_LOC
2945 && GENERIC_ID
!= GFC_ISYM_C_LOC
2946 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2948 /* Array intrinsics must also have the last upper bound of an
2949 assumed size array argument. UBOUND and SIZE have to be
2950 excluded from the check if the second argument is anything
2953 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2955 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2956 && arg
== expr
->value
.function
.actual
2957 && arg
->next
!= NULL
&& arg
->next
->expr
)
2959 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2962 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2965 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2970 if (arg
->expr
!= NULL
2971 && arg
->expr
->rank
> 0
2972 && resolve_assumed_size_actual (arg
->expr
))
2978 need_full_assumed_size
= temp
;
2981 if (!pure_function (expr
, &name
) && name
)
2985 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2986 "FORALL %s", name
, &expr
->where
,
2987 forall_flag
== 2 ? "mask" : "block");
2990 else if (do_concurrent_flag
)
2992 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2993 "DO CONCURRENT %s", name
, &expr
->where
,
2994 do_concurrent_flag
== 2 ? "mask" : "block");
2997 else if (gfc_pure (NULL
))
2999 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3000 "procedure within a PURE procedure", name
, &expr
->where
);
3004 if (gfc_implicit_pure (NULL
))
3005 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3008 /* Functions without the RECURSIVE attribution are not allowed to
3009 * call themselves. */
3010 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3013 esym
= expr
->value
.function
.esym
;
3015 if (is_illegal_recursion (esym
, gfc_current_ns
))
3017 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3018 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3019 " function '%s' is not RECURSIVE",
3020 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3022 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3023 " is not RECURSIVE", esym
->name
, &expr
->where
);
3029 /* Character lengths of use associated functions may contains references to
3030 symbols not referenced from the current program unit otherwise. Make sure
3031 those symbols are marked as referenced. */
3033 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3034 && expr
->value
.function
.esym
->attr
.use_assoc
)
3036 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3039 /* Make sure that the expression has a typespec that works. */
3040 if (expr
->ts
.type
== BT_UNKNOWN
)
3042 if (expr
->symtree
->n
.sym
->result
3043 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3044 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3045 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3052 /************* Subroutine resolution *************/
3055 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3061 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3062 sym
->name
, &c
->loc
);
3063 else if (do_concurrent_flag
)
3064 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3065 "PURE", sym
->name
, &c
->loc
);
3066 else if (gfc_pure (NULL
))
3067 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3070 if (gfc_implicit_pure (NULL
))
3071 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3076 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3080 if (sym
->attr
.generic
)
3082 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3085 c
->resolved_sym
= s
;
3086 pure_subroutine (c
, s
);
3090 /* TODO: Need to search for elemental references in generic interface. */
3093 if (sym
->attr
.intrinsic
)
3094 return gfc_intrinsic_sub_interface (c
, 0);
3101 resolve_generic_s (gfc_code
*c
)
3106 sym
= c
->symtree
->n
.sym
;
3110 m
= resolve_generic_s0 (c
, sym
);
3113 else if (m
== MATCH_ERROR
)
3117 if (sym
->ns
->parent
== NULL
)
3119 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3123 if (!generic_sym (sym
))
3127 /* Last ditch attempt. See if the reference is to an intrinsic
3128 that possesses a matching interface. 14.1.2.4 */
3129 sym
= c
->symtree
->n
.sym
;
3131 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3133 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3134 sym
->name
, &c
->loc
);
3138 m
= gfc_intrinsic_sub_interface (c
, 0);
3142 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3143 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3149 /* Resolve a subroutine call known to be specific. */
3152 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3156 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3158 if (sym
->attr
.dummy
)
3160 sym
->attr
.proc
= PROC_DUMMY
;
3164 sym
->attr
.proc
= PROC_EXTERNAL
;
3168 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3171 if (sym
->attr
.intrinsic
)
3173 m
= gfc_intrinsic_sub_interface (c
, 1);
3177 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3178 "with an intrinsic", sym
->name
, &c
->loc
);
3186 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3188 c
->resolved_sym
= sym
;
3189 pure_subroutine (c
, sym
);
3196 resolve_specific_s (gfc_code
*c
)
3201 sym
= c
->symtree
->n
.sym
;
3205 m
= resolve_specific_s0 (c
, sym
);
3208 if (m
== MATCH_ERROR
)
3211 if (sym
->ns
->parent
== NULL
)
3214 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3220 sym
= c
->symtree
->n
.sym
;
3221 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3222 sym
->name
, &c
->loc
);
3228 /* Resolve a subroutine call not known to be generic nor specific. */
3231 resolve_unknown_s (gfc_code
*c
)
3235 sym
= c
->symtree
->n
.sym
;
3237 if (sym
->attr
.dummy
)
3239 sym
->attr
.proc
= PROC_DUMMY
;
3243 /* See if we have an intrinsic function reference. */
3245 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3247 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3252 /* The reference is to an external name. */
3255 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3257 c
->resolved_sym
= sym
;
3259 pure_subroutine (c
, sym
);
3265 /* Resolve a subroutine call. Although it was tempting to use the same code
3266 for functions, subroutines and functions are stored differently and this
3267 makes things awkward. */
3270 resolve_call (gfc_code
*c
)
3273 procedure_type ptype
= PROC_INTRINSIC
;
3274 gfc_symbol
*csym
, *sym
;
3275 bool no_formal_args
;
3277 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3279 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3281 gfc_error ("'%s' at %L has a type, which is not consistent with "
3282 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3286 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3289 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3290 sym
= st
? st
->n
.sym
: NULL
;
3291 if (sym
&& csym
!= sym
3292 && sym
->ns
== gfc_current_ns
3293 && sym
->attr
.flavor
== FL_PROCEDURE
3294 && sym
->attr
.contained
)
3297 if (csym
->attr
.generic
)
3298 c
->symtree
->n
.sym
= sym
;
3301 csym
= c
->symtree
->n
.sym
;
3305 /* If this ia a deferred TBP, c->expr1 will be set. */
3306 if (!c
->expr1
&& csym
)
3308 if (csym
->attr
.abstract
)
3310 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3311 csym
->name
, &c
->loc
);
3315 /* Subroutines without the RECURSIVE attribution are not allowed to
3317 if (is_illegal_recursion (csym
, gfc_current_ns
))
3319 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3320 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3321 "as subroutine '%s' is not RECURSIVE",
3322 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3324 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3325 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3331 /* Switch off assumed size checking and do this again for certain kinds
3332 of procedure, once the procedure itself is resolved. */
3333 need_full_assumed_size
++;
3336 ptype
= csym
->attr
.proc
;
3338 no_formal_args
= csym
&& is_external_proc (csym
)
3339 && gfc_sym_get_dummy_args (csym
) == NULL
;
3340 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3343 /* Resume assumed_size checking. */
3344 need_full_assumed_size
--;
3346 /* If external, check for usage. */
3347 if (csym
&& is_external_proc (csym
))
3348 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3351 if (c
->resolved_sym
== NULL
)
3353 c
->resolved_isym
= NULL
;
3354 switch (procedure_kind (csym
))
3357 t
= resolve_generic_s (c
);
3360 case PTYPE_SPECIFIC
:
3361 t
= resolve_specific_s (c
);
3365 t
= resolve_unknown_s (c
);
3369 gfc_internal_error ("resolve_subroutine(): bad function type");
3373 /* Some checks of elemental subroutine actual arguments. */
3374 if (!resolve_elemental_actual (NULL
, c
))
3381 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3382 op1->shape and op2->shape are non-NULL return true if their shapes
3383 match. If both op1->shape and op2->shape are non-NULL return false
3384 if their shapes do not match. If either op1->shape or op2->shape is
3385 NULL, return true. */
3388 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3395 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3397 for (i
= 0; i
< op1
->rank
; i
++)
3399 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3401 gfc_error ("Shapes for operands at %L and %L are not conformable",
3402 &op1
->where
, &op2
->where
);
3413 /* Resolve an operator expression node. This can involve replacing the
3414 operation with a user defined function call. */
3417 resolve_operator (gfc_expr
*e
)
3419 gfc_expr
*op1
, *op2
;
3421 bool dual_locus_error
;
3424 /* Resolve all subnodes-- give them types. */
3426 switch (e
->value
.op
.op
)
3429 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3432 /* Fall through... */
3435 case INTRINSIC_UPLUS
:
3436 case INTRINSIC_UMINUS
:
3437 case INTRINSIC_PARENTHESES
:
3438 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3443 /* Typecheck the new node. */
3445 op1
= e
->value
.op
.op1
;
3446 op2
= e
->value
.op
.op2
;
3447 dual_locus_error
= false;
3449 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3450 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3452 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3456 switch (e
->value
.op
.op
)
3458 case INTRINSIC_UPLUS
:
3459 case INTRINSIC_UMINUS
:
3460 if (op1
->ts
.type
== BT_INTEGER
3461 || op1
->ts
.type
== BT_REAL
3462 || op1
->ts
.type
== BT_COMPLEX
)
3468 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3469 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3472 case INTRINSIC_PLUS
:
3473 case INTRINSIC_MINUS
:
3474 case INTRINSIC_TIMES
:
3475 case INTRINSIC_DIVIDE
:
3476 case INTRINSIC_POWER
:
3477 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3479 gfc_type_convert_binary (e
, 1);
3484 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3485 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3486 gfc_typename (&op2
->ts
));
3489 case INTRINSIC_CONCAT
:
3490 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3491 && op1
->ts
.kind
== op2
->ts
.kind
)
3493 e
->ts
.type
= BT_CHARACTER
;
3494 e
->ts
.kind
= op1
->ts
.kind
;
3499 _("Operands of string concatenation operator at %%L are %s/%s"),
3500 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3506 case INTRINSIC_NEQV
:
3507 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3509 e
->ts
.type
= BT_LOGICAL
;
3510 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3511 if (op1
->ts
.kind
< e
->ts
.kind
)
3512 gfc_convert_type (op1
, &e
->ts
, 2);
3513 else if (op2
->ts
.kind
< e
->ts
.kind
)
3514 gfc_convert_type (op2
, &e
->ts
, 2);
3518 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3519 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3520 gfc_typename (&op2
->ts
));
3525 if (op1
->ts
.type
== BT_LOGICAL
)
3527 e
->ts
.type
= BT_LOGICAL
;
3528 e
->ts
.kind
= op1
->ts
.kind
;
3532 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3533 gfc_typename (&op1
->ts
));
3537 case INTRINSIC_GT_OS
:
3539 case INTRINSIC_GE_OS
:
3541 case INTRINSIC_LT_OS
:
3543 case INTRINSIC_LE_OS
:
3544 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3546 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3550 /* Fall through... */
3553 case INTRINSIC_EQ_OS
:
3555 case INTRINSIC_NE_OS
:
3556 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3557 && op1
->ts
.kind
== op2
->ts
.kind
)
3559 e
->ts
.type
= BT_LOGICAL
;
3560 e
->ts
.kind
= gfc_default_logical_kind
;
3564 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3566 gfc_type_convert_binary (e
, 1);
3568 e
->ts
.type
= BT_LOGICAL
;
3569 e
->ts
.kind
= gfc_default_logical_kind
;
3571 if (gfc_option
.warn_compare_reals
)
3573 gfc_intrinsic_op op
= e
->value
.op
.op
;
3575 /* Type conversion has made sure that the types of op1 and op2
3576 agree, so it is only necessary to check the first one. */
3577 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3578 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3579 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3583 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3584 msg
= "Equality comparison for %s at %L";
3586 msg
= "Inequality comparison for %s at %L";
3588 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3595 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3597 _("Logicals at %%L must be compared with %s instead of %s"),
3598 (e
->value
.op
.op
== INTRINSIC_EQ
3599 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3600 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3603 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3604 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3605 gfc_typename (&op2
->ts
));
3609 case INTRINSIC_USER
:
3610 if (e
->value
.op
.uop
->op
== NULL
)
3611 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3612 else if (op2
== NULL
)
3613 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3614 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3617 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3618 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3619 gfc_typename (&op2
->ts
));
3620 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3625 case INTRINSIC_PARENTHESES
:
3627 if (e
->ts
.type
== BT_CHARACTER
)
3628 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3632 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3635 /* Deal with arrayness of an operand through an operator. */
3639 switch (e
->value
.op
.op
)
3641 case INTRINSIC_PLUS
:
3642 case INTRINSIC_MINUS
:
3643 case INTRINSIC_TIMES
:
3644 case INTRINSIC_DIVIDE
:
3645 case INTRINSIC_POWER
:
3646 case INTRINSIC_CONCAT
:
3650 case INTRINSIC_NEQV
:
3652 case INTRINSIC_EQ_OS
:
3654 case INTRINSIC_NE_OS
:
3656 case INTRINSIC_GT_OS
:
3658 case INTRINSIC_GE_OS
:
3660 case INTRINSIC_LT_OS
:
3662 case INTRINSIC_LE_OS
:
3664 if (op1
->rank
== 0 && op2
->rank
== 0)
3667 if (op1
->rank
== 0 && op2
->rank
!= 0)
3669 e
->rank
= op2
->rank
;
3671 if (e
->shape
== NULL
)
3672 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3675 if (op1
->rank
!= 0 && op2
->rank
== 0)
3677 e
->rank
= op1
->rank
;
3679 if (e
->shape
== NULL
)
3680 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3683 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3685 if (op1
->rank
== op2
->rank
)
3687 e
->rank
= op1
->rank
;
3688 if (e
->shape
== NULL
)
3690 t
= compare_shapes (op1
, op2
);
3694 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3699 /* Allow higher level expressions to work. */
3702 /* Try user-defined operators, and otherwise throw an error. */
3703 dual_locus_error
= true;
3705 _("Inconsistent ranks for operator at %%L and %%L"));
3712 case INTRINSIC_PARENTHESES
:
3714 case INTRINSIC_UPLUS
:
3715 case INTRINSIC_UMINUS
:
3716 /* Simply copy arrayness attribute */
3717 e
->rank
= op1
->rank
;
3719 if (e
->shape
== NULL
)
3720 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3728 /* Attempt to simplify the expression. */
3731 t
= gfc_simplify_expr (e
, 0);
3732 /* Some calls do not succeed in simplification and return false
3733 even though there is no error; e.g. variable references to
3734 PARAMETER arrays. */
3735 if (!gfc_is_constant_expr (e
))
3743 match m
= gfc_extend_expr (e
);
3746 if (m
== MATCH_ERROR
)
3750 if (dual_locus_error
)
3751 gfc_error (msg
, &op1
->where
, &op2
->where
);
3753 gfc_error (msg
, &e
->where
);
3759 /************** Array resolution subroutines **************/
3762 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3765 /* Compare two integer expressions. */
3768 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3772 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3773 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3776 /* If either of the types isn't INTEGER, we must have
3777 raised an error earlier. */
3779 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3782 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3792 /* Compare an integer expression with an integer. */
3795 compare_bound_int (gfc_expr
*a
, int b
)
3799 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3802 if (a
->ts
.type
!= BT_INTEGER
)
3803 gfc_internal_error ("compare_bound_int(): Bad expression");
3805 i
= mpz_cmp_si (a
->value
.integer
, b
);
3815 /* Compare an integer expression with a mpz_t. */
3818 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3822 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3825 if (a
->ts
.type
!= BT_INTEGER
)
3826 gfc_internal_error ("compare_bound_int(): Bad expression");
3828 i
= mpz_cmp (a
->value
.integer
, b
);
3838 /* Compute the last value of a sequence given by a triplet.
3839 Return 0 if it wasn't able to compute the last value, or if the
3840 sequence if empty, and 1 otherwise. */
3843 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3844 gfc_expr
*stride
, mpz_t last
)
3848 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3849 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3850 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3853 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3854 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3857 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3859 if (compare_bound (start
, end
) == CMP_GT
)
3861 mpz_set (last
, end
->value
.integer
);
3865 if (compare_bound_int (stride
, 0) == CMP_GT
)
3867 /* Stride is positive */
3868 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3873 /* Stride is negative */
3874 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3879 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3880 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3881 mpz_sub (last
, end
->value
.integer
, rem
);
3888 /* Compare a single dimension of an array reference to the array
3892 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3896 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3898 gcc_assert (ar
->stride
[i
] == NULL
);
3899 /* This implies [*] as [*:] and [*:3] are not possible. */
3900 if (ar
->start
[i
] == NULL
)
3902 gcc_assert (ar
->end
[i
] == NULL
);
3907 /* Given start, end and stride values, calculate the minimum and
3908 maximum referenced indexes. */
3910 switch (ar
->dimen_type
[i
])
3913 case DIMEN_THIS_IMAGE
:
3918 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3921 gfc_warning ("Array reference at %L is out of bounds "
3922 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3923 mpz_get_si (ar
->start
[i
]->value
.integer
),
3924 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3926 gfc_warning ("Array reference at %L is out of bounds "
3927 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3928 mpz_get_si (ar
->start
[i
]->value
.integer
),
3929 mpz_get_si (as
->lower
[i
]->value
.integer
),
3933 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3936 gfc_warning ("Array reference at %L is out of bounds "
3937 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3938 mpz_get_si (ar
->start
[i
]->value
.integer
),
3939 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3941 gfc_warning ("Array reference at %L is out of bounds "
3942 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3943 mpz_get_si (ar
->start
[i
]->value
.integer
),
3944 mpz_get_si (as
->upper
[i
]->value
.integer
),
3953 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3954 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3956 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3958 /* Check for zero stride, which is not allowed. */
3959 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3961 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3965 /* if start == len || (stride > 0 && start < len)
3966 || (stride < 0 && start > len),
3967 then the array section contains at least one element. In this
3968 case, there is an out-of-bounds access if
3969 (start < lower || start > upper). */
3970 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3971 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3972 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3973 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3974 && comp_start_end
== CMP_GT
))
3976 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3978 gfc_warning ("Lower array reference at %L is out of bounds "
3979 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3980 mpz_get_si (AR_START
->value
.integer
),
3981 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3984 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3986 gfc_warning ("Lower array reference at %L is out of bounds "
3987 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3988 mpz_get_si (AR_START
->value
.integer
),
3989 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3994 /* If we can compute the highest index of the array section,
3995 then it also has to be between lower and upper. */
3996 mpz_init (last_value
);
3997 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4000 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4002 gfc_warning ("Upper array reference at %L is out of bounds "
4003 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4004 mpz_get_si (last_value
),
4005 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4006 mpz_clear (last_value
);
4009 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4011 gfc_warning ("Upper array reference at %L is out of bounds "
4012 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4013 mpz_get_si (last_value
),
4014 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4015 mpz_clear (last_value
);
4019 mpz_clear (last_value
);
4027 gfc_internal_error ("check_dimension(): Bad array reference");
4034 /* Compare an array reference with an array specification. */
4037 compare_spec_to_ref (gfc_array_ref
*ar
)
4044 /* TODO: Full array sections are only allowed as actual parameters. */
4045 if (as
->type
== AS_ASSUMED_SIZE
4046 && (/*ar->type == AR_FULL
4047 ||*/ (ar
->type
== AR_SECTION
4048 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4050 gfc_error ("Rightmost upper bound of assumed size array section "
4051 "not specified at %L", &ar
->where
);
4055 if (ar
->type
== AR_FULL
)
4058 if (as
->rank
!= ar
->dimen
)
4060 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4061 &ar
->where
, ar
->dimen
, as
->rank
);
4065 /* ar->codimen == 0 is a local array. */
4066 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4068 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4069 &ar
->where
, ar
->codimen
, as
->corank
);
4073 for (i
= 0; i
< as
->rank
; i
++)
4074 if (!check_dimension (i
, ar
, as
))
4077 /* Local access has no coarray spec. */
4078 if (ar
->codimen
!= 0)
4079 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4081 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4082 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4084 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4085 i
+ 1 - as
->rank
, &ar
->where
);
4088 if (!check_dimension (i
, ar
, as
))
4096 /* Resolve one part of an array index. */
4099 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4100 int force_index_integer_kind
)
4107 if (!gfc_resolve_expr (index
))
4110 if (check_scalar
&& index
->rank
!= 0)
4112 gfc_error ("Array index at %L must be scalar", &index
->where
);
4116 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4118 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4119 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4123 if (index
->ts
.type
== BT_REAL
)
4124 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4128 if ((index
->ts
.kind
!= gfc_index_integer_kind
4129 && force_index_integer_kind
)
4130 || index
->ts
.type
!= BT_INTEGER
)
4133 ts
.type
= BT_INTEGER
;
4134 ts
.kind
= gfc_index_integer_kind
;
4136 gfc_convert_type_warn (index
, &ts
, 2, 0);
4142 /* Resolve one part of an array index. */
4145 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4147 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4150 /* Resolve a dim argument to an intrinsic function. */
4153 gfc_resolve_dim_arg (gfc_expr
*dim
)
4158 if (!gfc_resolve_expr (dim
))
4163 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4168 if (dim
->ts
.type
!= BT_INTEGER
)
4170 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4174 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4179 ts
.type
= BT_INTEGER
;
4180 ts
.kind
= gfc_index_integer_kind
;
4182 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4188 /* Given an expression that contains array references, update those array
4189 references to point to the right array specifications. While this is
4190 filled in during matching, this information is difficult to save and load
4191 in a module, so we take care of it here.
4193 The idea here is that the original array reference comes from the
4194 base symbol. We traverse the list of reference structures, setting
4195 the stored reference to references. Component references can
4196 provide an additional array specification. */
4199 find_array_spec (gfc_expr
*e
)
4205 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4206 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4208 as
= e
->symtree
->n
.sym
->as
;
4210 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4215 gfc_internal_error ("find_array_spec(): Missing spec");
4222 c
= ref
->u
.c
.component
;
4223 if (c
->attr
.dimension
)
4226 gfc_internal_error ("find_array_spec(): unused as(1)");
4237 gfc_internal_error ("find_array_spec(): unused as(2)");
4241 /* Resolve an array reference. */
4244 resolve_array_ref (gfc_array_ref
*ar
)
4246 int i
, check_scalar
;
4249 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4251 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4253 /* Do not force gfc_index_integer_kind for the start. We can
4254 do fine with any integer kind. This avoids temporary arrays
4255 created for indexing with a vector. */
4256 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4258 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4260 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4265 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4269 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4273 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4274 if (e
->expr_type
== EXPR_VARIABLE
4275 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4276 ar
->start
[i
] = gfc_get_parentheses (e
);
4280 gfc_error ("Array index at %L is an array of rank %d",
4281 &ar
->c_where
[i
], e
->rank
);
4285 /* Fill in the upper bound, which may be lower than the
4286 specified one for something like a(2:10:5), which is
4287 identical to a(2:7:5). Only relevant for strides not equal
4288 to one. Don't try a division by zero. */
4289 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4290 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4291 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4292 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4296 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4298 if (ar
->end
[i
] == NULL
)
4301 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4303 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4305 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4306 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4308 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4319 if (ar
->type
== AR_FULL
)
4321 if (ar
->as
->rank
== 0)
4322 ar
->type
= AR_ELEMENT
;
4324 /* Make sure array is the same as array(:,:), this way
4325 we don't need to special case all the time. */
4326 ar
->dimen
= ar
->as
->rank
;
4327 for (i
= 0; i
< ar
->dimen
; i
++)
4329 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4331 gcc_assert (ar
->start
[i
] == NULL
);
4332 gcc_assert (ar
->end
[i
] == NULL
);
4333 gcc_assert (ar
->stride
[i
] == NULL
);
4337 /* If the reference type is unknown, figure out what kind it is. */
4339 if (ar
->type
== AR_UNKNOWN
)
4341 ar
->type
= AR_ELEMENT
;
4342 for (i
= 0; i
< ar
->dimen
; i
++)
4343 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4344 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4346 ar
->type
= AR_SECTION
;
4351 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4354 if (ar
->as
->corank
&& ar
->codimen
== 0)
4357 ar
->codimen
= ar
->as
->corank
;
4358 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4359 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4367 resolve_substring (gfc_ref
*ref
)
4369 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4371 if (ref
->u
.ss
.start
!= NULL
)
4373 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4376 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4378 gfc_error ("Substring start index at %L must be of type INTEGER",
4379 &ref
->u
.ss
.start
->where
);
4383 if (ref
->u
.ss
.start
->rank
!= 0)
4385 gfc_error ("Substring start index at %L must be scalar",
4386 &ref
->u
.ss
.start
->where
);
4390 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4391 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4392 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4394 gfc_error ("Substring start index at %L is less than one",
4395 &ref
->u
.ss
.start
->where
);
4400 if (ref
->u
.ss
.end
!= NULL
)
4402 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4405 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4407 gfc_error ("Substring end index at %L must be of type INTEGER",
4408 &ref
->u
.ss
.end
->where
);
4412 if (ref
->u
.ss
.end
->rank
!= 0)
4414 gfc_error ("Substring end index at %L must be scalar",
4415 &ref
->u
.ss
.end
->where
);
4419 if (ref
->u
.ss
.length
!= NULL
4420 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4421 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4422 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4424 gfc_error ("Substring end index at %L exceeds the string length",
4425 &ref
->u
.ss
.start
->where
);
4429 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4430 gfc_integer_kinds
[k
].huge
) == CMP_GT
4431 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4432 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4434 gfc_error ("Substring end index at %L is too large",
4435 &ref
->u
.ss
.end
->where
);
4444 /* This function supplies missing substring charlens. */
4447 gfc_resolve_substring_charlen (gfc_expr
*e
)
4450 gfc_expr
*start
, *end
;
4452 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4453 if (char_ref
->type
== REF_SUBSTRING
)
4459 gcc_assert (char_ref
->next
== NULL
);
4463 if (e
->ts
.u
.cl
->length
)
4464 gfc_free_expr (e
->ts
.u
.cl
->length
);
4465 else if (e
->expr_type
== EXPR_VARIABLE
4466 && e
->symtree
->n
.sym
->attr
.dummy
)
4470 e
->ts
.type
= BT_CHARACTER
;
4471 e
->ts
.kind
= gfc_default_character_kind
;
4474 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4476 if (char_ref
->u
.ss
.start
)
4477 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4479 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4481 if (char_ref
->u
.ss
.end
)
4482 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4483 else if (e
->expr_type
== EXPR_VARIABLE
)
4484 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4490 gfc_free_expr (start
);
4491 gfc_free_expr (end
);
4495 /* Length = (end - start +1). */
4496 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4497 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4498 gfc_get_int_expr (gfc_default_integer_kind
,
4501 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4502 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4504 /* Make sure that the length is simplified. */
4505 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4506 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4510 /* Resolve subtype references. */
4513 resolve_ref (gfc_expr
*expr
)
4515 int current_part_dimension
, n_components
, seen_part_dimension
;
4518 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4519 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4521 find_array_spec (expr
);
4525 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4529 if (!resolve_array_ref (&ref
->u
.ar
))
4537 if (!resolve_substring (ref
))
4542 /* Check constraints on part references. */
4544 current_part_dimension
= 0;
4545 seen_part_dimension
= 0;
4548 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4553 switch (ref
->u
.ar
.type
)
4556 /* Coarray scalar. */
4557 if (ref
->u
.ar
.as
->rank
== 0)
4559 current_part_dimension
= 0;
4564 current_part_dimension
= 1;
4568 current_part_dimension
= 0;
4572 gfc_internal_error ("resolve_ref(): Bad array reference");
4578 if (current_part_dimension
|| seen_part_dimension
)
4581 if (ref
->u
.c
.component
->attr
.pointer
4582 || ref
->u
.c
.component
->attr
.proc_pointer
4583 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4584 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4586 gfc_error ("Component to the right of a part reference "
4587 "with nonzero rank must not have the POINTER "
4588 "attribute at %L", &expr
->where
);
4591 else if (ref
->u
.c
.component
->attr
.allocatable
4592 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4593 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4596 gfc_error ("Component to the right of a part reference "
4597 "with nonzero rank must not have the ALLOCATABLE "
4598 "attribute at %L", &expr
->where
);
4610 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4611 || ref
->next
== NULL
)
4612 && current_part_dimension
4613 && seen_part_dimension
)
4615 gfc_error ("Two or more part references with nonzero rank must "
4616 "not be specified at %L", &expr
->where
);
4620 if (ref
->type
== REF_COMPONENT
)
4622 if (current_part_dimension
)
4623 seen_part_dimension
= 1;
4625 /* reset to make sure */
4626 current_part_dimension
= 0;
4634 /* Given an expression, determine its shape. This is easier than it sounds.
4635 Leaves the shape array NULL if it is not possible to determine the shape. */
4638 expression_shape (gfc_expr
*e
)
4640 mpz_t array
[GFC_MAX_DIMENSIONS
];
4643 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4646 for (i
= 0; i
< e
->rank
; i
++)
4647 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4650 e
->shape
= gfc_get_shape (e
->rank
);
4652 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4657 for (i
--; i
>= 0; i
--)
4658 mpz_clear (array
[i
]);
4662 /* Given a variable expression node, compute the rank of the expression by
4663 examining the base symbol and any reference structures it may have. */
4666 expression_rank (gfc_expr
*e
)
4671 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4672 could lead to serious confusion... */
4673 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4677 if (e
->expr_type
== EXPR_ARRAY
)
4679 /* Constructors can have a rank different from one via RESHAPE(). */
4681 if (e
->symtree
== NULL
)
4687 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4688 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4694 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4696 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4697 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4698 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4700 if (ref
->type
!= REF_ARRAY
)
4703 if (ref
->u
.ar
.type
== AR_FULL
)
4705 rank
= ref
->u
.ar
.as
->rank
;
4709 if (ref
->u
.ar
.type
== AR_SECTION
)
4711 /* Figure out the rank of the section. */
4713 gfc_internal_error ("expression_rank(): Two array specs");
4715 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4716 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4717 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4727 expression_shape (e
);
4731 /* Resolve a variable expression. */
4734 resolve_variable (gfc_expr
*e
)
4741 if (e
->symtree
== NULL
)
4743 sym
= e
->symtree
->n
.sym
;
4745 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4746 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4747 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4749 if (!actual_arg
|| inquiry_argument
)
4751 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4752 "be used as actual argument", sym
->name
, &e
->where
);
4756 /* TS 29113, 407b. */
4757 else if (e
->ts
.type
== BT_ASSUMED
)
4761 gfc_error ("Assumed-type variable %s at %L may only be used "
4762 "as actual argument", sym
->name
, &e
->where
);
4765 else if (inquiry_argument
&& !first_actual_arg
)
4767 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4768 for all inquiry functions in resolve_function; the reason is
4769 that the function-name resolution happens too late in that
4771 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4772 "an inquiry function shall be the first argument",
4773 sym
->name
, &e
->where
);
4777 /* TS 29113, C535b. */
4778 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4779 && CLASS_DATA (sym
)->as
4780 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4781 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4782 && sym
->as
->type
== AS_ASSUMED_RANK
))
4786 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4787 "actual argument", sym
->name
, &e
->where
);
4790 else if (inquiry_argument
&& !first_actual_arg
)
4792 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4793 for all inquiry functions in resolve_function; the reason is
4794 that the function-name resolution happens too late in that
4796 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4797 "to an inquiry function shall be the first argument",
4798 sym
->name
, &e
->where
);
4803 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4804 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4805 && e
->ref
->next
== NULL
))
4807 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4808 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4811 /* TS 29113, 407b. */
4812 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4813 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4814 && e
->ref
->next
== NULL
))
4816 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4817 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4821 /* TS 29113, C535b. */
4822 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4823 && CLASS_DATA (sym
)->as
4824 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4825 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4826 && sym
->as
->type
== AS_ASSUMED_RANK
))
4828 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4829 && e
->ref
->next
== NULL
))
4831 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4832 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4837 /* If this is an associate-name, it may be parsed with an array reference
4838 in error even though the target is scalar. Fail directly in this case.
4839 TODO Understand why class scalar expressions must be excluded. */
4840 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4842 if (sym
->ts
.type
== BT_CLASS
)
4843 gfc_fix_class_refs (e
);
4844 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4848 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4849 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4851 /* On the other hand, the parser may not have known this is an array;
4852 in this case, we have to add a FULL reference. */
4853 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4855 e
->ref
= gfc_get_ref ();
4856 e
->ref
->type
= REF_ARRAY
;
4857 e
->ref
->u
.ar
.type
= AR_FULL
;
4858 e
->ref
->u
.ar
.dimen
= 0;
4861 if (e
->ref
&& !resolve_ref (e
))
4864 if (sym
->attr
.flavor
== FL_PROCEDURE
4865 && (!sym
->attr
.function
4866 || (sym
->attr
.function
&& sym
->result
4867 && sym
->result
->attr
.proc_pointer
4868 && !sym
->result
->attr
.function
)))
4870 e
->ts
.type
= BT_PROCEDURE
;
4871 goto resolve_procedure
;
4874 if (sym
->ts
.type
!= BT_UNKNOWN
)
4875 gfc_variable_attr (e
, &e
->ts
);
4878 /* Must be a simple variable reference. */
4879 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4884 if (check_assumed_size_reference (sym
, e
))
4887 /* Deal with forward references to entries during resolve_code, to
4888 satisfy, at least partially, 12.5.2.5. */
4889 if (gfc_current_ns
->entries
4890 && current_entry_id
== sym
->entry_id
4893 && cs_base
->current
->op
!= EXEC_ENTRY
)
4895 gfc_entry_list
*entry
;
4896 gfc_formal_arglist
*formal
;
4898 bool seen
, saved_specification_expr
;
4900 /* If the symbol is a dummy... */
4901 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4903 entry
= gfc_current_ns
->entries
;
4906 /* ...test if the symbol is a parameter of previous entries. */
4907 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4908 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4910 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4914 /* If it has not been seen as a dummy, this is an error. */
4917 if (specification_expr
)
4918 gfc_error ("Variable '%s', used in a specification expression"
4919 ", is referenced at %L before the ENTRY statement "
4920 "in which it is a parameter",
4921 sym
->name
, &cs_base
->current
->loc
);
4923 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4924 "statement in which it is a parameter",
4925 sym
->name
, &cs_base
->current
->loc
);
4930 /* Now do the same check on the specification expressions. */
4931 saved_specification_expr
= specification_expr
;
4932 specification_expr
= true;
4933 if (sym
->ts
.type
== BT_CHARACTER
4934 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4938 for (n
= 0; n
< sym
->as
->rank
; n
++)
4940 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4942 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4945 specification_expr
= saved_specification_expr
;
4948 /* Update the symbol's entry level. */
4949 sym
->entry_id
= current_entry_id
+ 1;
4952 /* If a symbol has been host_associated mark it. This is used latter,
4953 to identify if aliasing is possible via host association. */
4954 if (sym
->attr
.flavor
== FL_VARIABLE
4955 && gfc_current_ns
->parent
4956 && (gfc_current_ns
->parent
== sym
->ns
4957 || (gfc_current_ns
->parent
->parent
4958 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4959 sym
->attr
.host_assoc
= 1;
4962 if (t
&& !resolve_procedure_expression (e
))
4965 /* F2008, C617 and C1229. */
4966 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4967 && gfc_is_coindexed (e
))
4969 gfc_ref
*ref
, *ref2
= NULL
;
4971 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4973 if (ref
->type
== REF_COMPONENT
)
4975 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4979 for ( ; ref
; ref
= ref
->next
)
4980 if (ref
->type
== REF_COMPONENT
)
4983 /* Expression itself is not coindexed object. */
4984 if (ref
&& e
->ts
.type
== BT_CLASS
)
4986 gfc_error ("Polymorphic subobject of coindexed object at %L",
4991 /* Expression itself is coindexed object. */
4995 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
4996 for ( ; c
; c
= c
->next
)
4997 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
4999 gfc_error ("Coindexed object with polymorphic allocatable "
5000 "subcomponent at %L", &e
->where
);
5011 /* Checks to see that the correct symbol has been host associated.
5012 The only situation where this arises is that in which a twice
5013 contained function is parsed after the host association is made.
5014 Therefore, on detecting this, change the symbol in the expression
5015 and convert the array reference into an actual arglist if the old
5016 symbol is a variable. */
5018 check_host_association (gfc_expr
*e
)
5020 gfc_symbol
*sym
, *old_sym
;
5024 gfc_actual_arglist
*arg
, *tail
= NULL
;
5025 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5027 /* If the expression is the result of substitution in
5028 interface.c(gfc_extend_expr) because there is no way in
5029 which the host association can be wrong. */
5030 if (e
->symtree
== NULL
5031 || e
->symtree
->n
.sym
== NULL
5032 || e
->user_operator
)
5035 old_sym
= e
->symtree
->n
.sym
;
5037 if (gfc_current_ns
->parent
5038 && old_sym
->ns
!= gfc_current_ns
)
5040 /* Use the 'USE' name so that renamed module symbols are
5041 correctly handled. */
5042 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5044 if (sym
&& old_sym
!= sym
5045 && sym
->ts
.type
== old_sym
->ts
.type
5046 && sym
->attr
.flavor
== FL_PROCEDURE
5047 && sym
->attr
.contained
)
5049 /* Clear the shape, since it might not be valid. */
5050 gfc_free_shape (&e
->shape
, e
->rank
);
5052 /* Give the expression the right symtree! */
5053 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5054 gcc_assert (st
!= NULL
);
5056 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5057 || e
->expr_type
== EXPR_FUNCTION
)
5059 /* Original was function so point to the new symbol, since
5060 the actual argument list is already attached to the
5062 e
->value
.function
.esym
= NULL
;
5067 /* Original was variable so convert array references into
5068 an actual arglist. This does not need any checking now
5069 since resolve_function will take care of it. */
5070 e
->value
.function
.actual
= NULL
;
5071 e
->expr_type
= EXPR_FUNCTION
;
5074 /* Ambiguity will not arise if the array reference is not
5075 the last reference. */
5076 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5077 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5080 gcc_assert (ref
->type
== REF_ARRAY
);
5082 /* Grab the start expressions from the array ref and
5083 copy them into actual arguments. */
5084 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5086 arg
= gfc_get_actual_arglist ();
5087 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5088 if (e
->value
.function
.actual
== NULL
)
5089 tail
= e
->value
.function
.actual
= arg
;
5097 /* Dump the reference list and set the rank. */
5098 gfc_free_ref_list (e
->ref
);
5100 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5103 gfc_resolve_expr (e
);
5107 /* This might have changed! */
5108 return e
->expr_type
== EXPR_FUNCTION
;
5113 gfc_resolve_character_operator (gfc_expr
*e
)
5115 gfc_expr
*op1
= e
->value
.op
.op1
;
5116 gfc_expr
*op2
= e
->value
.op
.op2
;
5117 gfc_expr
*e1
= NULL
;
5118 gfc_expr
*e2
= NULL
;
5120 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5122 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5123 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5124 else if (op1
->expr_type
== EXPR_CONSTANT
)
5125 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5126 op1
->value
.character
.length
);
5128 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5129 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5130 else if (op2
->expr_type
== EXPR_CONSTANT
)
5131 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5132 op2
->value
.character
.length
);
5134 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5144 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5145 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5146 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5147 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5148 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5154 /* Ensure that an character expression has a charlen and, if possible, a
5155 length expression. */
5158 fixup_charlen (gfc_expr
*e
)
5160 /* The cases fall through so that changes in expression type and the need
5161 for multiple fixes are picked up. In all circumstances, a charlen should
5162 be available for the middle end to hang a backend_decl on. */
5163 switch (e
->expr_type
)
5166 gfc_resolve_character_operator (e
);
5169 if (e
->expr_type
== EXPR_ARRAY
)
5170 gfc_resolve_character_array_constructor (e
);
5172 case EXPR_SUBSTRING
:
5173 if (!e
->ts
.u
.cl
&& e
->ref
)
5174 gfc_resolve_substring_charlen (e
);
5178 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5185 /* Update an actual argument to include the passed-object for type-bound
5186 procedures at the right position. */
5188 static gfc_actual_arglist
*
5189 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5192 gcc_assert (argpos
> 0);
5196 gfc_actual_arglist
* result
;
5198 result
= gfc_get_actual_arglist ();
5202 result
->name
= name
;
5208 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5210 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5215 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5218 extract_compcall_passed_object (gfc_expr
* e
)
5222 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5224 if (e
->value
.compcall
.base_object
)
5225 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5228 po
= gfc_get_expr ();
5229 po
->expr_type
= EXPR_VARIABLE
;
5230 po
->symtree
= e
->symtree
;
5231 po
->ref
= gfc_copy_ref (e
->ref
);
5232 po
->where
= e
->where
;
5235 if (!gfc_resolve_expr (po
))
5242 /* Update the arglist of an EXPR_COMPCALL expression to include the
5246 update_compcall_arglist (gfc_expr
* e
)
5249 gfc_typebound_proc
* tbp
;
5251 tbp
= e
->value
.compcall
.tbp
;
5256 po
= extract_compcall_passed_object (e
);
5260 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5266 gcc_assert (tbp
->pass_arg_num
> 0);
5267 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5275 /* Extract the passed object from a PPC call (a copy of it). */
5278 extract_ppc_passed_object (gfc_expr
*e
)
5283 po
= gfc_get_expr ();
5284 po
->expr_type
= EXPR_VARIABLE
;
5285 po
->symtree
= e
->symtree
;
5286 po
->ref
= gfc_copy_ref (e
->ref
);
5287 po
->where
= e
->where
;
5289 /* Remove PPC reference. */
5291 while ((*ref
)->next
)
5292 ref
= &(*ref
)->next
;
5293 gfc_free_ref_list (*ref
);
5296 if (!gfc_resolve_expr (po
))
5303 /* Update the actual arglist of a procedure pointer component to include the
5307 update_ppc_arglist (gfc_expr
* e
)
5311 gfc_typebound_proc
* tb
;
5313 ppc
= gfc_get_proc_ptr_comp (e
);
5321 else if (tb
->nopass
)
5324 po
= extract_ppc_passed_object (e
);
5331 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5336 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5338 gfc_error ("Base object for procedure-pointer component call at %L is of"
5339 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5343 gcc_assert (tb
->pass_arg_num
> 0);
5344 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5352 /* Check that the object a TBP is called on is valid, i.e. it must not be
5353 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5356 check_typebound_baseobject (gfc_expr
* e
)
5359 bool return_value
= false;
5361 base
= extract_compcall_passed_object (e
);
5365 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5367 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5371 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5373 gfc_error ("Base object for type-bound procedure call at %L is of"
5374 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5378 /* F08:C1230. If the procedure called is NOPASS,
5379 the base object must be scalar. */
5380 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5382 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5383 " be scalar", &e
->where
);
5387 return_value
= true;
5390 gfc_free_expr (base
);
5391 return return_value
;
5395 /* Resolve a call to a type-bound procedure, either function or subroutine,
5396 statically from the data in an EXPR_COMPCALL expression. The adapted
5397 arglist and the target-procedure symtree are returned. */
5400 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5401 gfc_actual_arglist
** actual
)
5403 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5404 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5406 /* Update the actual arglist for PASS. */
5407 if (!update_compcall_arglist (e
))
5410 *actual
= e
->value
.compcall
.actual
;
5411 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5413 gfc_free_ref_list (e
->ref
);
5415 e
->value
.compcall
.actual
= NULL
;
5417 /* If we find a deferred typebound procedure, check for derived types
5418 that an overriding typebound procedure has not been missed. */
5419 if (e
->value
.compcall
.name
5420 && !e
->value
.compcall
.tbp
->non_overridable
5421 && e
->value
.compcall
.base_object
5422 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5425 gfc_symbol
*derived
;
5427 /* Use the derived type of the base_object. */
5428 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5431 /* If necessary, go through the inheritance chain. */
5432 while (!st
&& derived
)
5434 /* Look for the typebound procedure 'name'. */
5435 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5436 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5437 e
->value
.compcall
.name
);
5439 derived
= gfc_get_derived_super_type (derived
);
5442 /* Now find the specific name in the derived type namespace. */
5443 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5444 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5445 derived
->ns
, 1, &st
);
5453 /* Get the ultimate declared type from an expression. In addition,
5454 return the last class/derived type reference and the copy of the
5455 reference list. If check_types is set true, derived types are
5456 identified as well as class references. */
5458 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5459 gfc_expr
*e
, bool check_types
)
5461 gfc_symbol
*declared
;
5468 *new_ref
= gfc_copy_ref (e
->ref
);
5470 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5472 if (ref
->type
!= REF_COMPONENT
)
5475 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5476 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5477 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5479 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5485 if (declared
== NULL
)
5486 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5492 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5493 which of the specific bindings (if any) matches the arglist and transform
5494 the expression into a call of that binding. */
5497 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5499 gfc_typebound_proc
* genproc
;
5500 const char* genname
;
5502 gfc_symbol
*derived
;
5504 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5505 genname
= e
->value
.compcall
.name
;
5506 genproc
= e
->value
.compcall
.tbp
;
5508 if (!genproc
->is_generic
)
5511 /* Try the bindings on this type and in the inheritance hierarchy. */
5512 for (; genproc
; genproc
= genproc
->overridden
)
5516 gcc_assert (genproc
->is_generic
);
5517 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5520 gfc_actual_arglist
* args
;
5523 gcc_assert (g
->specific
);
5525 if (g
->specific
->error
)
5528 target
= g
->specific
->u
.specific
->n
.sym
;
5530 /* Get the right arglist by handling PASS/NOPASS. */
5531 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5532 if (!g
->specific
->nopass
)
5535 po
= extract_compcall_passed_object (e
);
5538 gfc_free_actual_arglist (args
);
5542 gcc_assert (g
->specific
->pass_arg_num
> 0);
5543 gcc_assert (!g
->specific
->error
);
5544 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5545 g
->specific
->pass_arg
);
5547 resolve_actual_arglist (args
, target
->attr
.proc
,
5548 is_external_proc (target
)
5549 && gfc_sym_get_dummy_args (target
) == NULL
);
5551 /* Check if this arglist matches the formal. */
5552 matches
= gfc_arglist_matches_symbol (&args
, target
);
5554 /* Clean up and break out of the loop if we've found it. */
5555 gfc_free_actual_arglist (args
);
5558 e
->value
.compcall
.tbp
= g
->specific
;
5559 genname
= g
->specific_st
->name
;
5560 /* Pass along the name for CLASS methods, where the vtab
5561 procedure pointer component has to be referenced. */
5569 /* Nothing matching found! */
5570 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5571 " '%s' at %L", genname
, &e
->where
);
5575 /* Make sure that we have the right specific instance for the name. */
5576 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5578 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5580 e
->value
.compcall
.tbp
= st
->n
.tb
;
5586 /* Resolve a call to a type-bound subroutine. */
5589 resolve_typebound_call (gfc_code
* c
, const char **name
)
5591 gfc_actual_arglist
* newactual
;
5592 gfc_symtree
* target
;
5594 /* Check that's really a SUBROUTINE. */
5595 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5597 gfc_error ("'%s' at %L should be a SUBROUTINE",
5598 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5602 if (!check_typebound_baseobject (c
->expr1
))
5605 /* Pass along the name for CLASS methods, where the vtab
5606 procedure pointer component has to be referenced. */
5608 *name
= c
->expr1
->value
.compcall
.name
;
5610 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5613 /* Transform into an ordinary EXEC_CALL for now. */
5615 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5618 c
->ext
.actual
= newactual
;
5619 c
->symtree
= target
;
5620 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5622 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5624 gfc_free_expr (c
->expr1
);
5625 c
->expr1
= gfc_get_expr ();
5626 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5627 c
->expr1
->symtree
= target
;
5628 c
->expr1
->where
= c
->loc
;
5630 return resolve_call (c
);
5634 /* Resolve a component-call expression. */
5636 resolve_compcall (gfc_expr
* e
, const char **name
)
5638 gfc_actual_arglist
* newactual
;
5639 gfc_symtree
* target
;
5641 /* Check that's really a FUNCTION. */
5642 if (!e
->value
.compcall
.tbp
->function
)
5644 gfc_error ("'%s' at %L should be a FUNCTION",
5645 e
->value
.compcall
.name
, &e
->where
);
5649 /* These must not be assign-calls! */
5650 gcc_assert (!e
->value
.compcall
.assign
);
5652 if (!check_typebound_baseobject (e
))
5655 /* Pass along the name for CLASS methods, where the vtab
5656 procedure pointer component has to be referenced. */
5658 *name
= e
->value
.compcall
.name
;
5660 if (!resolve_typebound_generic_call (e
, name
))
5662 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5664 /* Take the rank from the function's symbol. */
5665 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5666 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5668 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5669 arglist to the TBP's binding target. */
5671 if (!resolve_typebound_static (e
, &target
, &newactual
))
5674 e
->value
.function
.actual
= newactual
;
5675 e
->value
.function
.name
= NULL
;
5676 e
->value
.function
.esym
= target
->n
.sym
;
5677 e
->value
.function
.isym
= NULL
;
5678 e
->symtree
= target
;
5679 e
->ts
= target
->n
.sym
->ts
;
5680 e
->expr_type
= EXPR_FUNCTION
;
5682 /* Resolution is not necessary if this is a class subroutine; this
5683 function only has to identify the specific proc. Resolution of
5684 the call will be done next in resolve_typebound_call. */
5685 return gfc_resolve_expr (e
);
5689 static bool resolve_fl_derived (gfc_symbol
*sym
);
5692 /* Resolve a typebound function, or 'method'. First separate all
5693 the non-CLASS references by calling resolve_compcall directly. */
5696 resolve_typebound_function (gfc_expr
* e
)
5698 gfc_symbol
*declared
;
5710 /* Deal with typebound operators for CLASS objects. */
5711 expr
= e
->value
.compcall
.base_object
;
5712 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5713 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5715 /* If the base_object is not a variable, the corresponding actual
5716 argument expression must be stored in e->base_expression so
5717 that the corresponding tree temporary can be used as the base
5718 object in gfc_conv_procedure_call. */
5719 if (expr
->expr_type
!= EXPR_VARIABLE
)
5721 gfc_actual_arglist
*args
;
5723 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5725 if (expr
== args
->expr
)
5730 /* Since the typebound operators are generic, we have to ensure
5731 that any delays in resolution are corrected and that the vtab
5734 declared
= ts
.u
.derived
;
5735 c
= gfc_find_component (declared
, "_vptr", true, true);
5736 if (c
->ts
.u
.derived
== NULL
)
5737 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5739 if (!resolve_compcall (e
, &name
))
5742 /* Use the generic name if it is there. */
5743 name
= name
? name
: e
->value
.function
.esym
->name
;
5744 e
->symtree
= expr
->symtree
;
5745 e
->ref
= gfc_copy_ref (expr
->ref
);
5746 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5748 /* Trim away the extraneous references that emerge from nested
5749 use of interface.c (extend_expr). */
5750 if (class_ref
&& class_ref
->next
)
5752 gfc_free_ref_list (class_ref
->next
);
5753 class_ref
->next
= NULL
;
5755 else if (e
->ref
&& !class_ref
)
5757 gfc_free_ref_list (e
->ref
);
5761 gfc_add_vptr_component (e
);
5762 gfc_add_component_ref (e
, name
);
5763 e
->value
.function
.esym
= NULL
;
5764 if (expr
->expr_type
!= EXPR_VARIABLE
)
5765 e
->base_expr
= expr
;
5770 return resolve_compcall (e
, NULL
);
5772 if (!resolve_ref (e
))
5775 /* Get the CLASS declared type. */
5776 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5778 if (!resolve_fl_derived (declared
))
5781 /* Weed out cases of the ultimate component being a derived type. */
5782 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5783 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5785 gfc_free_ref_list (new_ref
);
5786 return resolve_compcall (e
, NULL
);
5789 c
= gfc_find_component (declared
, "_data", true, true);
5790 declared
= c
->ts
.u
.derived
;
5792 /* Treat the call as if it is a typebound procedure, in order to roll
5793 out the correct name for the specific function. */
5794 if (!resolve_compcall (e
, &name
))
5796 gfc_free_ref_list (new_ref
);
5803 /* Convert the expression to a procedure pointer component call. */
5804 e
->value
.function
.esym
= NULL
;
5810 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5811 gfc_add_vptr_component (e
);
5812 gfc_add_component_ref (e
, name
);
5814 /* Recover the typespec for the expression. This is really only
5815 necessary for generic procedures, where the additional call
5816 to gfc_add_component_ref seems to throw the collection of the
5817 correct typespec. */
5821 gfc_free_ref_list (new_ref
);
5826 /* Resolve a typebound subroutine, or 'method'. First separate all
5827 the non-CLASS references by calling resolve_typebound_call
5831 resolve_typebound_subroutine (gfc_code
*code
)
5833 gfc_symbol
*declared
;
5843 st
= code
->expr1
->symtree
;
5845 /* Deal with typebound operators for CLASS objects. */
5846 expr
= code
->expr1
->value
.compcall
.base_object
;
5847 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5848 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5850 /* If the base_object is not a variable, the corresponding actual
5851 argument expression must be stored in e->base_expression so
5852 that the corresponding tree temporary can be used as the base
5853 object in gfc_conv_procedure_call. */
5854 if (expr
->expr_type
!= EXPR_VARIABLE
)
5856 gfc_actual_arglist
*args
;
5858 args
= code
->expr1
->value
.function
.actual
;
5859 for (; args
; args
= args
->next
)
5860 if (expr
== args
->expr
)
5864 /* Since the typebound operators are generic, we have to ensure
5865 that any delays in resolution are corrected and that the vtab
5867 declared
= expr
->ts
.u
.derived
;
5868 c
= gfc_find_component (declared
, "_vptr", true, true);
5869 if (c
->ts
.u
.derived
== NULL
)
5870 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5872 if (!resolve_typebound_call (code
, &name
))
5875 /* Use the generic name if it is there. */
5876 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5877 code
->expr1
->symtree
= expr
->symtree
;
5878 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5880 /* Trim away the extraneous references that emerge from nested
5881 use of interface.c (extend_expr). */
5882 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5883 if (class_ref
&& class_ref
->next
)
5885 gfc_free_ref_list (class_ref
->next
);
5886 class_ref
->next
= NULL
;
5888 else if (code
->expr1
->ref
&& !class_ref
)
5890 gfc_free_ref_list (code
->expr1
->ref
);
5891 code
->expr1
->ref
= NULL
;
5894 /* Now use the procedure in the vtable. */
5895 gfc_add_vptr_component (code
->expr1
);
5896 gfc_add_component_ref (code
->expr1
, name
);
5897 code
->expr1
->value
.function
.esym
= NULL
;
5898 if (expr
->expr_type
!= EXPR_VARIABLE
)
5899 code
->expr1
->base_expr
= expr
;
5904 return resolve_typebound_call (code
, NULL
);
5906 if (!resolve_ref (code
->expr1
))
5909 /* Get the CLASS declared type. */
5910 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5912 /* Weed out cases of the ultimate component being a derived type. */
5913 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5914 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5916 gfc_free_ref_list (new_ref
);
5917 return resolve_typebound_call (code
, NULL
);
5920 if (!resolve_typebound_call (code
, &name
))
5922 gfc_free_ref_list (new_ref
);
5925 ts
= code
->expr1
->ts
;
5929 /* Convert the expression to a procedure pointer component call. */
5930 code
->expr1
->value
.function
.esym
= NULL
;
5931 code
->expr1
->symtree
= st
;
5934 code
->expr1
->ref
= new_ref
;
5936 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5937 gfc_add_vptr_component (code
->expr1
);
5938 gfc_add_component_ref (code
->expr1
, name
);
5940 /* Recover the typespec for the expression. This is really only
5941 necessary for generic procedures, where the additional call
5942 to gfc_add_component_ref seems to throw the collection of the
5943 correct typespec. */
5944 code
->expr1
->ts
= ts
;
5947 gfc_free_ref_list (new_ref
);
5953 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5956 resolve_ppc_call (gfc_code
* c
)
5958 gfc_component
*comp
;
5960 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5961 gcc_assert (comp
!= NULL
);
5963 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5964 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5966 if (!comp
->attr
.subroutine
)
5967 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5969 if (!resolve_ref (c
->expr1
))
5972 if (!update_ppc_arglist (c
->expr1
))
5975 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5977 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5978 !(comp
->ts
.interface
5979 && comp
->ts
.interface
->formal
)))
5982 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5988 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5991 resolve_expr_ppc (gfc_expr
* e
)
5993 gfc_component
*comp
;
5995 comp
= gfc_get_proc_ptr_comp (e
);
5996 gcc_assert (comp
!= NULL
);
5998 /* Convert to EXPR_FUNCTION. */
5999 e
->expr_type
= EXPR_FUNCTION
;
6000 e
->value
.function
.isym
= NULL
;
6001 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6003 if (comp
->as
!= NULL
)
6004 e
->rank
= comp
->as
->rank
;
6006 if (!comp
->attr
.function
)
6007 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6009 if (!resolve_ref (e
))
6012 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6013 !(comp
->ts
.interface
6014 && comp
->ts
.interface
->formal
)))
6017 if (!update_ppc_arglist (e
))
6020 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6027 gfc_is_expandable_expr (gfc_expr
*e
)
6029 gfc_constructor
*con
;
6031 if (e
->expr_type
== EXPR_ARRAY
)
6033 /* Traverse the constructor looking for variables that are flavor
6034 parameter. Parameters must be expanded since they are fully used at
6036 con
= gfc_constructor_first (e
->value
.constructor
);
6037 for (; con
; con
= gfc_constructor_next (con
))
6039 if (con
->expr
->expr_type
== EXPR_VARIABLE
6040 && con
->expr
->symtree
6041 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6042 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6044 if (con
->expr
->expr_type
== EXPR_ARRAY
6045 && gfc_is_expandable_expr (con
->expr
))
6053 /* Resolve an expression. That is, make sure that types of operands agree
6054 with their operators, intrinsic operators are converted to function calls
6055 for overloaded types and unresolved function references are resolved. */
6058 gfc_resolve_expr (gfc_expr
*e
)
6061 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6066 /* inquiry_argument only applies to variables. */
6067 inquiry_save
= inquiry_argument
;
6068 actual_arg_save
= actual_arg
;
6069 first_actual_arg_save
= first_actual_arg
;
6071 if (e
->expr_type
!= EXPR_VARIABLE
)
6073 inquiry_argument
= false;
6075 first_actual_arg
= false;
6078 switch (e
->expr_type
)
6081 t
= resolve_operator (e
);
6087 if (check_host_association (e
))
6088 t
= resolve_function (e
);
6091 t
= resolve_variable (e
);
6093 expression_rank (e
);
6096 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6097 && e
->ref
->type
!= REF_SUBSTRING
)
6098 gfc_resolve_substring_charlen (e
);
6103 t
= resolve_typebound_function (e
);
6106 case EXPR_SUBSTRING
:
6107 t
= resolve_ref (e
);
6116 t
= resolve_expr_ppc (e
);
6121 if (!resolve_ref (e
))
6124 t
= gfc_resolve_array_constructor (e
);
6125 /* Also try to expand a constructor. */
6128 expression_rank (e
);
6129 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6130 gfc_expand_constructor (e
, false);
6133 /* This provides the opportunity for the length of constructors with
6134 character valued function elements to propagate the string length
6135 to the expression. */
6136 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6138 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6139 here rather then add a duplicate test for it above. */
6140 gfc_expand_constructor (e
, false);
6141 t
= gfc_resolve_character_array_constructor (e
);
6146 case EXPR_STRUCTURE
:
6147 t
= resolve_ref (e
);
6151 t
= resolve_structure_cons (e
, 0);
6155 t
= gfc_simplify_expr (e
, 0);
6159 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6162 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6165 inquiry_argument
= inquiry_save
;
6166 actual_arg
= actual_arg_save
;
6167 first_actual_arg
= first_actual_arg_save
;
6173 /* Resolve an expression from an iterator. They must be scalar and have
6174 INTEGER or (optionally) REAL type. */
6177 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6178 const char *name_msgid
)
6180 if (!gfc_resolve_expr (expr
))
6183 if (expr
->rank
!= 0)
6185 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6189 if (expr
->ts
.type
!= BT_INTEGER
)
6191 if (expr
->ts
.type
== BT_REAL
)
6194 return gfc_notify_std (GFC_STD_F95_DEL
,
6195 "%s at %L must be integer",
6196 _(name_msgid
), &expr
->where
);
6199 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6206 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6214 /* Resolve the expressions in an iterator structure. If REAL_OK is
6215 false allow only INTEGER type iterators, otherwise allow REAL types.
6216 Set own_scope to true for ac-implied-do and data-implied-do as those
6217 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6220 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6222 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6225 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6226 _("iterator variable")))
6229 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6230 "Start expression in DO loop"))
6233 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6234 "End expression in DO loop"))
6237 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6238 "Step expression in DO loop"))
6241 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6243 if ((iter
->step
->ts
.type
== BT_INTEGER
6244 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6245 || (iter
->step
->ts
.type
== BT_REAL
6246 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6248 gfc_error ("Step expression in DO loop at %L cannot be zero",
6249 &iter
->step
->where
);
6254 /* Convert start, end, and step to the same type as var. */
6255 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6256 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6257 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6259 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6260 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6261 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6263 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6264 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6265 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6267 if (iter
->start
->expr_type
== EXPR_CONSTANT
6268 && iter
->end
->expr_type
== EXPR_CONSTANT
6269 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6272 if (iter
->start
->ts
.type
== BT_INTEGER
)
6274 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6275 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6279 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6280 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6282 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6283 gfc_warning ("DO loop at %L will be executed zero times",
6284 &iter
->step
->where
);
6291 /* Traversal function for find_forall_index. f == 2 signals that
6292 that variable itself is not to be checked - only the references. */
6295 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6297 if (expr
->expr_type
!= EXPR_VARIABLE
)
6300 /* A scalar assignment */
6301 if (!expr
->ref
|| *f
== 1)
6303 if (expr
->symtree
->n
.sym
== sym
)
6315 /* Check whether the FORALL index appears in the expression or not.
6316 Returns true if SYM is found in EXPR. */
6319 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6321 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6328 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6329 to be a scalar INTEGER variable. The subscripts and stride are scalar
6330 INTEGERs, and if stride is a constant it must be nonzero.
6331 Furthermore "A subscript or stride in a forall-triplet-spec shall
6332 not contain a reference to any index-name in the
6333 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6336 resolve_forall_iterators (gfc_forall_iterator
*it
)
6338 gfc_forall_iterator
*iter
, *iter2
;
6340 for (iter
= it
; iter
; iter
= iter
->next
)
6342 if (gfc_resolve_expr (iter
->var
)
6343 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6344 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6347 if (gfc_resolve_expr (iter
->start
)
6348 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6349 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6350 &iter
->start
->where
);
6351 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6352 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6354 if (gfc_resolve_expr (iter
->end
)
6355 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6356 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6358 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6359 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6361 if (gfc_resolve_expr (iter
->stride
))
6363 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6364 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6365 &iter
->stride
->where
, "INTEGER");
6367 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6368 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6369 gfc_error ("FORALL stride expression at %L cannot be zero",
6370 &iter
->stride
->where
);
6372 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6373 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6376 for (iter
= it
; iter
; iter
= iter
->next
)
6377 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6379 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6380 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6381 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6382 gfc_error ("FORALL index '%s' may not appear in triplet "
6383 "specification at %L", iter
->var
->symtree
->name
,
6384 &iter2
->start
->where
);
6389 /* Given a pointer to a symbol that is a derived type, see if it's
6390 inaccessible, i.e. if it's defined in another module and the components are
6391 PRIVATE. The search is recursive if necessary. Returns zero if no
6392 inaccessible components are found, nonzero otherwise. */
6395 derived_inaccessible (gfc_symbol
*sym
)
6399 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6402 for (c
= sym
->components
; c
; c
= c
->next
)
6404 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6412 /* Resolve the argument of a deallocate expression. The expression must be
6413 a pointer or a full array. */
6416 resolve_deallocate_expr (gfc_expr
*e
)
6418 symbol_attribute attr
;
6419 int allocatable
, pointer
;
6425 if (!gfc_resolve_expr (e
))
6428 if (e
->expr_type
!= EXPR_VARIABLE
)
6431 sym
= e
->symtree
->n
.sym
;
6432 unlimited
= UNLIMITED_POLY(sym
);
6434 if (sym
->ts
.type
== BT_CLASS
)
6436 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6437 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6441 allocatable
= sym
->attr
.allocatable
;
6442 pointer
= sym
->attr
.pointer
;
6444 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6449 if (ref
->u
.ar
.type
!= AR_FULL
6450 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6451 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6456 c
= ref
->u
.c
.component
;
6457 if (c
->ts
.type
== BT_CLASS
)
6459 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6460 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6464 allocatable
= c
->attr
.allocatable
;
6465 pointer
= c
->attr
.pointer
;
6475 attr
= gfc_expr_attr (e
);
6477 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6480 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6486 if (gfc_is_coindexed (e
))
6488 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6493 && !gfc_check_vardef_context (e
, true, true, false,
6494 _("DEALLOCATE object")))
6496 if (!gfc_check_vardef_context (e
, false, true, false,
6497 _("DEALLOCATE object")))
6504 /* Returns true if the expression e contains a reference to the symbol sym. */
6506 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6508 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6515 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6517 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6521 /* Given the expression node e for an allocatable/pointer of derived type to be
6522 allocated, get the expression node to be initialized afterwards (needed for
6523 derived types with default initializers, and derived types with allocatable
6524 components that need nullification.) */
6527 gfc_expr_to_initialize (gfc_expr
*e
)
6533 result
= gfc_copy_expr (e
);
6535 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6536 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6537 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6539 ref
->u
.ar
.type
= AR_FULL
;
6541 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6542 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6547 gfc_free_shape (&result
->shape
, result
->rank
);
6549 /* Recalculate rank, shape, etc. */
6550 gfc_resolve_expr (result
);
6555 /* If the last ref of an expression is an array ref, return a copy of the
6556 expression with that one removed. Otherwise, a copy of the original
6557 expression. This is used for allocate-expressions and pointer assignment
6558 LHS, where there may be an array specification that needs to be stripped
6559 off when using gfc_check_vardef_context. */
6562 remove_last_array_ref (gfc_expr
* e
)
6567 e2
= gfc_copy_expr (e
);
6568 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6569 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6571 gfc_free_ref_list (*r
);
6580 /* Used in resolve_allocate_expr to check that a allocation-object and
6581 a source-expr are conformable. This does not catch all possible
6582 cases; in particular a runtime checking is needed. */
6585 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6588 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6590 /* First compare rank. */
6591 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6593 gfc_error ("Source-expr at %L must be scalar or have the "
6594 "same rank as the allocate-object at %L",
6595 &e1
->where
, &e2
->where
);
6606 for (i
= 0; i
< e1
->rank
; i
++)
6608 if (tail
->u
.ar
.start
[i
] == NULL
)
6611 if (tail
->u
.ar
.end
[i
])
6613 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6614 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6615 mpz_add_ui (s
, s
, 1);
6619 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6622 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6624 gfc_error ("Source-expr at %L and allocate-object at %L must "
6625 "have the same shape", &e1
->where
, &e2
->where
);
6638 /* Resolve the expression in an ALLOCATE statement, doing the additional
6639 checks to see whether the expression is OK or not. The expression must
6640 have a trailing array reference that gives the size of the array. */
6643 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6645 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6649 symbol_attribute attr
;
6650 gfc_ref
*ref
, *ref2
;
6653 gfc_symbol
*sym
= NULL
;
6658 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6659 checking of coarrays. */
6660 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6661 if (ref
->next
== NULL
)
6664 if (ref
&& ref
->type
== REF_ARRAY
)
6665 ref
->u
.ar
.in_allocate
= true;
6667 if (!gfc_resolve_expr (e
))
6670 /* Make sure the expression is allocatable or a pointer. If it is
6671 pointer, the next-to-last reference must be a pointer. */
6675 sym
= e
->symtree
->n
.sym
;
6677 /* Check whether ultimate component is abstract and CLASS. */
6680 /* Is the allocate-object unlimited polymorphic? */
6681 unlimited
= UNLIMITED_POLY(e
);
6683 if (e
->expr_type
!= EXPR_VARIABLE
)
6686 attr
= gfc_expr_attr (e
);
6687 pointer
= attr
.pointer
;
6688 dimension
= attr
.dimension
;
6689 codimension
= attr
.codimension
;
6693 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6695 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6696 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6697 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6698 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6699 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6703 allocatable
= sym
->attr
.allocatable
;
6704 pointer
= sym
->attr
.pointer
;
6705 dimension
= sym
->attr
.dimension
;
6706 codimension
= sym
->attr
.codimension
;
6711 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6716 if (ref
->u
.ar
.codimen
> 0)
6719 for (n
= ref
->u
.ar
.dimen
;
6720 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6721 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6728 if (ref
->next
!= NULL
)
6736 gfc_error ("Coindexed allocatable object at %L",
6741 c
= ref
->u
.c
.component
;
6742 if (c
->ts
.type
== BT_CLASS
)
6744 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6745 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6746 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6747 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6748 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6752 allocatable
= c
->attr
.allocatable
;
6753 pointer
= c
->attr
.pointer
;
6754 dimension
= c
->attr
.dimension
;
6755 codimension
= c
->attr
.codimension
;
6756 is_abstract
= c
->attr
.abstract
;
6768 /* Check for F08:C628. */
6769 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6771 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6776 /* Some checks for the SOURCE tag. */
6779 /* Check F03:C631. */
6780 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6782 gfc_error ("Type of entity at %L is type incompatible with "
6783 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6787 /* Check F03:C632 and restriction following Note 6.18. */
6788 if (code
->expr3
->rank
> 0 && !unlimited
6789 && !conformable_arrays (code
->expr3
, e
))
6792 /* Check F03:C633. */
6793 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6795 gfc_error ("The allocate-object at %L and the source-expr at %L "
6796 "shall have the same kind type parameter",
6797 &e
->where
, &code
->expr3
->where
);
6801 /* Check F2008, C642. */
6802 if (code
->expr3
->ts
.type
== BT_DERIVED
6803 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6804 || (code
->expr3
->ts
.u
.derived
->from_intmod
6805 == INTMOD_ISO_FORTRAN_ENV
6806 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6807 == ISOFORTRAN_LOCK_TYPE
)))
6809 gfc_error ("The source-expr at %L shall neither be of type "
6810 "LOCK_TYPE nor have a LOCK_TYPE component if "
6811 "allocate-object at %L is a coarray",
6812 &code
->expr3
->where
, &e
->where
);
6817 /* Check F08:C629. */
6818 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6821 gcc_assert (e
->ts
.type
== BT_CLASS
);
6822 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6823 "type-spec or source-expr", sym
->name
, &e
->where
);
6827 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6829 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6830 code
->ext
.alloc
.ts
.u
.cl
->length
);
6831 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6833 gfc_error ("Allocating %s at %L with type-spec requires the same "
6834 "character-length parameter as in the declaration",
6835 sym
->name
, &e
->where
);
6840 /* In the variable definition context checks, gfc_expr_attr is used
6841 on the expression. This is fooled by the array specification
6842 present in e, thus we have to eliminate that one temporarily. */
6843 e2
= remove_last_array_ref (e
);
6846 t
= gfc_check_vardef_context (e2
, true, true, false,
6847 _("ALLOCATE object"));
6849 t
= gfc_check_vardef_context (e2
, false, true, false,
6850 _("ALLOCATE object"));
6855 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6856 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6858 /* For class arrays, the initialization with SOURCE is done
6859 using _copy and trans_call. It is convenient to exploit that
6860 when the allocated type is different from the declared type but
6861 no SOURCE exists by setting expr3. */
6862 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6864 else if (!code
->expr3
)
6866 /* Set up default initializer if needed. */
6870 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6871 ts
= code
->ext
.alloc
.ts
;
6875 if (ts
.type
== BT_CLASS
)
6876 ts
= ts
.u
.derived
->components
->ts
;
6878 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6880 gfc_code
*init_st
= gfc_get_code ();
6881 init_st
->loc
= code
->loc
;
6882 init_st
->op
= EXEC_INIT_ASSIGN
;
6883 init_st
->expr1
= gfc_expr_to_initialize (e
);
6884 init_st
->expr2
= init_e
;
6885 init_st
->next
= code
->next
;
6886 code
->next
= init_st
;
6889 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6891 /* Default initialization via MOLD (non-polymorphic). */
6892 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6893 gfc_resolve_expr (rhs
);
6894 gfc_free_expr (code
->expr3
);
6898 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6900 /* Make sure the vtab symbol is present when
6901 the module variables are generated. */
6902 gfc_typespec ts
= e
->ts
;
6904 ts
= code
->expr3
->ts
;
6905 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6906 ts
= code
->ext
.alloc
.ts
;
6908 gfc_find_derived_vtab (ts
.u
.derived
);
6911 e
= gfc_expr_to_initialize (e
);
6913 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6915 /* Again, make sure the vtab symbol is present when
6916 the module variables are generated. */
6917 gfc_typespec
*ts
= NULL
;
6919 ts
= &code
->expr3
->ts
;
6921 ts
= &code
->ext
.alloc
.ts
;
6925 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6926 gfc_find_derived_vtab (ts
->u
.derived
);
6928 gfc_find_intrinsic_vtab (ts
);
6931 e
= gfc_expr_to_initialize (e
);
6934 if (dimension
== 0 && codimension
== 0)
6937 /* Make sure the last reference node is an array specification. */
6939 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6940 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6942 gfc_error ("Array specification required in ALLOCATE statement "
6943 "at %L", &e
->where
);
6947 /* Make sure that the array section reference makes sense in the
6948 context of an ALLOCATE specification. */
6953 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6954 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6956 gfc_error ("Coarray specification required in ALLOCATE statement "
6957 "at %L", &e
->where
);
6961 for (i
= 0; i
< ar
->dimen
; i
++)
6963 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6966 switch (ar
->dimen_type
[i
])
6972 if (ar
->start
[i
] != NULL
6973 && ar
->end
[i
] != NULL
6974 && ar
->stride
[i
] == NULL
)
6977 /* Fall Through... */
6982 case DIMEN_THIS_IMAGE
:
6983 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6989 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6991 sym
= a
->expr
->symtree
->n
.sym
;
6993 /* TODO - check derived type components. */
6994 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6997 if ((ar
->start
[i
] != NULL
6998 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
6999 || (ar
->end
[i
] != NULL
7000 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7002 gfc_error ("'%s' must not appear in the array specification at "
7003 "%L in the same ALLOCATE statement where it is "
7004 "itself allocated", sym
->name
, &ar
->where
);
7010 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7012 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7013 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7015 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7017 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7018 "statement at %L", &e
->where
);
7024 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7025 && ar
->stride
[i
] == NULL
)
7028 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7041 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7043 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7044 gfc_alloc
*a
, *p
, *q
;
7047 errmsg
= code
->expr2
;
7049 /* Check the stat variable. */
7052 gfc_check_vardef_context (stat
, false, false, false,
7053 _("STAT variable"));
7055 if ((stat
->ts
.type
!= BT_INTEGER
7056 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7057 || stat
->ref
->type
== REF_COMPONENT
)))
7059 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7060 "variable", &stat
->where
);
7062 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7063 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7065 gfc_ref
*ref1
, *ref2
;
7068 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7069 ref1
= ref1
->next
, ref2
= ref2
->next
)
7071 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7073 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7082 gfc_error ("Stat-variable at %L shall not be %sd within "
7083 "the same %s statement", &stat
->where
, fcn
, fcn
);
7089 /* Check the errmsg variable. */
7093 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7096 gfc_check_vardef_context (errmsg
, false, false, false,
7097 _("ERRMSG variable"));
7099 if ((errmsg
->ts
.type
!= BT_CHARACTER
7101 && (errmsg
->ref
->type
== REF_ARRAY
7102 || errmsg
->ref
->type
== REF_COMPONENT
)))
7103 || errmsg
->rank
> 0 )
7104 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7105 "variable", &errmsg
->where
);
7107 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7108 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7110 gfc_ref
*ref1
, *ref2
;
7113 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7114 ref1
= ref1
->next
, ref2
= ref2
->next
)
7116 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7118 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7127 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7128 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7134 /* Check that an allocate-object appears only once in the statement. */
7136 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7139 for (q
= p
->next
; q
; q
= q
->next
)
7142 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7144 /* This is a potential collision. */
7145 gfc_ref
*pr
= pe
->ref
;
7146 gfc_ref
*qr
= qe
->ref
;
7148 /* Follow the references until
7149 a) They start to differ, in which case there is no error;
7150 you can deallocate a%b and a%c in a single statement
7151 b) Both of them stop, which is an error
7152 c) One of them stops, which is also an error. */
7155 if (pr
== NULL
&& qr
== NULL
)
7157 gfc_error ("Allocate-object at %L also appears at %L",
7158 &pe
->where
, &qe
->where
);
7161 else if (pr
!= NULL
&& qr
== NULL
)
7163 gfc_error ("Allocate-object at %L is subobject of"
7164 " object at %L", &pe
->where
, &qe
->where
);
7167 else if (pr
== NULL
&& qr
!= NULL
)
7169 gfc_error ("Allocate-object at %L is subobject of"
7170 " object at %L", &qe
->where
, &pe
->where
);
7173 /* Here, pr != NULL && qr != NULL */
7174 gcc_assert(pr
->type
== qr
->type
);
7175 if (pr
->type
== REF_ARRAY
)
7177 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7179 gcc_assert (qr
->type
== REF_ARRAY
);
7181 if (pr
->next
&& qr
->next
)
7184 gfc_array_ref
*par
= &(pr
->u
.ar
);
7185 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7187 for (i
=0; i
<par
->dimen
; i
++)
7189 if ((par
->start
[i
] != NULL
7190 || qar
->start
[i
] != NULL
)
7191 && gfc_dep_compare_expr (par
->start
[i
],
7192 qar
->start
[i
]) != 0)
7199 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7212 if (strcmp (fcn
, "ALLOCATE") == 0)
7214 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7215 resolve_allocate_expr (a
->expr
, code
);
7219 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7220 resolve_deallocate_expr (a
->expr
);
7225 /************ SELECT CASE resolution subroutines ************/
7227 /* Callback function for our mergesort variant. Determines interval
7228 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7229 op1 > op2. Assumes we're not dealing with the default case.
7230 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7231 There are nine situations to check. */
7234 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7238 if (op1
->low
== NULL
) /* op1 = (:L) */
7240 /* op2 = (:N), so overlap. */
7242 /* op2 = (M:) or (M:N), L < M */
7243 if (op2
->low
!= NULL
7244 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7247 else if (op1
->high
== NULL
) /* op1 = (K:) */
7249 /* op2 = (M:), so overlap. */
7251 /* op2 = (:N) or (M:N), K > N */
7252 if (op2
->high
!= NULL
7253 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7256 else /* op1 = (K:L) */
7258 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7259 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7261 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7262 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7264 else /* op2 = (M:N) */
7268 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7271 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7280 /* Merge-sort a double linked case list, detecting overlap in the
7281 process. LIST is the head of the double linked case list before it
7282 is sorted. Returns the head of the sorted list if we don't see any
7283 overlap, or NULL otherwise. */
7286 check_case_overlap (gfc_case
*list
)
7288 gfc_case
*p
, *q
, *e
, *tail
;
7289 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7291 /* If the passed list was empty, return immediately. */
7298 /* Loop unconditionally. The only exit from this loop is a return
7299 statement, when we've finished sorting the case list. */
7306 /* Count the number of merges we do in this pass. */
7309 /* Loop while there exists a merge to be done. */
7314 /* Count this merge. */
7317 /* Cut the list in two pieces by stepping INSIZE places
7318 forward in the list, starting from P. */
7321 for (i
= 0; i
< insize
; i
++)
7330 /* Now we have two lists. Merge them! */
7331 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7333 /* See from which the next case to merge comes from. */
7336 /* P is empty so the next case must come from Q. */
7341 else if (qsize
== 0 || q
== NULL
)
7350 cmp
= compare_cases (p
, q
);
7353 /* The whole case range for P is less than the
7361 /* The whole case range for Q is greater than
7362 the case range for P. */
7369 /* The cases overlap, or they are the same
7370 element in the list. Either way, we must
7371 issue an error and get the next case from P. */
7372 /* FIXME: Sort P and Q by line number. */
7373 gfc_error ("CASE label at %L overlaps with CASE "
7374 "label at %L", &p
->where
, &q
->where
);
7382 /* Add the next element to the merged list. */
7391 /* P has now stepped INSIZE places along, and so has Q. So
7392 they're the same. */
7397 /* If we have done only one merge or none at all, we've
7398 finished sorting the cases. */
7407 /* Otherwise repeat, merging lists twice the size. */
7413 /* Check to see if an expression is suitable for use in a CASE statement.
7414 Makes sure that all case expressions are scalar constants of the same
7415 type. Return false if anything is wrong. */
7418 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7420 if (e
== NULL
) return true;
7422 if (e
->ts
.type
!= case_expr
->ts
.type
)
7424 gfc_error ("Expression in CASE statement at %L must be of type %s",
7425 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7429 /* C805 (R808) For a given case-construct, each case-value shall be of
7430 the same type as case-expr. For character type, length differences
7431 are allowed, but the kind type parameters shall be the same. */
7433 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7435 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7436 &e
->where
, case_expr
->ts
.kind
);
7440 /* Convert the case value kind to that of case expression kind,
7443 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7444 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7448 gfc_error ("Expression in CASE statement at %L must be scalar",
7457 /* Given a completely parsed select statement, we:
7459 - Validate all expressions and code within the SELECT.
7460 - Make sure that the selection expression is not of the wrong type.
7461 - Make sure that no case ranges overlap.
7462 - Eliminate unreachable cases and unreachable code resulting from
7463 removing case labels.
7465 The standard does allow unreachable cases, e.g. CASE (5:3). But
7466 they are a hassle for code generation, and to prevent that, we just
7467 cut them out here. This is not necessary for overlapping cases
7468 because they are illegal and we never even try to generate code.
7470 We have the additional caveat that a SELECT construct could have
7471 been a computed GOTO in the source code. Fortunately we can fairly
7472 easily work around that here: The case_expr for a "real" SELECT CASE
7473 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7474 we have to do is make sure that the case_expr is a scalar integer
7478 resolve_select (gfc_code
*code
, bool select_type
)
7481 gfc_expr
*case_expr
;
7482 gfc_case
*cp
, *default_case
, *tail
, *head
;
7483 int seen_unreachable
;
7489 if (code
->expr1
== NULL
)
7491 /* This was actually a computed GOTO statement. */
7492 case_expr
= code
->expr2
;
7493 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7494 gfc_error ("Selection expression in computed GOTO statement "
7495 "at %L must be a scalar integer expression",
7498 /* Further checking is not necessary because this SELECT was built
7499 by the compiler, so it should always be OK. Just move the
7500 case_expr from expr2 to expr so that we can handle computed
7501 GOTOs as normal SELECTs from here on. */
7502 code
->expr1
= code
->expr2
;
7507 case_expr
= code
->expr1
;
7508 type
= case_expr
->ts
.type
;
7511 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7513 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7514 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7516 /* Punt. Going on here just produce more garbage error messages. */
7521 if (!select_type
&& case_expr
->rank
!= 0)
7523 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7524 "expression", &case_expr
->where
);
7530 /* Raise a warning if an INTEGER case value exceeds the range of
7531 the case-expr. Later, all expressions will be promoted to the
7532 largest kind of all case-labels. */
7534 if (type
== BT_INTEGER
)
7535 for (body
= code
->block
; body
; body
= body
->block
)
7536 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7539 && gfc_check_integer_range (cp
->low
->value
.integer
,
7540 case_expr
->ts
.kind
) != ARITH_OK
)
7541 gfc_warning ("Expression in CASE statement at %L is "
7542 "not in the range of %s", &cp
->low
->where
,
7543 gfc_typename (&case_expr
->ts
));
7546 && cp
->low
!= cp
->high
7547 && gfc_check_integer_range (cp
->high
->value
.integer
,
7548 case_expr
->ts
.kind
) != ARITH_OK
)
7549 gfc_warning ("Expression in CASE statement at %L is "
7550 "not in the range of %s", &cp
->high
->where
,
7551 gfc_typename (&case_expr
->ts
));
7554 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7555 of the SELECT CASE expression and its CASE values. Walk the lists
7556 of case values, and if we find a mismatch, promote case_expr to
7557 the appropriate kind. */
7559 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7561 for (body
= code
->block
; body
; body
= body
->block
)
7563 /* Walk the case label list. */
7564 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7566 /* Intercept the DEFAULT case. It does not have a kind. */
7567 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7570 /* Unreachable case ranges are discarded, so ignore. */
7571 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7572 && cp
->low
!= cp
->high
7573 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7577 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7578 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7580 if (cp
->high
!= NULL
7581 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7582 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7587 /* Assume there is no DEFAULT case. */
7588 default_case
= NULL
;
7593 for (body
= code
->block
; body
; body
= body
->block
)
7595 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7597 seen_unreachable
= 0;
7599 /* Walk the case label list, making sure that all case labels
7601 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7603 /* Count the number of cases in the whole construct. */
7606 /* Intercept the DEFAULT case. */
7607 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7609 if (default_case
!= NULL
)
7611 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7612 "by a second DEFAULT CASE at %L",
7613 &default_case
->where
, &cp
->where
);
7624 /* Deal with single value cases and case ranges. Errors are
7625 issued from the validation function. */
7626 if (!validate_case_label_expr (cp
->low
, case_expr
)
7627 || !validate_case_label_expr (cp
->high
, case_expr
))
7633 if (type
== BT_LOGICAL
7634 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7635 || cp
->low
!= cp
->high
))
7637 gfc_error ("Logical range in CASE statement at %L is not "
7638 "allowed", &cp
->low
->where
);
7643 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7646 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7647 if (value
& seen_logical
)
7649 gfc_error ("Constant logical value in CASE statement "
7650 "is repeated at %L",
7655 seen_logical
|= value
;
7658 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7659 && cp
->low
!= cp
->high
7660 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7662 if (gfc_option
.warn_surprising
)
7663 gfc_warning ("Range specification at %L can never "
7664 "be matched", &cp
->where
);
7666 cp
->unreachable
= 1;
7667 seen_unreachable
= 1;
7671 /* If the case range can be matched, it can also overlap with
7672 other cases. To make sure it does not, we put it in a
7673 double linked list here. We sort that with a merge sort
7674 later on to detect any overlapping cases. */
7678 head
->right
= head
->left
= NULL
;
7683 tail
->right
->left
= tail
;
7690 /* It there was a failure in the previous case label, give up
7691 for this case label list. Continue with the next block. */
7695 /* See if any case labels that are unreachable have been seen.
7696 If so, we eliminate them. This is a bit of a kludge because
7697 the case lists for a single case statement (label) is a
7698 single forward linked lists. */
7699 if (seen_unreachable
)
7701 /* Advance until the first case in the list is reachable. */
7702 while (body
->ext
.block
.case_list
!= NULL
7703 && body
->ext
.block
.case_list
->unreachable
)
7705 gfc_case
*n
= body
->ext
.block
.case_list
;
7706 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7708 gfc_free_case_list (n
);
7711 /* Strip all other unreachable cases. */
7712 if (body
->ext
.block
.case_list
)
7714 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7716 if (cp
->next
->unreachable
)
7718 gfc_case
*n
= cp
->next
;
7719 cp
->next
= cp
->next
->next
;
7721 gfc_free_case_list (n
);
7728 /* See if there were overlapping cases. If the check returns NULL,
7729 there was overlap. In that case we don't do anything. If head
7730 is non-NULL, we prepend the DEFAULT case. The sorted list can
7731 then used during code generation for SELECT CASE constructs with
7732 a case expression of a CHARACTER type. */
7735 head
= check_case_overlap (head
);
7737 /* Prepend the default_case if it is there. */
7738 if (head
!= NULL
&& default_case
)
7740 default_case
->left
= NULL
;
7741 default_case
->right
= head
;
7742 head
->left
= default_case
;
7746 /* Eliminate dead blocks that may be the result if we've seen
7747 unreachable case labels for a block. */
7748 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7750 if (body
->block
->ext
.block
.case_list
== NULL
)
7752 /* Cut the unreachable block from the code chain. */
7753 gfc_code
*c
= body
->block
;
7754 body
->block
= c
->block
;
7756 /* Kill the dead block, but not the blocks below it. */
7758 gfc_free_statements (c
);
7762 /* More than two cases is legal but insane for logical selects.
7763 Issue a warning for it. */
7764 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7766 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7771 /* Check if a derived type is extensible. */
7774 gfc_type_is_extensible (gfc_symbol
*sym
)
7776 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7777 || (sym
->attr
.is_class
7778 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7782 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7783 correct as well as possibly the array-spec. */
7786 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7790 gcc_assert (sym
->assoc
);
7791 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7793 /* If this is for SELECT TYPE, the target may not yet be set. In that
7794 case, return. Resolution will be called later manually again when
7796 target
= sym
->assoc
->target
;
7799 gcc_assert (!sym
->assoc
->dangling
);
7801 if (resolve_target
&& !gfc_resolve_expr (target
))
7804 /* For variable targets, we get some attributes from the target. */
7805 if (target
->expr_type
== EXPR_VARIABLE
)
7809 gcc_assert (target
->symtree
);
7810 tsym
= target
->symtree
->n
.sym
;
7812 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7813 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7815 sym
->attr
.target
= tsym
->attr
.target
7816 || gfc_expr_attr (target
).pointer
;
7819 /* Get type if this was not already set. Note that it can be
7820 some other type than the target in case this is a SELECT TYPE
7821 selector! So we must not update when the type is already there. */
7822 if (sym
->ts
.type
== BT_UNKNOWN
)
7823 sym
->ts
= target
->ts
;
7824 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7826 /* See if this is a valid association-to-variable. */
7827 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7828 && !gfc_has_vector_subscript (target
));
7830 /* Finally resolve if this is an array or not. */
7831 if (sym
->attr
.dimension
&& target
->rank
== 0)
7833 gfc_error ("Associate-name '%s' at %L is used as array",
7834 sym
->name
, &sym
->declared_at
);
7835 sym
->attr
.dimension
= 0;
7839 /* We cannot deal with class selectors that need temporaries. */
7840 if (target
->ts
.type
== BT_CLASS
7841 && gfc_ref_needs_temporary_p (target
->ref
))
7843 gfc_error ("CLASS selector at %L needs a temporary which is not "
7844 "yet implemented", &target
->where
);
7848 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7849 sym
->attr
.dimension
= 1;
7850 else if (target
->ts
.type
== BT_CLASS
)
7851 gfc_fix_class_refs (target
);
7853 /* The associate-name will have a correct type by now. Make absolutely
7854 sure that it has not picked up a dimension attribute. */
7855 if (sym
->ts
.type
== BT_CLASS
)
7856 sym
->attr
.dimension
= 0;
7858 if (sym
->attr
.dimension
)
7860 sym
->as
= gfc_get_array_spec ();
7861 sym
->as
->rank
= target
->rank
;
7862 sym
->as
->type
= AS_DEFERRED
;
7864 /* Target must not be coindexed, thus the associate-variable
7866 sym
->as
->corank
= 0;
7869 /* Mark this as an associate variable. */
7870 sym
->attr
.associate_var
= 1;
7872 /* If the target is a good class object, so is the associate variable. */
7873 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7874 sym
->attr
.class_ok
= 1;
7878 /* Resolve a SELECT TYPE statement. */
7881 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7883 gfc_symbol
*selector_type
;
7884 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7885 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7888 char name
[GFC_MAX_SYMBOL_LEN
];
7893 ns
= code
->ext
.block
.ns
;
7896 /* Check for F03:C813. */
7897 if (code
->expr1
->ts
.type
!= BT_CLASS
7898 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7900 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7901 "at %L", &code
->loc
);
7905 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7910 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7911 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7912 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7914 /* F2008: C803 The selector expression must not be coindexed. */
7915 if (gfc_is_coindexed (code
->expr2
))
7917 gfc_error ("Selector at %L must not be coindexed",
7918 &code
->expr2
->where
);
7925 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7927 if (gfc_is_coindexed (code
->expr1
))
7929 gfc_error ("Selector at %L must not be coindexed",
7930 &code
->expr1
->where
);
7935 /* Loop over TYPE IS / CLASS IS cases. */
7936 for (body
= code
->block
; body
; body
= body
->block
)
7938 c
= body
->ext
.block
.case_list
;
7940 /* Check F03:C815. */
7941 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7942 && !selector_type
->attr
.unlimited_polymorphic
7943 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7945 gfc_error ("Derived type '%s' at %L must be extensible",
7946 c
->ts
.u
.derived
->name
, &c
->where
);
7951 /* Check F03:C816. */
7952 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
7953 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
7954 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
7956 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7957 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7958 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7960 gfc_error ("Unexpected intrinsic type '%s' at %L",
7961 gfc_basic_typename (c
->ts
.type
), &c
->where
);
7966 /* Check F03:C814. */
7967 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
7969 gfc_error ("The type-spec at %L shall specify that each length "
7970 "type parameter is assumed", &c
->where
);
7975 /* Intercept the DEFAULT case. */
7976 if (c
->ts
.type
== BT_UNKNOWN
)
7978 /* Check F03:C818. */
7981 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7982 "by a second DEFAULT CASE at %L",
7983 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7988 default_case
= body
;
7995 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7996 target if present. If there are any EXIT statements referring to the
7997 SELECT TYPE construct, this is no problem because the gfc_code
7998 reference stays the same and EXIT is equally possible from the BLOCK
7999 it is changed to. */
8000 code
->op
= EXEC_BLOCK
;
8003 gfc_association_list
* assoc
;
8005 assoc
= gfc_get_association_list ();
8006 assoc
->st
= code
->expr1
->symtree
;
8007 assoc
->target
= gfc_copy_expr (code
->expr2
);
8008 assoc
->target
->where
= code
->expr2
->where
;
8009 /* assoc->variable will be set by resolve_assoc_var. */
8011 code
->ext
.block
.assoc
= assoc
;
8012 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8014 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8017 code
->ext
.block
.assoc
= NULL
;
8019 /* Add EXEC_SELECT to switch on type. */
8020 new_st
= gfc_get_code ();
8021 new_st
->op
= code
->op
;
8022 new_st
->expr1
= code
->expr1
;
8023 new_st
->expr2
= code
->expr2
;
8024 new_st
->block
= code
->block
;
8025 code
->expr1
= code
->expr2
= NULL
;
8030 ns
->code
->next
= new_st
;
8032 code
->op
= EXEC_SELECT
;
8034 gfc_add_vptr_component (code
->expr1
);
8035 gfc_add_hash_component (code
->expr1
);
8037 /* Loop over TYPE IS / CLASS IS cases. */
8038 for (body
= code
->block
; body
; body
= body
->block
)
8040 c
= body
->ext
.block
.case_list
;
8042 if (c
->ts
.type
== BT_DERIVED
)
8043 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8044 c
->ts
.u
.derived
->hash_value
);
8045 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8050 ivtab
= gfc_find_intrinsic_vtab (&c
->ts
);
8051 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8052 e
= CLASS_DATA (ivtab
)->initializer
;
8053 c
->low
= c
->high
= gfc_copy_expr (e
);
8056 else if (c
->ts
.type
== BT_UNKNOWN
)
8059 /* Associate temporary to selector. This should only be done
8060 when this case is actually true, so build a new ASSOCIATE
8061 that does precisely this here (instead of using the
8064 if (c
->ts
.type
== BT_CLASS
)
8065 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8066 else if (c
->ts
.type
== BT_DERIVED
)
8067 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8068 else if (c
->ts
.type
== BT_CHARACTER
)
8070 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8071 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8072 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8073 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8074 charlen
, c
->ts
.kind
);
8077 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8080 st
= gfc_find_symtree (ns
->sym_root
, name
);
8081 gcc_assert (st
->n
.sym
->assoc
);
8082 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8083 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8084 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8085 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8087 new_st
= gfc_get_code ();
8088 new_st
->op
= EXEC_BLOCK
;
8089 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8090 new_st
->ext
.block
.ns
->code
= body
->next
;
8091 body
->next
= new_st
;
8093 /* Chain in the new list only if it is marked as dangling. Otherwise
8094 there is a CASE label overlap and this is already used. Just ignore,
8095 the error is diagnosed elsewhere. */
8096 if (st
->n
.sym
->assoc
->dangling
)
8098 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8099 st
->n
.sym
->assoc
->dangling
= 0;
8102 resolve_assoc_var (st
->n
.sym
, false);
8105 /* Take out CLASS IS cases for separate treatment. */
8107 while (body
&& body
->block
)
8109 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8111 /* Add to class_is list. */
8112 if (class_is
== NULL
)
8114 class_is
= body
->block
;
8119 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8120 tail
->block
= body
->block
;
8123 /* Remove from EXEC_SELECT list. */
8124 body
->block
= body
->block
->block
;
8137 /* Add a default case to hold the CLASS IS cases. */
8138 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8139 tail
->block
= gfc_get_code ();
8141 tail
->op
= EXEC_SELECT_TYPE
;
8142 tail
->ext
.block
.case_list
= gfc_get_case ();
8143 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8145 default_case
= tail
;
8148 /* More than one CLASS IS block? */
8149 if (class_is
->block
)
8153 /* Sort CLASS IS blocks by extension level. */
8157 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8160 /* F03:C817 (check for doubles). */
8161 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8162 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8164 gfc_error ("Double CLASS IS block in SELECT TYPE "
8166 &c2
->ext
.block
.case_list
->where
);
8169 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8170 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8173 (*c1
)->block
= c2
->block
;
8183 /* Generate IF chain. */
8184 if_st
= gfc_get_code ();
8185 if_st
->op
= EXEC_IF
;
8187 for (body
= class_is
; body
; body
= body
->block
)
8189 new_st
->block
= gfc_get_code ();
8190 new_st
= new_st
->block
;
8191 new_st
->op
= EXEC_IF
;
8192 /* Set up IF condition: Call _gfortran_is_extension_of. */
8193 new_st
->expr1
= gfc_get_expr ();
8194 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8195 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8196 new_st
->expr1
->ts
.kind
= 4;
8197 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8198 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8199 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8200 /* Set up arguments. */
8201 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8202 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8203 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8204 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8205 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8206 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8207 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8208 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8209 new_st
->next
= body
->next
;
8211 if (default_case
->next
)
8213 new_st
->block
= gfc_get_code ();
8214 new_st
= new_st
->block
;
8215 new_st
->op
= EXEC_IF
;
8216 new_st
->next
= default_case
->next
;
8219 /* Replace CLASS DEFAULT code by the IF chain. */
8220 default_case
->next
= if_st
;
8223 /* Resolve the internal code. This can not be done earlier because
8224 it requires that the sym->assoc of selectors is set already. */
8225 gfc_current_ns
= ns
;
8226 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8227 gfc_current_ns
= old_ns
;
8229 resolve_select (code
, true);
8233 /* Resolve a transfer statement. This is making sure that:
8234 -- a derived type being transferred has only non-pointer components
8235 -- a derived type being transferred doesn't have private components, unless
8236 it's being transferred from the module where the type was defined
8237 -- we're not trying to transfer a whole assumed size array. */
8240 resolve_transfer (gfc_code
*code
)
8249 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8250 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8251 exp
= exp
->value
.op
.op1
;
8253 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8255 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8256 "MOLD=", &exp
->where
);
8260 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8261 && exp
->expr_type
!= EXPR_FUNCTION
))
8264 /* If we are reading, the variable will be changed. Note that
8265 code->ext.dt may be NULL if the TRANSFER is related to
8266 an INQUIRE statement -- but in this case, we are not reading, either. */
8267 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8268 && !gfc_check_vardef_context (exp
, false, false, false,
8272 sym
= exp
->symtree
->n
.sym
;
8275 /* Go to actual component transferred. */
8276 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8277 if (ref
->type
== REF_COMPONENT
)
8278 ts
= &ref
->u
.c
.component
->ts
;
8280 if (ts
->type
== BT_CLASS
)
8282 /* FIXME: Test for defined input/output. */
8283 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8284 "it is processed by a defined input/output procedure",
8289 if (ts
->type
== BT_DERIVED
)
8291 /* Check that transferred derived type doesn't contain POINTER
8293 if (ts
->u
.derived
->attr
.pointer_comp
)
8295 gfc_error ("Data transfer element at %L cannot have POINTER "
8296 "components unless it is processed by a defined "
8297 "input/output procedure", &code
->loc
);
8302 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8304 gfc_error ("Data transfer element at %L cannot have "
8305 "procedure pointer components", &code
->loc
);
8309 if (ts
->u
.derived
->attr
.alloc_comp
)
8311 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8312 "components unless it is processed by a defined "
8313 "input/output procedure", &code
->loc
);
8317 /* C_PTR and C_FUNPTR have private components which means they can not
8318 be printed. However, if -std=gnu and not -pedantic, allow
8319 the component to be printed to help debugging. */
8320 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8322 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8323 "cannot have PRIVATE components", &code
->loc
))
8326 else if (derived_inaccessible (ts
->u
.derived
))
8328 gfc_error ("Data transfer element at %L cannot have "
8329 "PRIVATE components",&code
->loc
);
8334 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8335 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8337 gfc_error ("Data transfer element at %L cannot be a full reference to "
8338 "an assumed-size array", &code
->loc
);
8344 /*********** Toplevel code resolution subroutines ***********/
8346 /* Find the set of labels that are reachable from this block. We also
8347 record the last statement in each block. */
8350 find_reachable_labels (gfc_code
*block
)
8357 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8359 /* Collect labels in this block. We don't keep those corresponding
8360 to END {IF|SELECT}, these are checked in resolve_branch by going
8361 up through the code_stack. */
8362 for (c
= block
; c
; c
= c
->next
)
8364 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8365 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8368 /* Merge with labels from parent block. */
8371 gcc_assert (cs_base
->prev
->reachable_labels
);
8372 bitmap_ior_into (cs_base
->reachable_labels
,
8373 cs_base
->prev
->reachable_labels
);
8379 resolve_lock_unlock (gfc_code
*code
)
8381 if (code
->expr1
->ts
.type
!= BT_DERIVED
8382 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8383 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8384 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8385 || code
->expr1
->rank
!= 0
8386 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8387 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8388 &code
->expr1
->where
);
8392 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8393 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8394 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8395 &code
->expr2
->where
);
8398 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8399 _("STAT variable")))
8404 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8405 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8406 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8407 &code
->expr3
->where
);
8410 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8411 _("ERRMSG variable")))
8414 /* Check ACQUIRED_LOCK. */
8416 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8417 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8418 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8419 "variable", &code
->expr4
->where
);
8422 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8423 _("ACQUIRED_LOCK variable")))
8429 resolve_sync (gfc_code
*code
)
8431 /* Check imageset. The * case matches expr1 == NULL. */
8434 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8435 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8436 "INTEGER expression", &code
->expr1
->where
);
8437 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8438 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8439 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8440 &code
->expr1
->where
);
8441 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8442 && gfc_simplify_expr (code
->expr1
, 0))
8444 gfc_constructor
*cons
;
8445 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8446 for (; cons
; cons
= gfc_constructor_next (cons
))
8447 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8448 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8449 gfc_error ("Imageset argument at %L must between 1 and "
8450 "num_images()", &cons
->expr
->where
);
8456 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8457 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8458 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8459 &code
->expr2
->where
);
8463 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8464 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8465 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8466 &code
->expr3
->where
);
8470 /* Given a branch to a label, see if the branch is conforming.
8471 The code node describes where the branch is located. */
8474 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8481 /* Step one: is this a valid branching target? */
8483 if (label
->defined
== ST_LABEL_UNKNOWN
)
8485 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8490 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8492 gfc_error ("Statement at %L is not a valid branch target statement "
8493 "for the branch statement at %L", &label
->where
, &code
->loc
);
8497 /* Step two: make sure this branch is not a branch to itself ;-) */
8499 if (code
->here
== label
)
8501 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8505 /* Step three: See if the label is in the same block as the
8506 branching statement. The hard work has been done by setting up
8507 the bitmap reachable_labels. */
8509 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8511 /* Check now whether there is a CRITICAL construct; if so, check
8512 whether the label is still visible outside of the CRITICAL block,
8513 which is invalid. */
8514 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8516 if (stack
->current
->op
== EXEC_CRITICAL
8517 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8518 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8519 "label at %L", &code
->loc
, &label
->where
);
8520 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8521 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8522 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8523 "for label at %L", &code
->loc
, &label
->where
);
8529 /* Step four: If we haven't found the label in the bitmap, it may
8530 still be the label of the END of the enclosing block, in which
8531 case we find it by going up the code_stack. */
8533 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8535 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8537 if (stack
->current
->op
== EXEC_CRITICAL
)
8539 /* Note: A label at END CRITICAL does not leave the CRITICAL
8540 construct as END CRITICAL is still part of it. */
8541 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8542 " at %L", &code
->loc
, &label
->where
);
8545 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8547 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8548 "label at %L", &code
->loc
, &label
->where
);
8555 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8559 /* The label is not in an enclosing block, so illegal. This was
8560 allowed in Fortran 66, so we allow it as extension. No
8561 further checks are necessary in this case. */
8562 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8563 "as the GOTO statement at %L", &label
->where
,
8569 /* Check whether EXPR1 has the same shape as EXPR2. */
8572 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8574 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8575 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8576 bool result
= false;
8579 /* Compare the rank. */
8580 if (expr1
->rank
!= expr2
->rank
)
8583 /* Compare the size of each dimension. */
8584 for (i
=0; i
<expr1
->rank
; i
++)
8586 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8589 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8592 if (mpz_cmp (shape
[i
], shape2
[i
]))
8596 /* When either of the two expression is an assumed size array, we
8597 ignore the comparison of dimension sizes. */
8602 gfc_clear_shape (shape
, i
);
8603 gfc_clear_shape (shape2
, i
);
8608 /* Check whether a WHERE assignment target or a WHERE mask expression
8609 has the same shape as the outmost WHERE mask expression. */
8612 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8618 cblock
= code
->block
;
8620 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8621 In case of nested WHERE, only the outmost one is stored. */
8622 if (mask
== NULL
) /* outmost WHERE */
8624 else /* inner WHERE */
8631 /* Check if the mask-expr has a consistent shape with the
8632 outmost WHERE mask-expr. */
8633 if (!resolve_where_shape (cblock
->expr1
, e
))
8634 gfc_error ("WHERE mask at %L has inconsistent shape",
8635 &cblock
->expr1
->where
);
8638 /* the assignment statement of a WHERE statement, or the first
8639 statement in where-body-construct of a WHERE construct */
8640 cnext
= cblock
->next
;
8645 /* WHERE assignment statement */
8648 /* Check shape consistent for WHERE assignment target. */
8649 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8650 gfc_error ("WHERE assignment target at %L has "
8651 "inconsistent shape", &cnext
->expr1
->where
);
8655 case EXEC_ASSIGN_CALL
:
8656 resolve_call (cnext
);
8657 if (!cnext
->resolved_sym
->attr
.elemental
)
8658 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8659 &cnext
->ext
.actual
->expr
->where
);
8662 /* WHERE or WHERE construct is part of a where-body-construct */
8664 resolve_where (cnext
, e
);
8668 gfc_error ("Unsupported statement inside WHERE at %L",
8671 /* the next statement within the same where-body-construct */
8672 cnext
= cnext
->next
;
8674 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8675 cblock
= cblock
->block
;
8680 /* Resolve assignment in FORALL construct.
8681 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8682 FORALL index variables. */
8685 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8689 for (n
= 0; n
< nvar
; n
++)
8691 gfc_symbol
*forall_index
;
8693 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8695 /* Check whether the assignment target is one of the FORALL index
8697 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8698 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8699 gfc_error ("Assignment to a FORALL index variable at %L",
8700 &code
->expr1
->where
);
8703 /* If one of the FORALL index variables doesn't appear in the
8704 assignment variable, then there could be a many-to-one
8705 assignment. Emit a warning rather than an error because the
8706 mask could be resolving this problem. */
8707 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8708 gfc_warning ("The FORALL with index '%s' is not used on the "
8709 "left side of the assignment at %L and so might "
8710 "cause multiple assignment to this object",
8711 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8717 /* Resolve WHERE statement in FORALL construct. */
8720 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8721 gfc_expr
**var_expr
)
8726 cblock
= code
->block
;
8729 /* the assignment statement of a WHERE statement, or the first
8730 statement in where-body-construct of a WHERE construct */
8731 cnext
= cblock
->next
;
8736 /* WHERE assignment statement */
8738 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8741 /* WHERE operator assignment statement */
8742 case EXEC_ASSIGN_CALL
:
8743 resolve_call (cnext
);
8744 if (!cnext
->resolved_sym
->attr
.elemental
)
8745 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8746 &cnext
->ext
.actual
->expr
->where
);
8749 /* WHERE or WHERE construct is part of a where-body-construct */
8751 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8755 gfc_error ("Unsupported statement inside WHERE at %L",
8758 /* the next statement within the same where-body-construct */
8759 cnext
= cnext
->next
;
8761 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8762 cblock
= cblock
->block
;
8767 /* Traverse the FORALL body to check whether the following errors exist:
8768 1. For assignment, check if a many-to-one assignment happens.
8769 2. For WHERE statement, check the WHERE body to see if there is any
8770 many-to-one assignment. */
8773 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8777 c
= code
->block
->next
;
8783 case EXEC_POINTER_ASSIGN
:
8784 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8787 case EXEC_ASSIGN_CALL
:
8791 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8792 there is no need to handle it here. */
8796 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8801 /* The next statement in the FORALL body. */
8807 /* Counts the number of iterators needed inside a forall construct, including
8808 nested forall constructs. This is used to allocate the needed memory
8809 in gfc_resolve_forall. */
8812 gfc_count_forall_iterators (gfc_code
*code
)
8814 int max_iters
, sub_iters
, current_iters
;
8815 gfc_forall_iterator
*fa
;
8817 gcc_assert(code
->op
== EXEC_FORALL
);
8821 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8824 code
= code
->block
->next
;
8828 if (code
->op
== EXEC_FORALL
)
8830 sub_iters
= gfc_count_forall_iterators (code
);
8831 if (sub_iters
> max_iters
)
8832 max_iters
= sub_iters
;
8837 return current_iters
+ max_iters
;
8841 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8842 gfc_resolve_forall_body to resolve the FORALL body. */
8845 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8847 static gfc_expr
**var_expr
;
8848 static int total_var
= 0;
8849 static int nvar
= 0;
8851 gfc_forall_iterator
*fa
;
8856 /* Start to resolve a FORALL construct */
8857 if (forall_save
== 0)
8859 /* Count the total number of FORALL index in the nested FORALL
8860 construct in order to allocate the VAR_EXPR with proper size. */
8861 total_var
= gfc_count_forall_iterators (code
);
8863 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8864 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8867 /* The information about FORALL iterator, including FORALL index start, end
8868 and stride. The FORALL index can not appear in start, end or stride. */
8869 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8871 /* Check if any outer FORALL index name is the same as the current
8873 for (i
= 0; i
< nvar
; i
++)
8875 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8877 gfc_error ("An outer FORALL construct already has an index "
8878 "with this name %L", &fa
->var
->where
);
8882 /* Record the current FORALL index. */
8883 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8887 /* No memory leak. */
8888 gcc_assert (nvar
<= total_var
);
8891 /* Resolve the FORALL body. */
8892 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8894 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8895 gfc_resolve_blocks (code
->block
, ns
);
8899 /* Free only the VAR_EXPRs allocated in this frame. */
8900 for (i
= nvar
; i
< tmp
; i
++)
8901 gfc_free_expr (var_expr
[i
]);
8905 /* We are in the outermost FORALL construct. */
8906 gcc_assert (forall_save
== 0);
8908 /* VAR_EXPR is not needed any more. */
8915 /* Resolve a BLOCK construct statement. */
8918 resolve_block_construct (gfc_code
* code
)
8920 /* Resolve the BLOCK's namespace. */
8921 gfc_resolve (code
->ext
.block
.ns
);
8923 /* For an ASSOCIATE block, the associations (and their targets) are already
8924 resolved during resolve_symbol. */
8928 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8931 static void resolve_code (gfc_code
*, gfc_namespace
*);
8934 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8938 for (; b
; b
= b
->block
)
8940 t
= gfc_resolve_expr (b
->expr1
);
8941 if (!gfc_resolve_expr (b
->expr2
))
8947 if (t
&& b
->expr1
!= NULL
8948 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8949 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8956 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8957 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8962 resolve_branch (b
->label1
, b
);
8966 resolve_block_construct (b
);
8970 case EXEC_SELECT_TYPE
:
8974 case EXEC_DO_CONCURRENT
:
8982 case EXEC_OMP_ATOMIC
:
8983 case EXEC_OMP_CRITICAL
:
8985 case EXEC_OMP_MASTER
:
8986 case EXEC_OMP_ORDERED
:
8987 case EXEC_OMP_PARALLEL
:
8988 case EXEC_OMP_PARALLEL_DO
:
8989 case EXEC_OMP_PARALLEL_SECTIONS
:
8990 case EXEC_OMP_PARALLEL_WORKSHARE
:
8991 case EXEC_OMP_SECTIONS
:
8992 case EXEC_OMP_SINGLE
:
8994 case EXEC_OMP_TASKWAIT
:
8995 case EXEC_OMP_TASKYIELD
:
8996 case EXEC_OMP_WORKSHARE
:
9000 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9003 resolve_code (b
->next
, ns
);
9008 /* Does everything to resolve an ordinary assignment. Returns true
9009 if this is an interface assignment. */
9011 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9021 if (gfc_extend_assign (code
, ns
))
9025 if (code
->op
== EXEC_ASSIGN_CALL
)
9027 lhs
= code
->ext
.actual
->expr
;
9028 rhsptr
= &code
->ext
.actual
->next
->expr
;
9032 gfc_actual_arglist
* args
;
9033 gfc_typebound_proc
* tbp
;
9035 gcc_assert (code
->op
== EXEC_COMPCALL
);
9037 args
= code
->expr1
->value
.compcall
.actual
;
9039 rhsptr
= &args
->next
->expr
;
9041 tbp
= code
->expr1
->value
.compcall
.tbp
;
9042 gcc_assert (!tbp
->is_generic
);
9045 /* Make a temporary rhs when there is a default initializer
9046 and rhs is the same symbol as the lhs. */
9047 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9048 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9049 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9050 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9051 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9060 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9061 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9065 /* Handle the case of a BOZ literal on the RHS. */
9066 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9069 if (gfc_option
.warn_surprising
)
9070 gfc_warning ("BOZ literal at %L is bitwise transferred "
9071 "non-integer symbol '%s'", &code
->loc
,
9072 lhs
->symtree
->n
.sym
->name
);
9074 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9076 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9078 if (rc
== ARITH_UNDERFLOW
)
9079 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9080 ". This check can be disabled with the option "
9081 "-fno-range-check", &rhs
->where
);
9082 else if (rc
== ARITH_OVERFLOW
)
9083 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9084 ". This check can be disabled with the option "
9085 "-fno-range-check", &rhs
->where
);
9086 else if (rc
== ARITH_NAN
)
9087 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9088 ". This check can be disabled with the option "
9089 "-fno-range-check", &rhs
->where
);
9094 if (lhs
->ts
.type
== BT_CHARACTER
9095 && gfc_option
.warn_character_truncation
)
9097 if (lhs
->ts
.u
.cl
!= NULL
9098 && lhs
->ts
.u
.cl
->length
!= NULL
9099 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9100 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9102 if (rhs
->expr_type
== EXPR_CONSTANT
)
9103 rlen
= rhs
->value
.character
.length
;
9105 else if (rhs
->ts
.u
.cl
!= NULL
9106 && rhs
->ts
.u
.cl
->length
!= NULL
9107 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9108 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9110 if (rlen
&& llen
&& rlen
> llen
)
9111 gfc_warning_now ("CHARACTER expression will be truncated "
9112 "in assignment (%d/%d) at %L",
9113 llen
, rlen
, &code
->loc
);
9116 /* Ensure that a vector index expression for the lvalue is evaluated
9117 to a temporary if the lvalue symbol is referenced in it. */
9120 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9121 if (ref
->type
== REF_ARRAY
)
9123 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9124 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9125 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9126 ref
->u
.ar
.start
[n
]))
9128 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9132 if (gfc_pure (NULL
))
9134 if (lhs
->ts
.type
== BT_DERIVED
9135 && lhs
->expr_type
== EXPR_VARIABLE
9136 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9137 && rhs
->expr_type
== EXPR_VARIABLE
9138 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9139 || gfc_is_coindexed (rhs
)))
9142 if (gfc_is_coindexed (rhs
))
9143 gfc_error ("Coindexed expression at %L is assigned to "
9144 "a derived type variable with a POINTER "
9145 "component in a PURE procedure",
9148 gfc_error ("The impure variable at %L is assigned to "
9149 "a derived type variable with a POINTER "
9150 "component in a PURE procedure (12.6)",
9155 /* Fortran 2008, C1283. */
9156 if (gfc_is_coindexed (lhs
))
9158 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9159 "procedure", &rhs
->where
);
9164 if (gfc_implicit_pure (NULL
))
9166 if (lhs
->expr_type
== EXPR_VARIABLE
9167 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9168 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9169 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9171 if (lhs
->ts
.type
== BT_DERIVED
9172 && lhs
->expr_type
== EXPR_VARIABLE
9173 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9174 && rhs
->expr_type
== EXPR_VARIABLE
9175 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9176 || gfc_is_coindexed (rhs
)))
9177 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9179 /* Fortran 2008, C1283. */
9180 if (gfc_is_coindexed (lhs
))
9181 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9185 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9186 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9187 if (lhs
->ts
.type
== BT_CLASS
)
9189 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9190 "%L - check that there is a matching specific subroutine "
9191 "for '=' operator", &lhs
->where
);
9195 /* F2008, Section 7.2.1.2. */
9196 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9198 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9199 "component in assignment at %L", &lhs
->where
);
9203 gfc_check_assign (lhs
, rhs
, 1);
9208 /* Add a component reference onto an expression. */
9211 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9216 ref
= &((*ref
)->next
);
9217 *ref
= gfc_get_ref ();
9218 (*ref
)->type
= REF_COMPONENT
;
9219 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9220 (*ref
)->u
.c
.component
= c
;
9223 /* Add a full array ref, as necessary. */
9226 gfc_add_full_array_ref (e
, c
->as
);
9227 e
->rank
= c
->as
->rank
;
9232 /* Build an assignment. Keep the argument 'op' for future use, so that
9233 pointer assignments can be made. */
9236 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9237 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9239 gfc_code
*this_code
;
9241 this_code
= gfc_get_code ();
9243 this_code
->next
= NULL
;
9244 this_code
->expr1
= gfc_copy_expr (expr1
);
9245 this_code
->expr2
= gfc_copy_expr (expr2
);
9246 this_code
->loc
= loc
;
9249 add_comp_ref (this_code
->expr1
, comp1
);
9250 add_comp_ref (this_code
->expr2
, comp2
);
9257 /* Makes a temporary variable expression based on the characteristics of
9258 a given variable expression. */
9261 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9263 static int serial
= 0;
9264 char name
[GFC_MAX_SYMBOL_LEN
];
9267 gfc_array_ref
*aref
;
9270 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9271 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9272 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9278 /* This function could be expanded to support other expression type
9279 but this is not needed here. */
9280 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9282 /* Obtain the arrayspec for the temporary. */
9285 aref
= gfc_find_array_ref (e
);
9286 if (e
->expr_type
== EXPR_VARIABLE
9287 && e
->symtree
->n
.sym
->as
== aref
->as
)
9291 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9292 if (ref
->type
== REF_COMPONENT
9293 && ref
->u
.c
.component
->as
== aref
->as
)
9301 /* Add the attributes and the arrayspec to the temporary. */
9302 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9303 tmp
->n
.sym
->attr
.function
= 0;
9304 tmp
->n
.sym
->attr
.result
= 0;
9305 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9309 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9312 if (as
->type
== AS_DEFERRED
)
9313 tmp
->n
.sym
->attr
.allocatable
= 1;
9316 tmp
->n
.sym
->attr
.dimension
= 0;
9318 gfc_set_sym_referenced (tmp
->n
.sym
);
9319 gfc_commit_symbol (tmp
->n
.sym
);
9320 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9322 /* Should the lhs be a section, use its array ref for the
9323 temporary expression. */
9324 if (aref
&& aref
->type
!= AR_FULL
)
9326 gfc_free_ref_list (e
->ref
);
9327 e
->ref
= gfc_copy_ref (ref
);
9333 /* Add one line of code to the code chain, making sure that 'head' and
9334 'tail' are appropriately updated. */
9337 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9339 gcc_assert (this_code
);
9341 *head
= *tail
= *this_code
;
9343 *tail
= gfc_append_code (*tail
, *this_code
);
9348 /* Counts the potential number of part array references that would
9349 result from resolution of typebound defined assignments. */
9352 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9355 int c_depth
= 0, t_depth
;
9357 for (c
= derived
->components
; c
; c
= c
->next
)
9359 if ((c
->ts
.type
!= BT_DERIVED
9361 || c
->attr
.allocatable
9362 || c
->attr
.proc_pointer_comp
9363 || c
->attr
.class_pointer
9364 || c
->attr
.proc_pointer
)
9365 && !c
->attr
.defined_assign_comp
)
9368 if (c
->as
&& c_depth
== 0)
9371 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9372 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9377 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9379 return depth
+ c_depth
;
9383 /* Implement 7.2.1.3 of the F08 standard:
9384 "An intrinsic assignment where the variable is of derived type is
9385 performed as if each component of the variable were assigned from the
9386 corresponding component of expr using pointer assignment (7.2.2) for
9387 each pointer component, defined assignment for each nonpointer
9388 nonallocatable component of a type that has a type-bound defined
9389 assignment consistent with the component, intrinsic assignment for
9390 each other nonpointer nonallocatable component, ..."
9392 The pointer assignments are taken care of by the intrinsic
9393 assignment of the structure itself. This function recursively adds
9394 defined assignments where required. The recursion is accomplished
9395 by calling resolve_code.
9397 When the lhs in a defined assignment has intent INOUT, we need a
9398 temporary for the lhs. In pseudo-code:
9400 ! Only call function lhs once.
9401 if (lhs is not a constant or an variable)
9404 ! Do the intrinsic assignment
9406 ! Now do the defined assignments
9407 do over components with typebound defined assignment [%cmp]
9408 #if one component's assignment procedure is INOUT
9410 #if expr2 non-variable
9416 t1%cmp {defined=} expr2%cmp
9422 expr1%cmp {defined=} expr2%cmp
9426 /* The temporary assignments have to be put on top of the additional
9427 code to avoid the result being changed by the intrinsic assignment.
9429 static int component_assignment_level
= 0;
9430 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9433 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9435 gfc_component
*comp1
, *comp2
;
9436 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9438 int error_count
, depth
;
9440 gfc_get_errors (NULL
, &error_count
);
9442 /* Filter out continuing processing after an error. */
9444 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9445 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9448 /* TODO: Handle more than one part array reference in assignments. */
9449 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9450 (*code
)->expr1
->rank
? 1 : 0);
9453 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9454 "done because multiple part array references would "
9455 "occur in intermediate expressions.", &(*code
)->loc
);
9459 component_assignment_level
++;
9461 /* Create a temporary so that functions get called only once. */
9462 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9463 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9467 /* Assign the rhs to the temporary. */
9468 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9469 this_code
= build_assignment (EXEC_ASSIGN
,
9470 tmp_expr
, (*code
)->expr2
,
9471 NULL
, NULL
, (*code
)->loc
);
9472 /* Add the code and substitute the rhs expression. */
9473 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9474 gfc_free_expr ((*code
)->expr2
);
9475 (*code
)->expr2
= tmp_expr
;
9478 /* Do the intrinsic assignment. This is not needed if the lhs is one
9479 of the temporaries generated here, since the intrinsic assignment
9480 to the final result already does this. */
9481 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9483 this_code
= build_assignment (EXEC_ASSIGN
,
9484 (*code
)->expr1
, (*code
)->expr2
,
9485 NULL
, NULL
, (*code
)->loc
);
9486 add_code_to_chain (&this_code
, &head
, &tail
);
9489 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9490 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9493 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9497 /* The intrinsic assignment does the right thing for pointers
9498 of all kinds and allocatable components. */
9499 if (comp1
->ts
.type
!= BT_DERIVED
9500 || comp1
->attr
.pointer
9501 || comp1
->attr
.allocatable
9502 || comp1
->attr
.proc_pointer_comp
9503 || comp1
->attr
.class_pointer
9504 || comp1
->attr
.proc_pointer
)
9507 /* Make an assigment for this component. */
9508 this_code
= build_assignment (EXEC_ASSIGN
,
9509 (*code
)->expr1
, (*code
)->expr2
,
9510 comp1
, comp2
, (*code
)->loc
);
9512 /* Convert the assignment if there is a defined assignment for
9513 this type. Otherwise, using the call from resolve_code,
9514 recurse into its components. */
9515 resolve_code (this_code
, ns
);
9517 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9519 gfc_formal_arglist
*dummy_args
;
9521 /* Check that there is a typebound defined assignment. If not,
9522 then this must be a module defined assignment. We cannot
9523 use the defined_assign_comp attribute here because it must
9524 be this derived type that has the defined assignment and not
9526 if (!(comp1
->ts
.u
.derived
->f2k_derived
9527 && comp1
->ts
.u
.derived
->f2k_derived
9528 ->tb_op
[INTRINSIC_ASSIGN
]))
9530 gfc_free_statements (this_code
);
9535 /* If the first argument of the subroutine has intent INOUT
9536 a temporary must be generated and used instead. */
9537 rsym
= this_code
->resolved_sym
;
9538 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9540 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9542 gfc_code
*temp_code
;
9545 /* Build the temporary required for the assignment and put
9546 it at the head of the generated code. */
9549 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9550 temp_code
= build_assignment (EXEC_ASSIGN
,
9552 NULL
, NULL
, (*code
)->loc
);
9553 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9556 /* Replace the first actual arg with the component of the
9558 gfc_free_expr (this_code
->ext
.actual
->expr
);
9559 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9560 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9563 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9565 /* Don't add intrinsic assignments since they are already
9566 effected by the intrinsic assignment of the structure. */
9567 gfc_free_statements (this_code
);
9572 add_code_to_chain (&this_code
, &head
, &tail
);
9576 /* Transfer the value to the final result. */
9577 this_code
= build_assignment (EXEC_ASSIGN
,
9579 comp1
, comp2
, (*code
)->loc
);
9580 add_code_to_chain (&this_code
, &head
, &tail
);
9584 /* This is probably not necessary. */
9587 gfc_free_statements (this_code
);
9591 /* Put the temporary assignments at the top of the generated code. */
9592 if (tmp_head
&& component_assignment_level
== 1)
9594 gfc_append_code (tmp_head
, head
);
9596 tmp_head
= tmp_tail
= NULL
;
9599 /* Now attach the remaining code chain to the input code. Step on
9600 to the end of the new code since resolution is complete. */
9601 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9602 tail
->next
= (*code
)->next
;
9603 /* Overwrite 'code' because this would place the intrinsic assignment
9604 before the temporary for the lhs is created. */
9605 gfc_free_expr ((*code
)->expr1
);
9606 gfc_free_expr ((*code
)->expr2
);
9611 component_assignment_level
--;
9615 /* Given a block of code, recursively resolve everything pointed to by this
9619 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9621 int omp_workshare_save
;
9622 int forall_save
, do_concurrent_save
;
9626 frame
.prev
= cs_base
;
9630 find_reachable_labels (code
);
9632 for (; code
; code
= code
->next
)
9634 frame
.current
= code
;
9635 forall_save
= forall_flag
;
9636 do_concurrent_save
= do_concurrent_flag
;
9638 if (code
->op
== EXEC_FORALL
)
9641 gfc_resolve_forall (code
, ns
, forall_save
);
9644 else if (code
->block
)
9646 omp_workshare_save
= -1;
9649 case EXEC_OMP_PARALLEL_WORKSHARE
:
9650 omp_workshare_save
= omp_workshare_flag
;
9651 omp_workshare_flag
= 1;
9652 gfc_resolve_omp_parallel_blocks (code
, ns
);
9654 case EXEC_OMP_PARALLEL
:
9655 case EXEC_OMP_PARALLEL_DO
:
9656 case EXEC_OMP_PARALLEL_SECTIONS
:
9658 omp_workshare_save
= omp_workshare_flag
;
9659 omp_workshare_flag
= 0;
9660 gfc_resolve_omp_parallel_blocks (code
, ns
);
9663 gfc_resolve_omp_do_blocks (code
, ns
);
9665 case EXEC_SELECT_TYPE
:
9666 /* Blocks are handled in resolve_select_type because we have
9667 to transform the SELECT TYPE into ASSOCIATE first. */
9669 case EXEC_DO_CONCURRENT
:
9670 do_concurrent_flag
= 1;
9671 gfc_resolve_blocks (code
->block
, ns
);
9672 do_concurrent_flag
= 2;
9674 case EXEC_OMP_WORKSHARE
:
9675 omp_workshare_save
= omp_workshare_flag
;
9676 omp_workshare_flag
= 1;
9679 gfc_resolve_blocks (code
->block
, ns
);
9683 if (omp_workshare_save
!= -1)
9684 omp_workshare_flag
= omp_workshare_save
;
9688 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9689 t
= gfc_resolve_expr (code
->expr1
);
9690 forall_flag
= forall_save
;
9691 do_concurrent_flag
= do_concurrent_save
;
9693 if (!gfc_resolve_expr (code
->expr2
))
9696 if (code
->op
== EXEC_ALLOCATE
9697 && !gfc_resolve_expr (code
->expr3
))
9703 case EXEC_END_BLOCK
:
9704 case EXEC_END_NESTED_BLOCK
:
9708 case EXEC_ERROR_STOP
:
9712 case EXEC_ASSIGN_CALL
:
9717 case EXEC_SYNC_IMAGES
:
9718 case EXEC_SYNC_MEMORY
:
9719 resolve_sync (code
);
9724 resolve_lock_unlock (code
);
9728 /* Keep track of which entry we are up to. */
9729 current_entry_id
= code
->ext
.entry
->id
;
9733 resolve_where (code
, NULL
);
9737 if (code
->expr1
!= NULL
)
9739 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9740 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9741 "INTEGER variable", &code
->expr1
->where
);
9742 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9743 gfc_error ("Variable '%s' has not been assigned a target "
9744 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9745 &code
->expr1
->where
);
9748 resolve_branch (code
->label1
, code
);
9752 if (code
->expr1
!= NULL
9753 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9754 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9755 "INTEGER return specifier", &code
->expr1
->where
);
9758 case EXEC_INIT_ASSIGN
:
9759 case EXEC_END_PROCEDURE
:
9766 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9770 if (resolve_ordinary_assign (code
, ns
))
9772 if (code
->op
== EXEC_COMPCALL
)
9778 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9779 if (code
->expr1
->ts
.type
== BT_DERIVED
9780 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9781 generate_component_assignments (&code
, ns
);
9785 case EXEC_LABEL_ASSIGN
:
9786 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9787 gfc_error ("Label %d referenced at %L is never defined",
9788 code
->label1
->value
, &code
->label1
->where
);
9790 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9791 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9792 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9793 != gfc_default_integer_kind
9794 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9795 gfc_error ("ASSIGN statement at %L requires a scalar "
9796 "default INTEGER variable", &code
->expr1
->where
);
9799 case EXEC_POINTER_ASSIGN
:
9806 /* This is both a variable definition and pointer assignment
9807 context, so check both of them. For rank remapping, a final
9808 array ref may be present on the LHS and fool gfc_expr_attr
9809 used in gfc_check_vardef_context. Remove it. */
9810 e
= remove_last_array_ref (code
->expr1
);
9811 t
= gfc_check_vardef_context (e
, true, false, false,
9812 _("pointer assignment"));
9814 t
= gfc_check_vardef_context (e
, false, false, false,
9815 _("pointer assignment"));
9820 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9824 case EXEC_ARITHMETIC_IF
:
9826 && code
->expr1
->ts
.type
!= BT_INTEGER
9827 && code
->expr1
->ts
.type
!= BT_REAL
)
9828 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9829 "expression", &code
->expr1
->where
);
9831 resolve_branch (code
->label1
, code
);
9832 resolve_branch (code
->label2
, code
);
9833 resolve_branch (code
->label3
, code
);
9837 if (t
&& code
->expr1
!= NULL
9838 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9839 || code
->expr1
->rank
!= 0))
9840 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9841 &code
->expr1
->where
);
9846 resolve_call (code
);
9851 resolve_typebound_subroutine (code
);
9855 resolve_ppc_call (code
);
9859 /* Select is complicated. Also, a SELECT construct could be
9860 a transformed computed GOTO. */
9861 resolve_select (code
, false);
9864 case EXEC_SELECT_TYPE
:
9865 resolve_select_type (code
, ns
);
9869 resolve_block_construct (code
);
9873 if (code
->ext
.iterator
!= NULL
)
9875 gfc_iterator
*iter
= code
->ext
.iterator
;
9876 if (gfc_resolve_iterator (iter
, true, false))
9877 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9882 if (code
->expr1
== NULL
)
9883 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9885 && (code
->expr1
->rank
!= 0
9886 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9887 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9888 "a scalar LOGICAL expression", &code
->expr1
->where
);
9893 resolve_allocate_deallocate (code
, "ALLOCATE");
9897 case EXEC_DEALLOCATE
:
9899 resolve_allocate_deallocate (code
, "DEALLOCATE");
9904 if (!gfc_resolve_open (code
->ext
.open
))
9907 resolve_branch (code
->ext
.open
->err
, code
);
9911 if (!gfc_resolve_close (code
->ext
.close
))
9914 resolve_branch (code
->ext
.close
->err
, code
);
9917 case EXEC_BACKSPACE
:
9921 if (!gfc_resolve_filepos (code
->ext
.filepos
))
9924 resolve_branch (code
->ext
.filepos
->err
, code
);
9928 if (!gfc_resolve_inquire (code
->ext
.inquire
))
9931 resolve_branch (code
->ext
.inquire
->err
, code
);
9935 gcc_assert (code
->ext
.inquire
!= NULL
);
9936 if (!gfc_resolve_inquire (code
->ext
.inquire
))
9939 resolve_branch (code
->ext
.inquire
->err
, code
);
9943 if (!gfc_resolve_wait (code
->ext
.wait
))
9946 resolve_branch (code
->ext
.wait
->err
, code
);
9947 resolve_branch (code
->ext
.wait
->end
, code
);
9948 resolve_branch (code
->ext
.wait
->eor
, code
);
9953 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
9956 resolve_branch (code
->ext
.dt
->err
, code
);
9957 resolve_branch (code
->ext
.dt
->end
, code
);
9958 resolve_branch (code
->ext
.dt
->eor
, code
);
9962 resolve_transfer (code
);
9965 case EXEC_DO_CONCURRENT
:
9967 resolve_forall_iterators (code
->ext
.forall_iterator
);
9969 if (code
->expr1
!= NULL
9970 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9971 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9972 "expression", &code
->expr1
->where
);
9975 case EXEC_OMP_ATOMIC
:
9976 case EXEC_OMP_BARRIER
:
9977 case EXEC_OMP_CRITICAL
:
9978 case EXEC_OMP_FLUSH
:
9980 case EXEC_OMP_MASTER
:
9981 case EXEC_OMP_ORDERED
:
9982 case EXEC_OMP_SECTIONS
:
9983 case EXEC_OMP_SINGLE
:
9984 case EXEC_OMP_TASKWAIT
:
9985 case EXEC_OMP_TASKYIELD
:
9986 case EXEC_OMP_WORKSHARE
:
9987 gfc_resolve_omp_directive (code
, ns
);
9990 case EXEC_OMP_PARALLEL
:
9991 case EXEC_OMP_PARALLEL_DO
:
9992 case EXEC_OMP_PARALLEL_SECTIONS
:
9993 case EXEC_OMP_PARALLEL_WORKSHARE
:
9995 omp_workshare_save
= omp_workshare_flag
;
9996 omp_workshare_flag
= 0;
9997 gfc_resolve_omp_directive (code
, ns
);
9998 omp_workshare_flag
= omp_workshare_save
;
10002 gfc_internal_error ("resolve_code(): Bad statement code");
10006 cs_base
= frame
.prev
;
10010 /* Resolve initial values and make sure they are compatible with
10014 resolve_values (gfc_symbol
*sym
)
10018 if (sym
->value
== NULL
)
10021 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10022 t
= resolve_structure_cons (sym
->value
, 1);
10024 t
= gfc_resolve_expr (sym
->value
);
10029 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10033 /* Verify any BIND(C) derived types in the namespace so we can report errors
10034 for them once, rather than for each variable declared of that type. */
10037 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10039 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10040 && derived_sym
->attr
.is_bind_c
== 1)
10041 verify_bind_c_derived_type (derived_sym
);
10047 /* Verify that any binding labels used in a given namespace do not collide
10048 with the names or binding labels of any global symbols. Multiple INTERFACE
10049 for the same procedure are permitted. */
10052 gfc_verify_binding_labels (gfc_symbol
*sym
)
10055 const char *module
;
10057 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10058 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10061 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10064 module
= sym
->module
;
10065 else if (sym
->ns
&& sym
->ns
->proc_name
10066 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10067 module
= sym
->ns
->proc_name
->name
;
10068 else if (sym
->ns
&& sym
->ns
->parent
10069 && sym
->ns
&& sym
->ns
->parent
->proc_name
10070 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10071 module
= sym
->ns
->parent
->proc_name
->name
;
10077 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10080 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10081 gsym
->where
= sym
->declared_at
;
10082 gsym
->sym_name
= sym
->name
;
10083 gsym
->binding_label
= sym
->binding_label
;
10084 gsym
->binding_label
= sym
->binding_label
;
10085 gsym
->ns
= sym
->ns
;
10086 gsym
->mod_name
= module
;
10087 if (sym
->attr
.function
)
10088 gsym
->type
= GSYM_FUNCTION
;
10089 else if (sym
->attr
.subroutine
)
10090 gsym
->type
= GSYM_SUBROUTINE
;
10091 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10092 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10096 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10098 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10099 "identifier as entity at %L", sym
->name
,
10100 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10101 /* Clear the binding label to prevent checking multiple times. */
10102 sym
->binding_label
= NULL
;
10105 else if (sym
->attr
.flavor
== FL_VARIABLE
10106 && (strcmp (module
, gsym
->mod_name
) != 0
10107 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10109 /* This can only happen if the variable is defined in a module - if it
10110 isn't the same module, reject it. */
10111 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10112 "the same global identifier as entity at %L from module %s",
10113 sym
->name
, module
, sym
->binding_label
,
10114 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10115 sym
->binding_label
= NULL
;
10117 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10118 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10119 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10120 && sym
!= gsym
->ns
->proc_name
10121 && (strcmp (gsym
->sym_name
, sym
->name
) != 0
10122 || module
!= gsym
->mod_name
10123 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10125 /* Print an error if the procdure is defined multiple times; we have to
10126 exclude references to the same procedure via module association or
10127 multiple checks for the same procedure. */
10128 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10129 "global identifier as entity at %L", sym
->name
,
10130 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10131 sym
->binding_label
= NULL
;
10136 /* Resolve an index expression. */
10139 resolve_index_expr (gfc_expr
*e
)
10141 if (!gfc_resolve_expr (e
))
10144 if (!gfc_simplify_expr (e
, 0))
10147 if (!gfc_specification_expr (e
))
10154 /* Resolve a charlen structure. */
10157 resolve_charlen (gfc_charlen
*cl
)
10160 bool saved_specification_expr
;
10166 saved_specification_expr
= specification_expr
;
10167 specification_expr
= true;
10169 if (cl
->length_from_typespec
)
10171 if (!gfc_resolve_expr (cl
->length
))
10173 specification_expr
= saved_specification_expr
;
10177 if (!gfc_simplify_expr (cl
->length
, 0))
10179 specification_expr
= saved_specification_expr
;
10186 if (!resolve_index_expr (cl
->length
))
10188 specification_expr
= saved_specification_expr
;
10193 /* "If the character length parameter value evaluates to a negative
10194 value, the length of character entities declared is zero." */
10195 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10197 if (gfc_option
.warn_surprising
)
10198 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10199 " the length has been set to zero",
10200 &cl
->length
->where
, i
);
10201 gfc_replace_expr (cl
->length
,
10202 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10205 /* Check that the character length is not too large. */
10206 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10207 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10208 && cl
->length
->ts
.type
== BT_INTEGER
10209 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10211 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10212 specification_expr
= saved_specification_expr
;
10216 specification_expr
= saved_specification_expr
;
10221 /* Test for non-constant shape arrays. */
10224 is_non_constant_shape_array (gfc_symbol
*sym
)
10230 not_constant
= false;
10231 if (sym
->as
!= NULL
)
10233 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10234 has not been simplified; parameter array references. Do the
10235 simplification now. */
10236 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10238 e
= sym
->as
->lower
[i
];
10239 if (e
&& (!resolve_index_expr(e
)
10240 || !gfc_is_constant_expr (e
)))
10241 not_constant
= true;
10242 e
= sym
->as
->upper
[i
];
10243 if (e
&& (!resolve_index_expr(e
)
10244 || !gfc_is_constant_expr (e
)))
10245 not_constant
= true;
10248 return not_constant
;
10251 /* Given a symbol and an initialization expression, add code to initialize
10252 the symbol to the function entry. */
10254 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10258 gfc_namespace
*ns
= sym
->ns
;
10260 /* Search for the function namespace if this is a contained
10261 function without an explicit result. */
10262 if (sym
->attr
.function
&& sym
== sym
->result
10263 && sym
->name
!= sym
->ns
->proc_name
->name
)
10265 ns
= ns
->contained
;
10266 for (;ns
; ns
= ns
->sibling
)
10267 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10273 gfc_free_expr (init
);
10277 /* Build an l-value expression for the result. */
10278 lval
= gfc_lval_expr_from_sym (sym
);
10280 /* Add the code at scope entry. */
10281 init_st
= gfc_get_code ();
10282 init_st
->next
= ns
->code
;
10283 ns
->code
= init_st
;
10285 /* Assign the default initializer to the l-value. */
10286 init_st
->loc
= sym
->declared_at
;
10287 init_st
->op
= EXEC_INIT_ASSIGN
;
10288 init_st
->expr1
= lval
;
10289 init_st
->expr2
= init
;
10292 /* Assign the default initializer to a derived type variable or result. */
10295 apply_default_init (gfc_symbol
*sym
)
10297 gfc_expr
*init
= NULL
;
10299 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10302 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10303 init
= gfc_default_initializer (&sym
->ts
);
10305 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10308 build_init_assign (sym
, init
);
10309 sym
->attr
.referenced
= 1;
10312 /* Build an initializer for a local integer, real, complex, logical, or
10313 character variable, based on the command line flags finit-local-zero,
10314 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10315 null if the symbol should not have a default initialization. */
10317 build_default_init_expr (gfc_symbol
*sym
)
10320 gfc_expr
*init_expr
;
10323 /* These symbols should never have a default initialization. */
10324 if (sym
->attr
.allocatable
10325 || sym
->attr
.external
10327 || sym
->attr
.pointer
10328 || sym
->attr
.in_equivalence
10329 || sym
->attr
.in_common
10332 || sym
->attr
.cray_pointee
10333 || sym
->attr
.cray_pointer
10337 /* Now we'll try to build an initializer expression. */
10338 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10339 &sym
->declared_at
);
10341 /* We will only initialize integers, reals, complex, logicals, and
10342 characters, and only if the corresponding command-line flags
10343 were set. Otherwise, we free init_expr and return null. */
10344 switch (sym
->ts
.type
)
10347 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10348 mpz_set_si (init_expr
->value
.integer
,
10349 gfc_option
.flag_init_integer_value
);
10352 gfc_free_expr (init_expr
);
10358 switch (gfc_option
.flag_init_real
)
10360 case GFC_INIT_REAL_SNAN
:
10361 init_expr
->is_snan
= 1;
10362 /* Fall through. */
10363 case GFC_INIT_REAL_NAN
:
10364 mpfr_set_nan (init_expr
->value
.real
);
10367 case GFC_INIT_REAL_INF
:
10368 mpfr_set_inf (init_expr
->value
.real
, 1);
10371 case GFC_INIT_REAL_NEG_INF
:
10372 mpfr_set_inf (init_expr
->value
.real
, -1);
10375 case GFC_INIT_REAL_ZERO
:
10376 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10380 gfc_free_expr (init_expr
);
10387 switch (gfc_option
.flag_init_real
)
10389 case GFC_INIT_REAL_SNAN
:
10390 init_expr
->is_snan
= 1;
10391 /* Fall through. */
10392 case GFC_INIT_REAL_NAN
:
10393 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10394 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10397 case GFC_INIT_REAL_INF
:
10398 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10399 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10402 case GFC_INIT_REAL_NEG_INF
:
10403 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10404 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10407 case GFC_INIT_REAL_ZERO
:
10408 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10412 gfc_free_expr (init_expr
);
10419 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10420 init_expr
->value
.logical
= 0;
10421 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10422 init_expr
->value
.logical
= 1;
10425 gfc_free_expr (init_expr
);
10431 /* For characters, the length must be constant in order to
10432 create a default initializer. */
10433 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10434 && sym
->ts
.u
.cl
->length
10435 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10437 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10438 init_expr
->value
.character
.length
= char_len
;
10439 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10440 for (i
= 0; i
< char_len
; i
++)
10441 init_expr
->value
.character
.string
[i
]
10442 = (unsigned char) gfc_option
.flag_init_character_value
;
10446 gfc_free_expr (init_expr
);
10449 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10450 && sym
->ts
.u
.cl
->length
)
10452 gfc_actual_arglist
*arg
;
10453 init_expr
= gfc_get_expr ();
10454 init_expr
->where
= sym
->declared_at
;
10455 init_expr
->ts
= sym
->ts
;
10456 init_expr
->expr_type
= EXPR_FUNCTION
;
10457 init_expr
->value
.function
.isym
=
10458 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10459 init_expr
->value
.function
.name
= "repeat";
10460 arg
= gfc_get_actual_arglist ();
10461 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10463 arg
->expr
->value
.character
.string
[0]
10464 = gfc_option
.flag_init_character_value
;
10465 arg
->next
= gfc_get_actual_arglist ();
10466 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10467 init_expr
->value
.function
.actual
= arg
;
10472 gfc_free_expr (init_expr
);
10478 /* Add an initialization expression to a local variable. */
10480 apply_default_init_local (gfc_symbol
*sym
)
10482 gfc_expr
*init
= NULL
;
10484 /* The symbol should be a variable or a function return value. */
10485 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10486 || (sym
->attr
.function
&& sym
->result
!= sym
))
10489 /* Try to build the initializer expression. If we can't initialize
10490 this symbol, then init will be NULL. */
10491 init
= build_default_init_expr (sym
);
10495 /* For saved variables, we don't want to add an initializer at function
10496 entry, so we just add a static initializer. Note that automatic variables
10497 are stack allocated even with -fno-automatic; we have also to exclude
10498 result variable, which are also nonstatic. */
10499 if (sym
->attr
.save
|| sym
->ns
->save_all
10500 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10501 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10503 /* Don't clobber an existing initializer! */
10504 gcc_assert (sym
->value
== NULL
);
10509 build_init_assign (sym
, init
);
10513 /* Resolution of common features of flavors variable and procedure. */
10516 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10518 gfc_array_spec
*as
;
10520 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10521 as
= CLASS_DATA (sym
)->as
;
10525 /* Constraints on deferred shape variable. */
10526 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10528 bool pointer
, allocatable
, dimension
;
10530 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10532 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10533 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10534 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10538 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10539 allocatable
= sym
->attr
.allocatable
;
10540 dimension
= sym
->attr
.dimension
;
10545 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10547 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10548 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10551 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10552 "'%s' at %L may not be ALLOCATABLE",
10553 sym
->name
, &sym
->declared_at
))
10557 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10559 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10560 "assumed rank", sym
->name
, &sym
->declared_at
);
10566 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10567 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10569 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10570 sym
->name
, &sym
->declared_at
);
10575 /* Constraints on polymorphic variables. */
10576 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10579 if (sym
->attr
.class_ok
10580 && !sym
->attr
.select_type_temporary
10581 && !UNLIMITED_POLY (sym
)
10582 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10584 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10585 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10586 &sym
->declared_at
);
10591 /* Assume that use associated symbols were checked in the module ns.
10592 Class-variables that are associate-names are also something special
10593 and excepted from the test. */
10594 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10596 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10597 "or pointer", sym
->name
, &sym
->declared_at
);
10606 /* Additional checks for symbols with flavor variable and derived
10607 type. To be called from resolve_fl_variable. */
10610 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10612 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10614 /* Check to see if a derived type is blocked from being host
10615 associated by the presence of another class I symbol in the same
10616 namespace. 14.6.1.3 of the standard and the discussion on
10617 comp.lang.fortran. */
10618 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10619 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10622 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10623 if (s
&& s
->attr
.generic
)
10624 s
= gfc_find_dt_in_generic (s
);
10625 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10627 gfc_error ("The type '%s' cannot be host associated at %L "
10628 "because it is blocked by an incompatible object "
10629 "of the same name declared at %L",
10630 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10636 /* 4th constraint in section 11.3: "If an object of a type for which
10637 component-initialization is specified (R429) appears in the
10638 specification-part of a module and does not have the ALLOCATABLE
10639 or POINTER attribute, the object shall have the SAVE attribute."
10641 The check for initializers is performed with
10642 gfc_has_default_initializer because gfc_default_initializer generates
10643 a hidden default for allocatable components. */
10644 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10645 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10646 && !sym
->ns
->save_all
&& !sym
->attr
.save
10647 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10648 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10649 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10650 "'%s' at %L, needed due to the default "
10651 "initialization", sym
->name
, &sym
->declared_at
))
10654 /* Assign default initializer. */
10655 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10656 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10658 sym
->value
= gfc_default_initializer (&sym
->ts
);
10665 /* Resolve symbols with flavor variable. */
10668 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10670 int no_init_flag
, automatic_flag
;
10672 const char *auto_save_msg
;
10673 bool saved_specification_expr
;
10675 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10678 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10681 /* Set this flag to check that variables are parameters of all entries.
10682 This check is effected by the call to gfc_resolve_expr through
10683 is_non_constant_shape_array. */
10684 saved_specification_expr
= specification_expr
;
10685 specification_expr
= true;
10687 if (sym
->ns
->proc_name
10688 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10689 || sym
->ns
->proc_name
->attr
.is_main_program
)
10690 && !sym
->attr
.use_assoc
10691 && !sym
->attr
.allocatable
10692 && !sym
->attr
.pointer
10693 && is_non_constant_shape_array (sym
))
10695 /* The shape of a main program or module array needs to be
10697 gfc_error ("The module or main program array '%s' at %L must "
10698 "have constant shape", sym
->name
, &sym
->declared_at
);
10699 specification_expr
= saved_specification_expr
;
10703 /* Constraints on deferred type parameter. */
10704 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10706 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10707 "requires either the pointer or allocatable attribute",
10708 sym
->name
, &sym
->declared_at
);
10709 specification_expr
= saved_specification_expr
;
10713 if (sym
->ts
.type
== BT_CHARACTER
)
10715 /* Make sure that character string variables with assumed length are
10716 dummy arguments. */
10717 e
= sym
->ts
.u
.cl
->length
;
10718 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10719 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10721 gfc_error ("Entity with assumed character length at %L must be a "
10722 "dummy argument or a PARAMETER", &sym
->declared_at
);
10723 specification_expr
= saved_specification_expr
;
10727 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10729 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10730 specification_expr
= saved_specification_expr
;
10734 if (!gfc_is_constant_expr (e
)
10735 && !(e
->expr_type
== EXPR_VARIABLE
10736 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10738 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10739 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10740 || sym
->ns
->proc_name
->attr
.is_main_program
))
10742 gfc_error ("'%s' at %L must have constant character length "
10743 "in this context", sym
->name
, &sym
->declared_at
);
10744 specification_expr
= saved_specification_expr
;
10747 if (sym
->attr
.in_common
)
10749 gfc_error ("COMMON variable '%s' at %L must have constant "
10750 "character length", sym
->name
, &sym
->declared_at
);
10751 specification_expr
= saved_specification_expr
;
10757 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10758 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10760 /* Determine if the symbol may not have an initializer. */
10761 no_init_flag
= automatic_flag
= 0;
10762 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10763 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10765 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10766 && is_non_constant_shape_array (sym
))
10768 no_init_flag
= automatic_flag
= 1;
10770 /* Also, they must not have the SAVE attribute.
10771 SAVE_IMPLICIT is checked below. */
10772 if (sym
->as
&& sym
->attr
.codimension
)
10774 int corank
= sym
->as
->corank
;
10775 sym
->as
->corank
= 0;
10776 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10777 sym
->as
->corank
= corank
;
10779 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10781 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10782 specification_expr
= saved_specification_expr
;
10787 /* Ensure that any initializer is simplified. */
10789 gfc_simplify_expr (sym
->value
, 1);
10791 /* Reject illegal initializers. */
10792 if (!sym
->mark
&& sym
->value
)
10794 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10795 && CLASS_DATA (sym
)->attr
.allocatable
))
10796 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10797 sym
->name
, &sym
->declared_at
);
10798 else if (sym
->attr
.external
)
10799 gfc_error ("External '%s' at %L cannot have an initializer",
10800 sym
->name
, &sym
->declared_at
);
10801 else if (sym
->attr
.dummy
10802 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10803 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10804 sym
->name
, &sym
->declared_at
);
10805 else if (sym
->attr
.intrinsic
)
10806 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10807 sym
->name
, &sym
->declared_at
);
10808 else if (sym
->attr
.result
)
10809 gfc_error ("Function result '%s' at %L cannot have an initializer",
10810 sym
->name
, &sym
->declared_at
);
10811 else if (automatic_flag
)
10812 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10813 sym
->name
, &sym
->declared_at
);
10815 goto no_init_error
;
10816 specification_expr
= saved_specification_expr
;
10821 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10823 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10824 specification_expr
= saved_specification_expr
;
10828 specification_expr
= saved_specification_expr
;
10833 /* Resolve a procedure. */
10836 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10838 gfc_formal_arglist
*arg
;
10840 if (sym
->attr
.function
10841 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10844 if (sym
->ts
.type
== BT_CHARACTER
)
10846 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10848 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10849 && !resolve_charlen (cl
))
10852 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10853 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10855 gfc_error ("Character-valued statement function '%s' at %L must "
10856 "have constant length", sym
->name
, &sym
->declared_at
);
10861 /* Ensure that derived type for are not of a private type. Internal
10862 module procedures are excluded by 2.2.3.3 - i.e., they are not
10863 externally accessible and can access all the objects accessible in
10865 if (!(sym
->ns
->parent
10866 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10867 && gfc_check_symbol_access (sym
))
10869 gfc_interface
*iface
;
10871 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10874 && arg
->sym
->ts
.type
== BT_DERIVED
10875 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10876 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10877 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10878 "and cannot be a dummy argument"
10879 " of '%s', which is PUBLIC at %L",
10880 arg
->sym
->name
, sym
->name
,
10881 &sym
->declared_at
))
10883 /* Stop this message from recurring. */
10884 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10889 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10890 PRIVATE to the containing module. */
10891 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10893 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10896 && arg
->sym
->ts
.type
== BT_DERIVED
10897 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10898 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10899 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10900 "PUBLIC interface '%s' at %L "
10901 "takes dummy arguments of '%s' which "
10902 "is PRIVATE", iface
->sym
->name
,
10903 sym
->name
, &iface
->sym
->declared_at
,
10904 gfc_typename(&arg
->sym
->ts
)))
10906 /* Stop this message from recurring. */
10907 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10913 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10914 PRIVATE to the containing module. */
10915 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10917 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10920 && arg
->sym
->ts
.type
== BT_DERIVED
10921 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10922 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10923 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10924 "PUBLIC interface '%s' at %L takes "
10925 "dummy arguments of '%s' which is "
10926 "PRIVATE", iface
->sym
->name
,
10927 sym
->name
, &iface
->sym
->declared_at
,
10928 gfc_typename(&arg
->sym
->ts
)))
10930 /* Stop this message from recurring. */
10931 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10938 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10939 && !sym
->attr
.proc_pointer
)
10941 gfc_error ("Function '%s' at %L cannot have an initializer",
10942 sym
->name
, &sym
->declared_at
);
10946 /* An external symbol may not have an initializer because it is taken to be
10947 a procedure. Exception: Procedure Pointers. */
10948 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10950 gfc_error ("External object '%s' at %L may not have an initializer",
10951 sym
->name
, &sym
->declared_at
);
10955 /* An elemental function is required to return a scalar 12.7.1 */
10956 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10958 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10959 "result", sym
->name
, &sym
->declared_at
);
10960 /* Reset so that the error only occurs once. */
10961 sym
->attr
.elemental
= 0;
10965 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10966 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10968 gfc_error ("Statement function '%s' at %L may not have pointer or "
10969 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10973 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10974 char-len-param shall not be array-valued, pointer-valued, recursive
10975 or pure. ....snip... A character value of * may only be used in the
10976 following ways: (i) Dummy arg of procedure - dummy associates with
10977 actual length; (ii) To declare a named constant; or (iii) External
10978 function - but length must be declared in calling scoping unit. */
10979 if (sym
->attr
.function
10980 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
10981 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10983 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10984 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10986 if (sym
->as
&& sym
->as
->rank
)
10987 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10988 "array-valued", sym
->name
, &sym
->declared_at
);
10990 if (sym
->attr
.pointer
)
10991 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10992 "pointer-valued", sym
->name
, &sym
->declared_at
);
10994 if (sym
->attr
.pure
)
10995 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10996 "pure", sym
->name
, &sym
->declared_at
);
10998 if (sym
->attr
.recursive
)
10999 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11000 "recursive", sym
->name
, &sym
->declared_at
);
11005 /* Appendix B.2 of the standard. Contained functions give an
11006 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11007 character length is an F2003 feature. */
11008 if (!sym
->attr
.contained
11009 && gfc_current_form
!= FORM_FIXED
11010 && !sym
->ts
.deferred
)
11011 gfc_notify_std (GFC_STD_F95_OBS
,
11012 "CHARACTER(*) function '%s' at %L",
11013 sym
->name
, &sym
->declared_at
);
11016 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11018 gfc_formal_arglist
*curr_arg
;
11019 int has_non_interop_arg
= 0;
11021 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11022 sym
->common_block
))
11024 /* Clear these to prevent looking at them again if there was an
11026 sym
->attr
.is_bind_c
= 0;
11027 sym
->attr
.is_c_interop
= 0;
11028 sym
->ts
.is_c_interop
= 0;
11032 /* So far, no errors have been found. */
11033 sym
->attr
.is_c_interop
= 1;
11034 sym
->ts
.is_c_interop
= 1;
11037 curr_arg
= gfc_sym_get_dummy_args (sym
);
11038 while (curr_arg
!= NULL
)
11040 /* Skip implicitly typed dummy args here. */
11041 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11042 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11043 /* If something is found to fail, record the fact so we
11044 can mark the symbol for the procedure as not being
11045 BIND(C) to try and prevent multiple errors being
11047 has_non_interop_arg
= 1;
11049 curr_arg
= curr_arg
->next
;
11052 /* See if any of the arguments were not interoperable and if so, clear
11053 the procedure symbol to prevent duplicate error messages. */
11054 if (has_non_interop_arg
!= 0)
11056 sym
->attr
.is_c_interop
= 0;
11057 sym
->ts
.is_c_interop
= 0;
11058 sym
->attr
.is_bind_c
= 0;
11062 if (!sym
->attr
.proc_pointer
)
11064 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11066 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11067 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11070 if (sym
->attr
.intent
)
11072 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11073 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11076 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11078 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11079 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11082 if (sym
->attr
.external
&& sym
->attr
.function
11083 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11084 || sym
->attr
.contained
))
11086 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11087 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11090 if (strcmp ("ppr@", sym
->name
) == 0)
11092 gfc_error ("Procedure pointer result '%s' at %L "
11093 "is missing the pointer attribute",
11094 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11103 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11104 been defined and we now know their defined arguments, check that they fulfill
11105 the requirements of the standard for procedures used as finalizers. */
11108 gfc_resolve_finalizers (gfc_symbol
* derived
)
11110 gfc_finalizer
* list
;
11111 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11112 bool result
= true;
11113 bool seen_scalar
= false;
11115 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11118 /* Walk over the list of finalizer-procedures, check them, and if any one
11119 does not fit in with the standard's definition, print an error and remove
11120 it from the list. */
11121 prev_link
= &derived
->f2k_derived
->finalizers
;
11122 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11124 gfc_formal_arglist
*dummy_args
;
11129 /* Skip this finalizer if we already resolved it. */
11130 if (list
->proc_tree
)
11132 prev_link
= &(list
->next
);
11136 /* Check this exists and is a SUBROUTINE. */
11137 if (!list
->proc_sym
->attr
.subroutine
)
11139 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11140 list
->proc_sym
->name
, &list
->where
);
11144 /* We should have exactly one argument. */
11145 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11146 if (!dummy_args
|| dummy_args
->next
)
11148 gfc_error ("FINAL procedure at %L must have exactly one argument",
11152 arg
= dummy_args
->sym
;
11154 /* This argument must be of our type. */
11155 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11157 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11158 &arg
->declared_at
, derived
->name
);
11162 /* It must neither be a pointer nor allocatable nor optional. */
11163 if (arg
->attr
.pointer
)
11165 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11166 &arg
->declared_at
);
11169 if (arg
->attr
.allocatable
)
11171 gfc_error ("Argument of FINAL procedure at %L must not be"
11172 " ALLOCATABLE", &arg
->declared_at
);
11175 if (arg
->attr
.optional
)
11177 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11178 &arg
->declared_at
);
11182 /* It must not be INTENT(OUT). */
11183 if (arg
->attr
.intent
== INTENT_OUT
)
11185 gfc_error ("Argument of FINAL procedure at %L must not be"
11186 " INTENT(OUT)", &arg
->declared_at
);
11190 /* Warn if the procedure is non-scalar and not assumed shape. */
11191 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11192 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11193 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11194 " shape argument", &arg
->declared_at
);
11196 /* Check that it does not match in kind and rank with a FINAL procedure
11197 defined earlier. To really loop over the *earlier* declarations,
11198 we need to walk the tail of the list as new ones were pushed at the
11200 /* TODO: Handle kind parameters once they are implemented. */
11201 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11202 for (i
= list
->next
; i
; i
= i
->next
)
11204 gfc_formal_arglist
*dummy_args
;
11206 /* Argument list might be empty; that is an error signalled earlier,
11207 but we nevertheless continued resolving. */
11208 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11211 gfc_symbol
* i_arg
= dummy_args
->sym
;
11212 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11213 if (i_rank
== my_rank
)
11215 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11216 " rank (%d) as '%s'",
11217 list
->proc_sym
->name
, &list
->where
, my_rank
,
11218 i
->proc_sym
->name
);
11224 /* Is this the/a scalar finalizer procedure? */
11225 if (!arg
->as
|| arg
->as
->rank
== 0)
11226 seen_scalar
= true;
11228 /* Find the symtree for this procedure. */
11229 gcc_assert (!list
->proc_tree
);
11230 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11232 prev_link
= &list
->next
;
11235 /* Remove wrong nodes immediately from the list so we don't risk any
11236 troubles in the future when they might fail later expectations. */
11240 *prev_link
= list
->next
;
11241 gfc_free_finalizer (i
);
11244 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11245 were nodes in the list, must have been for arrays. It is surely a good
11246 idea to have a scalar version there if there's something to finalize. */
11247 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11248 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11249 " defined at %L, suggest also scalar one",
11250 derived
->name
, &derived
->declared_at
);
11252 gfc_find_derived_vtab (derived
);
11257 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11260 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11261 const char* generic_name
, locus where
)
11263 gfc_symbol
*sym1
, *sym2
;
11264 const char *pass1
, *pass2
;
11266 gcc_assert (t1
->specific
&& t2
->specific
);
11267 gcc_assert (!t1
->specific
->is_generic
);
11268 gcc_assert (!t2
->specific
->is_generic
);
11269 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11271 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11272 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11277 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11278 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11279 || sym1
->attr
.function
!= sym2
->attr
.function
)
11281 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11282 " GENERIC '%s' at %L",
11283 sym1
->name
, sym2
->name
, generic_name
, &where
);
11287 /* Compare the interfaces. */
11288 if (t1
->specific
->nopass
)
11290 else if (t1
->specific
->pass_arg
)
11291 pass1
= t1
->specific
->pass_arg
;
11293 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11294 if (t2
->specific
->nopass
)
11296 else if (t2
->specific
->pass_arg
)
11297 pass2
= t2
->specific
->pass_arg
;
11299 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11300 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11301 NULL
, 0, pass1
, pass2
))
11303 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11304 sym1
->name
, sym2
->name
, generic_name
, &where
);
11312 /* Worker function for resolving a generic procedure binding; this is used to
11313 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11315 The difference between those cases is finding possible inherited bindings
11316 that are overridden, as one has to look for them in tb_sym_root,
11317 tb_uop_root or tb_op, respectively. Thus the caller must already find
11318 the super-type and set p->overridden correctly. */
11321 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11322 gfc_typebound_proc
* p
, const char* name
)
11324 gfc_tbp_generic
* target
;
11325 gfc_symtree
* first_target
;
11326 gfc_symtree
* inherited
;
11328 gcc_assert (p
&& p
->is_generic
);
11330 /* Try to find the specific bindings for the symtrees in our target-list. */
11331 gcc_assert (p
->u
.generic
);
11332 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11333 if (!target
->specific
)
11335 gfc_typebound_proc
* overridden_tbp
;
11336 gfc_tbp_generic
* g
;
11337 const char* target_name
;
11339 target_name
= target
->specific_st
->name
;
11341 /* Defined for this type directly. */
11342 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11344 target
->specific
= target
->specific_st
->n
.tb
;
11345 goto specific_found
;
11348 /* Look for an inherited specific binding. */
11351 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11356 gcc_assert (inherited
->n
.tb
);
11357 target
->specific
= inherited
->n
.tb
;
11358 goto specific_found
;
11362 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11363 " at %L", target_name
, name
, &p
->where
);
11366 /* Once we've found the specific binding, check it is not ambiguous with
11367 other specifics already found or inherited for the same GENERIC. */
11369 gcc_assert (target
->specific
);
11371 /* This must really be a specific binding! */
11372 if (target
->specific
->is_generic
)
11374 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11375 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11379 /* Check those already resolved on this type directly. */
11380 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11381 if (g
!= target
&& g
->specific
11382 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11385 /* Check for ambiguity with inherited specific targets. */
11386 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11387 overridden_tbp
= overridden_tbp
->overridden
)
11388 if (overridden_tbp
->is_generic
)
11390 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11392 gcc_assert (g
->specific
);
11393 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11399 /* If we attempt to "overwrite" a specific binding, this is an error. */
11400 if (p
->overridden
&& !p
->overridden
->is_generic
)
11402 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11403 " the same name", name
, &p
->where
);
11407 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11408 all must have the same attributes here. */
11409 first_target
= p
->u
.generic
->specific
->u
.specific
;
11410 gcc_assert (first_target
);
11411 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11412 p
->function
= first_target
->n
.sym
->attr
.function
;
11418 /* Resolve a GENERIC procedure binding for a derived type. */
11421 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11423 gfc_symbol
* super_type
;
11425 /* Find the overridden binding if any. */
11426 st
->n
.tb
->overridden
= NULL
;
11427 super_type
= gfc_get_derived_super_type (derived
);
11430 gfc_symtree
* overridden
;
11431 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11434 if (overridden
&& overridden
->n
.tb
)
11435 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11438 /* Resolve using worker function. */
11439 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11443 /* Retrieve the target-procedure of an operator binding and do some checks in
11444 common for intrinsic and user-defined type-bound operators. */
11447 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11449 gfc_symbol
* target_proc
;
11451 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11452 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11453 gcc_assert (target_proc
);
11455 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11456 if (target
->specific
->nopass
)
11458 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11462 return target_proc
;
11466 /* Resolve a type-bound intrinsic operator. */
11469 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11470 gfc_typebound_proc
* p
)
11472 gfc_symbol
* super_type
;
11473 gfc_tbp_generic
* target
;
11475 /* If there's already an error here, do nothing (but don't fail again). */
11479 /* Operators should always be GENERIC bindings. */
11480 gcc_assert (p
->is_generic
);
11482 /* Look for an overridden binding. */
11483 super_type
= gfc_get_derived_super_type (derived
);
11484 if (super_type
&& super_type
->f2k_derived
)
11485 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11488 p
->overridden
= NULL
;
11490 /* Resolve general GENERIC properties using worker function. */
11491 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11494 /* Check the targets to be procedures of correct interface. */
11495 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11497 gfc_symbol
* target_proc
;
11499 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11503 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11506 /* Add target to non-typebound operator list. */
11507 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11508 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11510 gfc_interface
*head
, *intr
;
11511 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11513 head
= derived
->ns
->op
[op
];
11514 intr
= gfc_get_interface ();
11515 intr
->sym
= target_proc
;
11516 intr
->where
= p
->where
;
11518 derived
->ns
->op
[op
] = intr
;
11530 /* Resolve a type-bound user operator (tree-walker callback). */
11532 static gfc_symbol
* resolve_bindings_derived
;
11533 static bool resolve_bindings_result
;
11535 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11538 resolve_typebound_user_op (gfc_symtree
* stree
)
11540 gfc_symbol
* super_type
;
11541 gfc_tbp_generic
* target
;
11543 gcc_assert (stree
&& stree
->n
.tb
);
11545 if (stree
->n
.tb
->error
)
11548 /* Operators should always be GENERIC bindings. */
11549 gcc_assert (stree
->n
.tb
->is_generic
);
11551 /* Find overridden procedure, if any. */
11552 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11553 if (super_type
&& super_type
->f2k_derived
)
11555 gfc_symtree
* overridden
;
11556 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11557 stree
->name
, true, NULL
);
11559 if (overridden
&& overridden
->n
.tb
)
11560 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11563 stree
->n
.tb
->overridden
= NULL
;
11565 /* Resolve basically using worker function. */
11566 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11569 /* Check the targets to be functions of correct interface. */
11570 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11572 gfc_symbol
* target_proc
;
11574 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11578 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11585 resolve_bindings_result
= false;
11586 stree
->n
.tb
->error
= 1;
11590 /* Resolve the type-bound procedures for a derived type. */
11593 resolve_typebound_procedure (gfc_symtree
* stree
)
11597 gfc_symbol
* me_arg
;
11598 gfc_symbol
* super_type
;
11599 gfc_component
* comp
;
11601 gcc_assert (stree
);
11603 /* Undefined specific symbol from GENERIC target definition. */
11607 if (stree
->n
.tb
->error
)
11610 /* If this is a GENERIC binding, use that routine. */
11611 if (stree
->n
.tb
->is_generic
)
11613 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11618 /* Get the target-procedure to check it. */
11619 gcc_assert (!stree
->n
.tb
->is_generic
);
11620 gcc_assert (stree
->n
.tb
->u
.specific
);
11621 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11622 where
= stree
->n
.tb
->where
;
11624 /* Default access should already be resolved from the parser. */
11625 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11627 if (stree
->n
.tb
->deferred
)
11629 if (!check_proc_interface (proc
, &where
))
11634 /* Check for F08:C465. */
11635 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11636 || (proc
->attr
.proc
!= PROC_MODULE
11637 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11638 || proc
->attr
.abstract
)
11640 gfc_error ("'%s' must be a module procedure or an external procedure with"
11641 " an explicit interface at %L", proc
->name
, &where
);
11646 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11647 stree
->n
.tb
->function
= proc
->attr
.function
;
11649 /* Find the super-type of the current derived type. We could do this once and
11650 store in a global if speed is needed, but as long as not I believe this is
11651 more readable and clearer. */
11652 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11654 /* If PASS, resolve and check arguments if not already resolved / loaded
11655 from a .mod file. */
11656 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11658 gfc_formal_arglist
*dummy_args
;
11660 dummy_args
= gfc_sym_get_dummy_args (proc
);
11661 if (stree
->n
.tb
->pass_arg
)
11663 gfc_formal_arglist
*i
;
11665 /* If an explicit passing argument name is given, walk the arg-list
11666 and look for it. */
11669 stree
->n
.tb
->pass_arg_num
= 1;
11670 for (i
= dummy_args
; i
; i
= i
->next
)
11672 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11677 ++stree
->n
.tb
->pass_arg_num
;
11682 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11684 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11685 stree
->n
.tb
->pass_arg
);
11691 /* Otherwise, take the first one; there should in fact be at least
11693 stree
->n
.tb
->pass_arg_num
= 1;
11696 gfc_error ("Procedure '%s' with PASS at %L must have at"
11697 " least one argument", proc
->name
, &where
);
11700 me_arg
= dummy_args
->sym
;
11703 /* Now check that the argument-type matches and the passed-object
11704 dummy argument is generally fine. */
11706 gcc_assert (me_arg
);
11708 if (me_arg
->ts
.type
!= BT_CLASS
)
11710 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11711 " at %L", proc
->name
, &where
);
11715 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11716 != resolve_bindings_derived
)
11718 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11719 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11720 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11724 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11725 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11727 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11728 " scalar", proc
->name
, &where
);
11731 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11733 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11734 " be ALLOCATABLE", proc
->name
, &where
);
11737 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11739 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11740 " be POINTER", proc
->name
, &where
);
11745 /* If we are extending some type, check that we don't override a procedure
11746 flagged NON_OVERRIDABLE. */
11747 stree
->n
.tb
->overridden
= NULL
;
11750 gfc_symtree
* overridden
;
11751 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11752 stree
->name
, true, NULL
);
11756 if (overridden
->n
.tb
)
11757 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11759 if (!gfc_check_typebound_override (stree
, overridden
))
11764 /* See if there's a name collision with a component directly in this type. */
11765 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11766 if (!strcmp (comp
->name
, stree
->name
))
11768 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11770 stree
->name
, &where
, resolve_bindings_derived
->name
);
11774 /* Try to find a name collision with an inherited component. */
11775 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11777 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11778 " component of '%s'",
11779 stree
->name
, &where
, resolve_bindings_derived
->name
);
11783 stree
->n
.tb
->error
= 0;
11787 resolve_bindings_result
= false;
11788 stree
->n
.tb
->error
= 1;
11793 resolve_typebound_procedures (gfc_symbol
* derived
)
11796 gfc_symbol
* super_type
;
11798 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11801 super_type
= gfc_get_derived_super_type (derived
);
11803 resolve_symbol (super_type
);
11805 resolve_bindings_derived
= derived
;
11806 resolve_bindings_result
= true;
11808 /* Make sure the vtab has been generated. */
11809 gfc_find_derived_vtab (derived
);
11811 if (derived
->f2k_derived
->tb_sym_root
)
11812 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11813 &resolve_typebound_procedure
);
11815 if (derived
->f2k_derived
->tb_uop_root
)
11816 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11817 &resolve_typebound_user_op
);
11819 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11821 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11822 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11823 (gfc_intrinsic_op
)op
, p
))
11824 resolve_bindings_result
= false;
11827 return resolve_bindings_result
;
11831 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11832 to give all identical derived types the same backend_decl. */
11834 add_dt_to_dt_list (gfc_symbol
*derived
)
11836 gfc_dt_list
*dt_list
;
11838 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11839 if (derived
== dt_list
->derived
)
11842 dt_list
= gfc_get_dt_list ();
11843 dt_list
->next
= gfc_derived_types
;
11844 dt_list
->derived
= derived
;
11845 gfc_derived_types
= dt_list
;
11849 /* Ensure that a derived-type is really not abstract, meaning that every
11850 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11853 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11858 if (!ensure_not_abstract_walker (sub
, st
->left
))
11860 if (!ensure_not_abstract_walker (sub
, st
->right
))
11863 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11865 gfc_symtree
* overriding
;
11866 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11869 gcc_assert (overriding
->n
.tb
);
11870 if (overriding
->n
.tb
->deferred
)
11872 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11873 " '%s' is DEFERRED and not overridden",
11874 sub
->name
, &sub
->declared_at
, st
->name
);
11883 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11885 /* The algorithm used here is to recursively travel up the ancestry of sub
11886 and for each ancestor-type, check all bindings. If any of them is
11887 DEFERRED, look it up starting from sub and see if the found (overriding)
11888 binding is not DEFERRED.
11889 This is not the most efficient way to do this, but it should be ok and is
11890 clearer than something sophisticated. */
11892 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11894 if (!ancestor
->attr
.abstract
)
11897 /* Walk bindings of this ancestor. */
11898 if (ancestor
->f2k_derived
)
11901 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11906 /* Find next ancestor type and recurse on it. */
11907 ancestor
= gfc_get_derived_super_type (ancestor
);
11909 return ensure_not_abstract (sub
, ancestor
);
11915 /* This check for typebound defined assignments is done recursively
11916 since the order in which derived types are resolved is not always in
11917 order of the declarations. */
11920 check_defined_assignments (gfc_symbol
*derived
)
11924 for (c
= derived
->components
; c
; c
= c
->next
)
11926 if (c
->ts
.type
!= BT_DERIVED
11928 || c
->attr
.allocatable
11929 || c
->attr
.proc_pointer_comp
11930 || c
->attr
.class_pointer
11931 || c
->attr
.proc_pointer
)
11934 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
11935 || (c
->ts
.u
.derived
->f2k_derived
11936 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
11938 derived
->attr
.defined_assign_comp
= 1;
11942 check_defined_assignments (c
->ts
.u
.derived
);
11943 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11945 derived
->attr
.defined_assign_comp
= 1;
11952 /* Resolve the components of a derived type. This does not have to wait until
11953 resolution stage, but can be done as soon as the dt declaration has been
11957 resolve_fl_derived0 (gfc_symbol
*sym
)
11959 gfc_symbol
* super_type
;
11962 if (sym
->attr
.unlimited_polymorphic
)
11965 super_type
= gfc_get_derived_super_type (sym
);
11968 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11970 gfc_error ("As extending type '%s' at %L has a coarray component, "
11971 "parent type '%s' shall also have one", sym
->name
,
11972 &sym
->declared_at
, super_type
->name
);
11976 /* Ensure the extended type gets resolved before we do. */
11977 if (super_type
&& !resolve_fl_derived0 (super_type
))
11980 /* An ABSTRACT type must be extensible. */
11981 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11983 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11984 sym
->name
, &sym
->declared_at
);
11988 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11991 for ( ; c
!= NULL
; c
= c
->next
)
11993 if (c
->attr
.artificial
)
11996 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11997 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
11999 gfc_error ("Deferred-length character component '%s' at %L is not "
12000 "yet supported", c
->name
, &c
->loc
);
12005 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12006 && c
->attr
.codimension
12007 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12009 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12010 "deferred shape", c
->name
, &c
->loc
);
12015 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12016 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12018 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12019 "shall not be a coarray", c
->name
, &c
->loc
);
12024 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12025 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12026 || c
->attr
.allocatable
))
12028 gfc_error ("Component '%s' at %L with coarray component "
12029 "shall be a nonpointer, nonallocatable scalar",
12035 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12037 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12038 "is not an array pointer", c
->name
, &c
->loc
);
12042 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12044 gfc_symbol
*ifc
= c
->ts
.interface
;
12046 if (!sym
->attr
.vtype
12047 && !check_proc_interface (ifc
, &c
->loc
))
12050 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12052 /* Resolve interface and copy attributes. */
12053 if (ifc
->formal
&& !ifc
->formal_ns
)
12054 resolve_symbol (ifc
);
12055 if (ifc
->attr
.intrinsic
)
12056 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12060 c
->ts
= ifc
->result
->ts
;
12061 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12062 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12063 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12064 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12065 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12070 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12071 c
->attr
.pointer
= ifc
->attr
.pointer
;
12072 c
->attr
.dimension
= ifc
->attr
.dimension
;
12073 c
->as
= gfc_copy_array_spec (ifc
->as
);
12074 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12076 c
->ts
.interface
= ifc
;
12077 c
->attr
.function
= ifc
->attr
.function
;
12078 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12080 c
->attr
.pure
= ifc
->attr
.pure
;
12081 c
->attr
.elemental
= ifc
->attr
.elemental
;
12082 c
->attr
.recursive
= ifc
->attr
.recursive
;
12083 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12084 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12085 /* Copy char length. */
12086 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12088 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12089 if (cl
->length
&& !cl
->resolved
12090 && !gfc_resolve_expr (cl
->length
))
12096 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12098 /* Since PPCs are not implicitly typed, a PPC without an explicit
12099 interface must be a subroutine. */
12100 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12103 /* Procedure pointer components: Check PASS arg. */
12104 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12105 && !sym
->attr
.vtype
)
12107 gfc_symbol
* me_arg
;
12109 if (c
->tb
->pass_arg
)
12111 gfc_formal_arglist
* i
;
12113 /* If an explicit passing argument name is given, walk the arg-list
12114 and look for it. */
12117 c
->tb
->pass_arg_num
= 1;
12118 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12120 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12125 c
->tb
->pass_arg_num
++;
12130 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12131 "at %L has no argument '%s'", c
->name
,
12132 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12139 /* Otherwise, take the first one; there should in fact be at least
12141 c
->tb
->pass_arg_num
= 1;
12142 if (!c
->ts
.interface
->formal
)
12144 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12145 "must have at least one argument",
12150 me_arg
= c
->ts
.interface
->formal
->sym
;
12153 /* Now check that the argument-type matches. */
12154 gcc_assert (me_arg
);
12155 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12156 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12157 || (me_arg
->ts
.type
== BT_CLASS
12158 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12160 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12161 " the derived type '%s'", me_arg
->name
, c
->name
,
12162 me_arg
->name
, &c
->loc
, sym
->name
);
12167 /* Check for C453. */
12168 if (me_arg
->attr
.dimension
)
12170 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12171 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12177 if (me_arg
->attr
.pointer
)
12179 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12180 "may not have the POINTER attribute", me_arg
->name
,
12181 c
->name
, me_arg
->name
, &c
->loc
);
12186 if (me_arg
->attr
.allocatable
)
12188 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12189 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12190 me_arg
->name
, &c
->loc
);
12195 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12196 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12197 " at %L", c
->name
, &c
->loc
);
12201 /* Check type-spec if this is not the parent-type component. */
12202 if (((sym
->attr
.is_class
12203 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12204 || c
!= sym
->components
->ts
.u
.derived
->components
))
12205 || (!sym
->attr
.is_class
12206 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12207 && !sym
->attr
.vtype
12208 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12211 /* If this type is an extension, set the accessibility of the parent
12214 && ((sym
->attr
.is_class
12215 && c
== sym
->components
->ts
.u
.derived
->components
)
12216 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12217 && strcmp (super_type
->name
, c
->name
) == 0)
12218 c
->attr
.access
= super_type
->attr
.access
;
12220 /* If this type is an extension, see if this component has the same name
12221 as an inherited type-bound procedure. */
12222 if (super_type
&& !sym
->attr
.is_class
12223 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12225 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12226 " inherited type-bound procedure",
12227 c
->name
, sym
->name
, &c
->loc
);
12231 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12232 && !c
->ts
.deferred
)
12234 if (c
->ts
.u
.cl
->length
== NULL
12235 || (!resolve_charlen(c
->ts
.u
.cl
))
12236 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12238 gfc_error ("Character length of component '%s' needs to "
12239 "be a constant specification expression at %L",
12241 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12246 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12247 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12249 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12250 "length must be a POINTER or ALLOCATABLE",
12251 c
->name
, sym
->name
, &c
->loc
);
12255 if (c
->ts
.type
== BT_DERIVED
12256 && sym
->component_access
!= ACCESS_PRIVATE
12257 && gfc_check_symbol_access (sym
)
12258 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12259 && !c
->ts
.u
.derived
->attr
.use_assoc
12260 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12261 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12262 "PRIVATE type and cannot be a component of "
12263 "'%s', which is PUBLIC at %L", c
->name
,
12264 sym
->name
, &sym
->declared_at
))
12267 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12269 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12270 "type %s", c
->name
, &c
->loc
, sym
->name
);
12274 if (sym
->attr
.sequence
)
12276 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12278 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12279 "not have the SEQUENCE attribute",
12280 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12285 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12286 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12287 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12288 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12289 CLASS_DATA (c
)->ts
.u
.derived
12290 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12292 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12293 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12294 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12296 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12297 "that has not been declared", c
->name
, sym
->name
,
12302 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12303 && CLASS_DATA (c
)->attr
.class_pointer
12304 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12305 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12306 && !UNLIMITED_POLY (c
))
12308 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12309 "that has not been declared", c
->name
, sym
->name
,
12315 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12316 && (!c
->attr
.class_ok
12317 || !(CLASS_DATA (c
)->attr
.class_pointer
12318 || CLASS_DATA (c
)->attr
.allocatable
)))
12320 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12321 "or pointer", c
->name
, &c
->loc
);
12322 /* Prevent a recurrence of the error. */
12323 c
->ts
.type
= BT_UNKNOWN
;
12327 /* Ensure that all the derived type components are put on the
12328 derived type list; even in formal namespaces, where derived type
12329 pointer components might not have been declared. */
12330 if (c
->ts
.type
== BT_DERIVED
12332 && c
->ts
.u
.derived
->components
12334 && sym
!= c
->ts
.u
.derived
)
12335 add_dt_to_dt_list (c
->ts
.u
.derived
);
12337 if (!gfc_resolve_array_spec (c
->as
,
12338 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12339 || c
->attr
.allocatable
)))
12342 if (c
->initializer
&& !sym
->attr
.vtype
12343 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12347 check_defined_assignments (sym
);
12349 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12350 sym
->attr
.defined_assign_comp
12351 = super_type
->attr
.defined_assign_comp
;
12353 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12354 all DEFERRED bindings are overridden. */
12355 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12356 && !sym
->attr
.is_class
12357 && !ensure_not_abstract (sym
, super_type
))
12360 /* Add derived type to the derived type list. */
12361 add_dt_to_dt_list (sym
);
12363 /* Check if the type is finalizable. This is done in order to ensure that the
12364 finalization wrapper is generated early enough. */
12365 gfc_is_finalizable (sym
, NULL
);
12371 /* The following procedure does the full resolution of a derived type,
12372 including resolution of all type-bound procedures (if present). In contrast
12373 to 'resolve_fl_derived0' this can only be done after the module has been
12374 parsed completely. */
12377 resolve_fl_derived (gfc_symbol
*sym
)
12379 gfc_symbol
*gen_dt
= NULL
;
12381 if (sym
->attr
.unlimited_polymorphic
)
12384 if (!sym
->attr
.is_class
)
12385 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12386 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12387 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12388 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12389 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12390 "'%s' at %L being the same name as derived "
12391 "type at %L", sym
->name
,
12392 gen_dt
->generic
->sym
== sym
12393 ? gen_dt
->generic
->next
->sym
->name
12394 : gen_dt
->generic
->sym
->name
,
12395 gen_dt
->generic
->sym
== sym
12396 ? &gen_dt
->generic
->next
->sym
->declared_at
12397 : &gen_dt
->generic
->sym
->declared_at
,
12398 &sym
->declared_at
))
12401 /* Resolve the finalizer procedures. */
12402 if (!gfc_resolve_finalizers (sym
))
12405 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12407 /* Fix up incomplete CLASS symbols. */
12408 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12409 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12411 /* Nothing more to do for unlimited polymorphic entities. */
12412 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12414 else if (vptr
->ts
.u
.derived
== NULL
)
12416 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12418 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12422 if (!resolve_fl_derived0 (sym
))
12425 /* Resolve the type-bound procedures. */
12426 if (!resolve_typebound_procedures (sym
))
12434 resolve_fl_namelist (gfc_symbol
*sym
)
12439 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12441 /* Check again, the check in match only works if NAMELIST comes
12443 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12445 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12446 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12450 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12451 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12452 "with assumed shape in namelist '%s' at %L",
12453 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12456 if (is_non_constant_shape_array (nl
->sym
)
12457 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12458 "with nonconstant shape in namelist '%s' at %L",
12459 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12462 if (nl
->sym
->ts
.type
== BT_CHARACTER
12463 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12464 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12465 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12466 "nonconstant character length in "
12467 "namelist '%s' at %L", nl
->sym
->name
,
12468 sym
->name
, &sym
->declared_at
))
12471 /* FIXME: Once UDDTIO is implemented, the following can be
12473 if (nl
->sym
->ts
.type
== BT_CLASS
)
12475 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12476 "polymorphic and requires a defined input/output "
12477 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12481 if (nl
->sym
->ts
.type
== BT_DERIVED
12482 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12483 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12485 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12486 "namelist '%s' at %L with ALLOCATABLE "
12487 "or POINTER components", nl
->sym
->name
,
12488 sym
->name
, &sym
->declared_at
))
12491 /* FIXME: Once UDDTIO is implemented, the following can be
12493 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12494 "ALLOCATABLE or POINTER components and thus requires "
12495 "a defined input/output procedure", nl
->sym
->name
,
12496 sym
->name
, &sym
->declared_at
);
12501 /* Reject PRIVATE objects in a PUBLIC namelist. */
12502 if (gfc_check_symbol_access (sym
))
12504 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12506 if (!nl
->sym
->attr
.use_assoc
12507 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12508 && !gfc_check_symbol_access (nl
->sym
))
12510 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12511 "cannot be member of PUBLIC namelist '%s' at %L",
12512 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12516 /* Types with private components that came here by USE-association. */
12517 if (nl
->sym
->ts
.type
== BT_DERIVED
12518 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12520 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12521 "components and cannot be member of namelist '%s' at %L",
12522 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12526 /* Types with private components that are defined in the same module. */
12527 if (nl
->sym
->ts
.type
== BT_DERIVED
12528 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12529 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12531 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12532 "cannot be a member of PUBLIC namelist '%s' at %L",
12533 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12540 /* 14.1.2 A module or internal procedure represent local entities
12541 of the same type as a namelist member and so are not allowed. */
12542 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12544 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12547 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12548 if ((nl
->sym
== sym
->ns
->proc_name
)
12550 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12555 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12556 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12558 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12559 "attribute in '%s' at %L", nlsym
->name
,
12560 &sym
->declared_at
);
12570 resolve_fl_parameter (gfc_symbol
*sym
)
12572 /* A parameter array's shape needs to be constant. */
12573 if (sym
->as
!= NULL
12574 && (sym
->as
->type
== AS_DEFERRED
12575 || is_non_constant_shape_array (sym
)))
12577 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12578 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12582 /* Make sure a parameter that has been implicitly typed still
12583 matches the implicit type, since PARAMETER statements can precede
12584 IMPLICIT statements. */
12585 if (sym
->attr
.implicit_type
12586 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12589 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12590 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12594 /* Make sure the types of derived parameters are consistent. This
12595 type checking is deferred until resolution because the type may
12596 refer to a derived type from the host. */
12597 if (sym
->ts
.type
== BT_DERIVED
12598 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12600 gfc_error ("Incompatible derived type in PARAMETER at %L",
12601 &sym
->value
->where
);
12608 /* Do anything necessary to resolve a symbol. Right now, we just
12609 assume that an otherwise unknown symbol is a variable. This sort
12610 of thing commonly happens for symbols in module. */
12613 resolve_symbol (gfc_symbol
*sym
)
12615 int check_constant
, mp_flag
;
12616 gfc_symtree
*symtree
;
12617 gfc_symtree
*this_symtree
;
12620 symbol_attribute class_attr
;
12621 gfc_array_spec
*as
;
12622 bool saved_specification_expr
;
12628 if (sym
->attr
.artificial
)
12631 if (sym
->attr
.unlimited_polymorphic
)
12634 if (sym
->attr
.flavor
== FL_UNKNOWN
12635 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12636 && !sym
->attr
.generic
&& !sym
->attr
.external
12637 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12640 /* If we find that a flavorless symbol is an interface in one of the
12641 parent namespaces, find its symtree in this namespace, free the
12642 symbol and set the symtree to point to the interface symbol. */
12643 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12645 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12646 if (symtree
&& (symtree
->n
.sym
->generic
||
12647 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12648 && sym
->ns
->construct_entities
)))
12650 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12652 gfc_release_symbol (sym
);
12653 symtree
->n
.sym
->refs
++;
12654 this_symtree
->n
.sym
= symtree
->n
.sym
;
12659 /* Otherwise give it a flavor according to such attributes as
12661 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12662 && sym
->attr
.intrinsic
== 0)
12663 sym
->attr
.flavor
= FL_VARIABLE
;
12664 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12666 sym
->attr
.flavor
= FL_PROCEDURE
;
12667 if (sym
->attr
.dimension
)
12668 sym
->attr
.function
= 1;
12672 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12673 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12675 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12676 && !resolve_procedure_interface (sym
))
12679 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12680 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12682 if (sym
->attr
.external
)
12683 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12684 "at %L", &sym
->declared_at
);
12686 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12687 "at %L", &sym
->declared_at
);
12692 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12695 /* Symbols that are module procedures with results (functions) have
12696 the types and array specification copied for type checking in
12697 procedures that call them, as well as for saving to a module
12698 file. These symbols can't stand the scrutiny that their results
12700 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12702 /* Make sure that the intrinsic is consistent with its internal
12703 representation. This needs to be done before assigning a default
12704 type to avoid spurious warnings. */
12705 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12706 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12709 /* Resolve associate names. */
12711 resolve_assoc_var (sym
, true);
12713 /* Assign default type to symbols that need one and don't have one. */
12714 if (sym
->ts
.type
== BT_UNKNOWN
)
12716 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12718 gfc_set_default_type (sym
, 1, NULL
);
12721 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12722 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12723 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12724 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12726 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12728 /* The specific case of an external procedure should emit an error
12729 in the case that there is no implicit type. */
12731 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12734 /* Result may be in another namespace. */
12735 resolve_symbol (sym
->result
);
12737 if (!sym
->result
->attr
.proc_pointer
)
12739 sym
->ts
= sym
->result
->ts
;
12740 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12741 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12742 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12743 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12744 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12749 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12751 bool saved_specification_expr
= specification_expr
;
12752 specification_expr
= true;
12753 gfc_resolve_array_spec (sym
->result
->as
, false);
12754 specification_expr
= saved_specification_expr
;
12757 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12759 as
= CLASS_DATA (sym
)->as
;
12760 class_attr
= CLASS_DATA (sym
)->attr
;
12761 class_attr
.pointer
= class_attr
.class_pointer
;
12765 class_attr
= sym
->attr
;
12770 if (sym
->attr
.contiguous
12771 && (!class_attr
.dimension
12772 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12773 && !class_attr
.pointer
)))
12775 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12776 "array pointer or an assumed-shape or assumed-rank array",
12777 sym
->name
, &sym
->declared_at
);
12781 /* Assumed size arrays and assumed shape arrays must be dummy
12782 arguments. Array-spec's of implied-shape should have been resolved to
12783 AS_EXPLICIT already. */
12787 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12788 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12789 || as
->type
== AS_ASSUMED_SHAPE
)
12790 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12792 if (as
->type
== AS_ASSUMED_SIZE
)
12793 gfc_error ("Assumed size array at %L must be a dummy argument",
12794 &sym
->declared_at
);
12796 gfc_error ("Assumed shape array at %L must be a dummy argument",
12797 &sym
->declared_at
);
12800 /* TS 29113, C535a. */
12801 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12802 && !sym
->attr
.select_type_temporary
)
12804 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12805 &sym
->declared_at
);
12808 if (as
->type
== AS_ASSUMED_RANK
12809 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12811 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12812 "CODIMENSION attribute", &sym
->declared_at
);
12817 /* Make sure symbols with known intent or optional are really dummy
12818 variable. Because of ENTRY statement, this has to be deferred
12819 until resolution time. */
12821 if (!sym
->attr
.dummy
12822 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12824 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12828 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12830 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12831 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12835 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12837 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12838 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12840 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12841 "attribute must have constant length",
12842 sym
->name
, &sym
->declared_at
);
12846 if (sym
->ts
.is_c_interop
12847 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12849 gfc_error ("C interoperable character dummy variable '%s' at %L "
12850 "with VALUE attribute must have length one",
12851 sym
->name
, &sym
->declared_at
);
12856 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12857 && sym
->ts
.u
.derived
->attr
.generic
)
12859 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12860 if (!sym
->ts
.u
.derived
)
12862 gfc_error ("The derived type '%s' at %L is of type '%s', "
12863 "which has not been defined", sym
->name
,
12864 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12865 sym
->ts
.type
= BT_UNKNOWN
;
12870 /* Use the same constraints as TYPE(*), except for the type check
12871 and that only scalars and assumed-size arrays are permitted. */
12872 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
12874 if (!sym
->attr
.dummy
)
12876 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12877 "a dummy argument", sym
->name
, &sym
->declared_at
);
12881 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
12882 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
12883 && sym
->ts
.type
!= BT_COMPLEX
)
12885 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12886 "of type TYPE(*) or of an numeric intrinsic type",
12887 sym
->name
, &sym
->declared_at
);
12891 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12892 || sym
->attr
.pointer
|| sym
->attr
.value
)
12894 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12895 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
12896 "attribute", sym
->name
, &sym
->declared_at
);
12900 if (sym
->attr
.intent
== INTENT_OUT
)
12902 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12903 "have the INTENT(OUT) attribute",
12904 sym
->name
, &sym
->declared_at
);
12907 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
12909 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
12910 "either be a scalar or an assumed-size array",
12911 sym
->name
, &sym
->declared_at
);
12915 /* Set the type to TYPE(*) and add a dimension(*) to ensure
12916 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
12918 sym
->ts
.type
= BT_ASSUMED
;
12919 sym
->as
= gfc_get_array_spec ();
12920 sym
->as
->type
= AS_ASSUMED_SIZE
;
12922 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
12924 else if (sym
->ts
.type
== BT_ASSUMED
)
12926 /* TS 29113, C407a. */
12927 if (!sym
->attr
.dummy
)
12929 gfc_error ("Assumed type of variable %s at %L is only permitted "
12930 "for dummy variables", sym
->name
, &sym
->declared_at
);
12933 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12934 || sym
->attr
.pointer
|| sym
->attr
.value
)
12936 gfc_error ("Assumed-type variable %s at %L may not have the "
12937 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12938 sym
->name
, &sym
->declared_at
);
12941 if (sym
->attr
.intent
== INTENT_OUT
)
12943 gfc_error ("Assumed-type variable %s at %L may not have the "
12944 "INTENT(OUT) attribute",
12945 sym
->name
, &sym
->declared_at
);
12948 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12950 gfc_error ("Assumed-type variable %s at %L shall not be an "
12951 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12956 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12957 do this for something that was implicitly typed because that is handled
12958 in gfc_set_default_type. Handle dummy arguments and procedure
12959 definitions separately. Also, anything that is use associated is not
12960 handled here but instead is handled in the module it is declared in.
12961 Finally, derived type definitions are allowed to be BIND(C) since that
12962 only implies that they're interoperable, and they are checked fully for
12963 interoperability when a variable is declared of that type. */
12964 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12965 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12966 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12970 /* First, make sure the variable is declared at the
12971 module-level scope (J3/04-007, Section 15.3). */
12972 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12973 sym
->attr
.in_common
== 0)
12975 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12976 "is neither a COMMON block nor declared at the "
12977 "module level scope", sym
->name
, &(sym
->declared_at
));
12980 else if (sym
->common_head
!= NULL
)
12982 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12986 /* If type() declaration, we need to verify that the components
12987 of the given type are all C interoperable, etc. */
12988 if (sym
->ts
.type
== BT_DERIVED
&&
12989 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12991 /* Make sure the user marked the derived type as BIND(C). If
12992 not, call the verify routine. This could print an error
12993 for the derived type more than once if multiple variables
12994 of that type are declared. */
12995 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12996 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13000 /* Verify the variable itself as C interoperable if it
13001 is BIND(C). It is not possible for this to succeed if
13002 the verify_bind_c_derived_type failed, so don't have to handle
13003 any error returned by verify_bind_c_derived_type. */
13004 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13005 sym
->common_block
);
13010 /* clear the is_bind_c flag to prevent reporting errors more than
13011 once if something failed. */
13012 sym
->attr
.is_bind_c
= 0;
13017 /* If a derived type symbol has reached this point, without its
13018 type being declared, we have an error. Notice that most
13019 conditions that produce undefined derived types have already
13020 been dealt with. However, the likes of:
13021 implicit type(t) (t) ..... call foo (t) will get us here if
13022 the type is not declared in the scope of the implicit
13023 statement. Change the type to BT_UNKNOWN, both because it is so
13024 and to prevent an ICE. */
13025 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13026 && sym
->ts
.u
.derived
->components
== NULL
13027 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13029 gfc_error ("The derived type '%s' at %L is of type '%s', "
13030 "which has not been defined", sym
->name
,
13031 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13032 sym
->ts
.type
= BT_UNKNOWN
;
13036 /* Make sure that the derived type has been resolved and that the
13037 derived type is visible in the symbol's namespace, if it is a
13038 module function and is not PRIVATE. */
13039 if (sym
->ts
.type
== BT_DERIVED
13040 && sym
->ts
.u
.derived
->attr
.use_assoc
13041 && sym
->ns
->proc_name
13042 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13043 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13046 /* Unless the derived-type declaration is use associated, Fortran 95
13047 does not allow public entries of private derived types.
13048 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13049 161 in 95-006r3. */
13050 if (sym
->ts
.type
== BT_DERIVED
13051 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13052 && !sym
->ts
.u
.derived
->attr
.use_assoc
13053 && gfc_check_symbol_access (sym
)
13054 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13055 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13056 "derived type '%s'",
13057 (sym
->attr
.flavor
== FL_PARAMETER
)
13058 ? "parameter" : "variable",
13059 sym
->name
, &sym
->declared_at
,
13060 sym
->ts
.u
.derived
->name
))
13063 /* F2008, C1302. */
13064 if (sym
->ts
.type
== BT_DERIVED
13065 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13066 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13067 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13068 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13070 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13071 "type LOCK_TYPE must be a coarray", sym
->name
,
13072 &sym
->declared_at
);
13076 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13077 default initialization is defined (5.1.2.4.4). */
13078 if (sym
->ts
.type
== BT_DERIVED
13080 && sym
->attr
.intent
== INTENT_OUT
13082 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13084 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13086 if (c
->initializer
)
13088 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13089 "ASSUMED SIZE and so cannot have a default initializer",
13090 sym
->name
, &sym
->declared_at
);
13097 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13098 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13100 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13101 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13106 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13107 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13108 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13109 || class_attr
.codimension
)
13110 && (sym
->attr
.result
|| sym
->result
== sym
))
13112 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13113 "a coarray component", sym
->name
, &sym
->declared_at
);
13118 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13119 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13121 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13122 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13127 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13128 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13129 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13130 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13131 || class_attr
.allocatable
))
13133 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13134 "nonpointer, nonallocatable scalar, which is not a coarray",
13135 sym
->name
, &sym
->declared_at
);
13139 /* F2008, C526. The function-result case was handled above. */
13140 if (class_attr
.codimension
13141 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13142 || sym
->attr
.select_type_temporary
13143 || sym
->ns
->save_all
13144 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13145 || sym
->ns
->proc_name
->attr
.is_main_program
13146 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13148 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13149 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13153 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13154 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13156 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13157 "deferred shape", sym
->name
, &sym
->declared_at
);
13160 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13161 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13163 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13164 "deferred shape", sym
->name
, &sym
->declared_at
);
13169 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13170 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13171 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13172 || (class_attr
.codimension
&& class_attr
.allocatable
))
13173 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13175 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13176 "allocatable coarray or have coarray components",
13177 sym
->name
, &sym
->declared_at
);
13181 if (class_attr
.codimension
&& sym
->attr
.dummy
13182 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13184 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13185 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13186 sym
->ns
->proc_name
->name
);
13190 if (sym
->ts
.type
== BT_LOGICAL
13191 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13192 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13193 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13196 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13197 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13199 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13200 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13201 "%L with non-C_Bool kind in BIND(C) procedure "
13202 "'%s'", sym
->name
, &sym
->declared_at
,
13203 sym
->ns
->proc_name
->name
))
13205 else if (!gfc_logical_kinds
[i
].c_bool
13206 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13207 "'%s' at %L with non-C_Bool kind in "
13208 "BIND(C) procedure '%s'", sym
->name
,
13210 sym
->attr
.function
? sym
->name
13211 : sym
->ns
->proc_name
->name
))
13215 switch (sym
->attr
.flavor
)
13218 if (!resolve_fl_variable (sym
, mp_flag
))
13223 if (!resolve_fl_procedure (sym
, mp_flag
))
13228 if (!resolve_fl_namelist (sym
))
13233 if (!resolve_fl_parameter (sym
))
13241 /* Resolve array specifier. Check as well some constraints
13242 on COMMON blocks. */
13244 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13246 /* Set the formal_arg_flag so that check_conflict will not throw
13247 an error for host associated variables in the specification
13248 expression for an array_valued function. */
13249 if (sym
->attr
.function
&& sym
->as
)
13250 formal_arg_flag
= 1;
13252 saved_specification_expr
= specification_expr
;
13253 specification_expr
= true;
13254 gfc_resolve_array_spec (sym
->as
, check_constant
);
13255 specification_expr
= saved_specification_expr
;
13257 formal_arg_flag
= 0;
13259 /* Resolve formal namespaces. */
13260 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13261 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13262 gfc_resolve (sym
->formal_ns
);
13264 /* Make sure the formal namespace is present. */
13265 if (sym
->formal
&& !sym
->formal_ns
)
13267 gfc_formal_arglist
*formal
= sym
->formal
;
13268 while (formal
&& !formal
->sym
)
13269 formal
= formal
->next
;
13273 sym
->formal_ns
= formal
->sym
->ns
;
13274 if (sym
->ns
!= formal
->sym
->ns
)
13275 sym
->formal_ns
->refs
++;
13279 /* Check threadprivate restrictions. */
13280 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13281 && (!sym
->attr
.in_common
13282 && sym
->module
== NULL
13283 && (sym
->ns
->proc_name
== NULL
13284 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13285 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13287 /* If we have come this far we can apply default-initializers, as
13288 described in 14.7.5, to those variables that have not already
13289 been assigned one. */
13290 if (sym
->ts
.type
== BT_DERIVED
13292 && !sym
->attr
.allocatable
13293 && !sym
->attr
.alloc_comp
)
13295 symbol_attribute
*a
= &sym
->attr
;
13297 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13298 && !a
->in_common
&& !a
->use_assoc
13299 && (a
->referenced
|| a
->result
)
13300 && !(a
->function
&& sym
!= sym
->result
))
13301 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13302 apply_default_init (sym
);
13305 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13306 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13307 && !CLASS_DATA (sym
)->attr
.class_pointer
13308 && !CLASS_DATA (sym
)->attr
.allocatable
)
13309 apply_default_init (sym
);
13311 /* If this symbol has a type-spec, check it. */
13312 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13313 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13314 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13319 /************* Resolve DATA statements *************/
13323 gfc_data_value
*vnode
;
13329 /* Advance the values structure to point to the next value in the data list. */
13332 next_data_value (void)
13334 while (mpz_cmp_ui (values
.left
, 0) == 0)
13337 if (values
.vnode
->next
== NULL
)
13340 values
.vnode
= values
.vnode
->next
;
13341 mpz_set (values
.left
, values
.vnode
->repeat
);
13349 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13355 ar_type mark
= AR_UNKNOWN
;
13357 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13363 if (!gfc_resolve_expr (var
->expr
))
13367 mpz_init_set_si (offset
, 0);
13370 if (e
->expr_type
!= EXPR_VARIABLE
)
13371 gfc_internal_error ("check_data_variable(): Bad expression");
13373 sym
= e
->symtree
->n
.sym
;
13375 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13377 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13378 sym
->name
, &sym
->declared_at
);
13381 if (e
->ref
== NULL
&& sym
->as
)
13383 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13384 " declaration", sym
->name
, where
);
13388 has_pointer
= sym
->attr
.pointer
;
13390 if (gfc_is_coindexed (e
))
13392 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13397 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13399 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13403 && ref
->type
== REF_ARRAY
13404 && ref
->u
.ar
.type
!= AR_FULL
)
13406 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13407 "be a full array", sym
->name
, where
);
13412 if (e
->rank
== 0 || has_pointer
)
13414 mpz_init_set_ui (size
, 1);
13421 /* Find the array section reference. */
13422 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13424 if (ref
->type
!= REF_ARRAY
)
13426 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13432 /* Set marks according to the reference pattern. */
13433 switch (ref
->u
.ar
.type
)
13441 /* Get the start position of array section. */
13442 gfc_get_section_index (ar
, section_index
, &offset
);
13447 gcc_unreachable ();
13450 if (!gfc_array_size (e
, &size
))
13452 gfc_error ("Nonconstant array section at %L in DATA statement",
13454 mpz_clear (offset
);
13461 while (mpz_cmp_ui (size
, 0) > 0)
13463 if (!next_data_value ())
13465 gfc_error ("DATA statement at %L has more variables than values",
13471 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13475 /* If we have more than one element left in the repeat count,
13476 and we have more than one element left in the target variable,
13477 then create a range assignment. */
13478 /* FIXME: Only done for full arrays for now, since array sections
13480 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13481 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13485 if (mpz_cmp (size
, values
.left
) >= 0)
13487 mpz_init_set (range
, values
.left
);
13488 mpz_sub (size
, size
, values
.left
);
13489 mpz_set_ui (values
.left
, 0);
13493 mpz_init_set (range
, size
);
13494 mpz_sub (values
.left
, values
.left
, size
);
13495 mpz_set_ui (size
, 0);
13498 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13501 mpz_add (offset
, offset
, range
);
13508 /* Assign initial value to symbol. */
13511 mpz_sub_ui (values
.left
, values
.left
, 1);
13512 mpz_sub_ui (size
, size
, 1);
13514 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13519 if (mark
== AR_FULL
)
13520 mpz_add_ui (offset
, offset
, 1);
13522 /* Modify the array section indexes and recalculate the offset
13523 for next element. */
13524 else if (mark
== AR_SECTION
)
13525 gfc_advance_section (section_index
, ar
, &offset
);
13529 if (mark
== AR_SECTION
)
13531 for (i
= 0; i
< ar
->dimen
; i
++)
13532 mpz_clear (section_index
[i
]);
13536 mpz_clear (offset
);
13542 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13544 /* Iterate over a list of elements in a DATA statement. */
13547 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13550 iterator_stack frame
;
13551 gfc_expr
*e
, *start
, *end
, *step
;
13552 bool retval
= true;
13554 mpz_init (frame
.value
);
13557 start
= gfc_copy_expr (var
->iter
.start
);
13558 end
= gfc_copy_expr (var
->iter
.end
);
13559 step
= gfc_copy_expr (var
->iter
.step
);
13561 if (!gfc_simplify_expr (start
, 1)
13562 || start
->expr_type
!= EXPR_CONSTANT
)
13564 gfc_error ("start of implied-do loop at %L could not be "
13565 "simplified to a constant value", &start
->where
);
13569 if (!gfc_simplify_expr (end
, 1)
13570 || end
->expr_type
!= EXPR_CONSTANT
)
13572 gfc_error ("end of implied-do loop at %L could not be "
13573 "simplified to a constant value", &start
->where
);
13577 if (!gfc_simplify_expr (step
, 1)
13578 || step
->expr_type
!= EXPR_CONSTANT
)
13580 gfc_error ("step of implied-do loop at %L could not be "
13581 "simplified to a constant value", &start
->where
);
13586 mpz_set (trip
, end
->value
.integer
);
13587 mpz_sub (trip
, trip
, start
->value
.integer
);
13588 mpz_add (trip
, trip
, step
->value
.integer
);
13590 mpz_div (trip
, trip
, step
->value
.integer
);
13592 mpz_set (frame
.value
, start
->value
.integer
);
13594 frame
.prev
= iter_stack
;
13595 frame
.variable
= var
->iter
.var
->symtree
;
13596 iter_stack
= &frame
;
13598 while (mpz_cmp_ui (trip
, 0) > 0)
13600 if (!traverse_data_var (var
->list
, where
))
13606 e
= gfc_copy_expr (var
->expr
);
13607 if (!gfc_simplify_expr (e
, 1))
13614 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13616 mpz_sub_ui (trip
, trip
, 1);
13620 mpz_clear (frame
.value
);
13623 gfc_free_expr (start
);
13624 gfc_free_expr (end
);
13625 gfc_free_expr (step
);
13627 iter_stack
= frame
.prev
;
13632 /* Type resolve variables in the variable list of a DATA statement. */
13635 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13639 for (; var
; var
= var
->next
)
13641 if (var
->expr
== NULL
)
13642 t
= traverse_data_list (var
, where
);
13644 t
= check_data_variable (var
, where
);
13654 /* Resolve the expressions and iterators associated with a data statement.
13655 This is separate from the assignment checking because data lists should
13656 only be resolved once. */
13659 resolve_data_variables (gfc_data_variable
*d
)
13661 for (; d
; d
= d
->next
)
13663 if (d
->list
== NULL
)
13665 if (!gfc_resolve_expr (d
->expr
))
13670 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13673 if (!resolve_data_variables (d
->list
))
13682 /* Resolve a single DATA statement. We implement this by storing a pointer to
13683 the value list into static variables, and then recursively traversing the
13684 variables list, expanding iterators and such. */
13687 resolve_data (gfc_data
*d
)
13690 if (!resolve_data_variables (d
->var
))
13693 values
.vnode
= d
->value
;
13694 if (d
->value
== NULL
)
13695 mpz_set_ui (values
.left
, 0);
13697 mpz_set (values
.left
, d
->value
->repeat
);
13699 if (!traverse_data_var (d
->var
, &d
->where
))
13702 /* At this point, we better not have any values left. */
13704 if (next_data_value ())
13705 gfc_error ("DATA statement at %L has more values than variables",
13710 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13711 accessed by host or use association, is a dummy argument to a pure function,
13712 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13713 is storage associated with any such variable, shall not be used in the
13714 following contexts: (clients of this function). */
13716 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13717 procedure. Returns zero if assignment is OK, nonzero if there is a
13720 gfc_impure_variable (gfc_symbol
*sym
)
13725 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13728 /* Check if the symbol's ns is inside the pure procedure. */
13729 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13733 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13737 proc
= sym
->ns
->proc_name
;
13738 if (sym
->attr
.dummy
13739 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13740 || proc
->attr
.function
))
13743 /* TODO: Sort out what can be storage associated, if anything, and include
13744 it here. In principle equivalences should be scanned but it does not
13745 seem to be possible to storage associate an impure variable this way. */
13750 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13751 current namespace is inside a pure procedure. */
13754 gfc_pure (gfc_symbol
*sym
)
13756 symbol_attribute attr
;
13761 /* Check if the current namespace or one of its parents
13762 belongs to a pure procedure. */
13763 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13765 sym
= ns
->proc_name
;
13769 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13777 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13781 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13782 checks if the current namespace is implicitly pure. Note that this
13783 function returns false for a PURE procedure. */
13786 gfc_implicit_pure (gfc_symbol
*sym
)
13792 /* Check if the current procedure is implicit_pure. Walk up
13793 the procedure list until we find a procedure. */
13794 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13796 sym
= ns
->proc_name
;
13800 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13805 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13806 && !sym
->attr
.pure
;
13810 /* Test whether the current procedure is elemental or not. */
13813 gfc_elemental (gfc_symbol
*sym
)
13815 symbol_attribute attr
;
13818 sym
= gfc_current_ns
->proc_name
;
13823 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13827 /* Warn about unused labels. */
13830 warn_unused_fortran_label (gfc_st_label
*label
)
13835 warn_unused_fortran_label (label
->left
);
13837 if (label
->defined
== ST_LABEL_UNKNOWN
)
13840 switch (label
->referenced
)
13842 case ST_LABEL_UNKNOWN
:
13843 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13847 case ST_LABEL_BAD_TARGET
:
13848 gfc_warning ("Label %d at %L defined but cannot be used",
13849 label
->value
, &label
->where
);
13856 warn_unused_fortran_label (label
->right
);
13860 /* Returns the sequence type of a symbol or sequence. */
13863 sequence_type (gfc_typespec ts
)
13872 if (ts
.u
.derived
->components
== NULL
)
13873 return SEQ_NONDEFAULT
;
13875 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13876 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13877 if (sequence_type (c
->ts
) != result
)
13883 if (ts
.kind
!= gfc_default_character_kind
)
13884 return SEQ_NONDEFAULT
;
13886 return SEQ_CHARACTER
;
13889 if (ts
.kind
!= gfc_default_integer_kind
)
13890 return SEQ_NONDEFAULT
;
13892 return SEQ_NUMERIC
;
13895 if (!(ts
.kind
== gfc_default_real_kind
13896 || ts
.kind
== gfc_default_double_kind
))
13897 return SEQ_NONDEFAULT
;
13899 return SEQ_NUMERIC
;
13902 if (ts
.kind
!= gfc_default_complex_kind
)
13903 return SEQ_NONDEFAULT
;
13905 return SEQ_NUMERIC
;
13908 if (ts
.kind
!= gfc_default_logical_kind
)
13909 return SEQ_NONDEFAULT
;
13911 return SEQ_NUMERIC
;
13914 return SEQ_NONDEFAULT
;
13919 /* Resolve derived type EQUIVALENCE object. */
13922 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13924 gfc_component
*c
= derived
->components
;
13929 /* Shall not be an object of nonsequence derived type. */
13930 if (!derived
->attr
.sequence
)
13932 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13933 "attribute to be an EQUIVALENCE object", sym
->name
,
13938 /* Shall not have allocatable components. */
13939 if (derived
->attr
.alloc_comp
)
13941 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13942 "components to be an EQUIVALENCE object",sym
->name
,
13947 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13949 gfc_error ("Derived type variable '%s' at %L with default "
13950 "initialization cannot be in EQUIVALENCE with a variable "
13951 "in COMMON", sym
->name
, &e
->where
);
13955 for (; c
; c
= c
->next
)
13957 if (c
->ts
.type
== BT_DERIVED
13958 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
13961 /* Shall not be an object of sequence derived type containing a pointer
13962 in the structure. */
13963 if (c
->attr
.pointer
)
13965 gfc_error ("Derived type variable '%s' at %L with pointer "
13966 "component(s) cannot be an EQUIVALENCE object",
13967 sym
->name
, &e
->where
);
13975 /* Resolve equivalence object.
13976 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13977 an allocatable array, an object of nonsequence derived type, an object of
13978 sequence derived type containing a pointer at any level of component
13979 selection, an automatic object, a function name, an entry name, a result
13980 name, a named constant, a structure component, or a subobject of any of
13981 the preceding objects. A substring shall not have length zero. A
13982 derived type shall not have components with default initialization nor
13983 shall two objects of an equivalence group be initialized.
13984 Either all or none of the objects shall have an protected attribute.
13985 The simple constraints are done in symbol.c(check_conflict) and the rest
13986 are implemented here. */
13989 resolve_equivalence (gfc_equiv
*eq
)
13992 gfc_symbol
*first_sym
;
13995 locus
*last_where
= NULL
;
13996 seq_type eq_type
, last_eq_type
;
13997 gfc_typespec
*last_ts
;
13998 int object
, cnt_protected
;
14001 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14003 first_sym
= eq
->expr
->symtree
->n
.sym
;
14007 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14011 e
->ts
= e
->symtree
->n
.sym
->ts
;
14012 /* match_varspec might not know yet if it is seeing
14013 array reference or substring reference, as it doesn't
14015 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14017 gfc_ref
*ref
= e
->ref
;
14018 sym
= e
->symtree
->n
.sym
;
14020 if (sym
->attr
.dimension
)
14022 ref
->u
.ar
.as
= sym
->as
;
14026 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14027 if (e
->ts
.type
== BT_CHARACTER
14029 && ref
->type
== REF_ARRAY
14030 && ref
->u
.ar
.dimen
== 1
14031 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14032 && ref
->u
.ar
.stride
[0] == NULL
)
14034 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14035 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14038 /* Optimize away the (:) reference. */
14039 if (start
== NULL
&& end
== NULL
)
14042 e
->ref
= ref
->next
;
14044 e
->ref
->next
= ref
->next
;
14049 ref
->type
= REF_SUBSTRING
;
14051 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14053 ref
->u
.ss
.start
= start
;
14054 if (end
== NULL
&& e
->ts
.u
.cl
)
14055 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14056 ref
->u
.ss
.end
= end
;
14057 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14064 /* Any further ref is an error. */
14067 gcc_assert (ref
->type
== REF_ARRAY
);
14068 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14074 if (!gfc_resolve_expr (e
))
14077 sym
= e
->symtree
->n
.sym
;
14079 if (sym
->attr
.is_protected
)
14081 if (cnt_protected
> 0 && cnt_protected
!= object
)
14083 gfc_error ("Either all or none of the objects in the "
14084 "EQUIVALENCE set at %L shall have the "
14085 "PROTECTED attribute",
14090 /* Shall not equivalence common block variables in a PURE procedure. */
14091 if (sym
->ns
->proc_name
14092 && sym
->ns
->proc_name
->attr
.pure
14093 && sym
->attr
.in_common
)
14095 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14096 "object in the pure procedure '%s'",
14097 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14101 /* Shall not be a named constant. */
14102 if (e
->expr_type
== EXPR_CONSTANT
)
14104 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14105 "object", sym
->name
, &e
->where
);
14109 if (e
->ts
.type
== BT_DERIVED
14110 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14113 /* Check that the types correspond correctly:
14115 A numeric sequence structure may be equivalenced to another sequence
14116 structure, an object of default integer type, default real type, double
14117 precision real type, default logical type such that components of the
14118 structure ultimately only become associated to objects of the same
14119 kind. A character sequence structure may be equivalenced to an object
14120 of default character kind or another character sequence structure.
14121 Other objects may be equivalenced only to objects of the same type and
14122 kind parameters. */
14124 /* Identical types are unconditionally OK. */
14125 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14126 goto identical_types
;
14128 last_eq_type
= sequence_type (*last_ts
);
14129 eq_type
= sequence_type (sym
->ts
);
14131 /* Since the pair of objects is not of the same type, mixed or
14132 non-default sequences can be rejected. */
14134 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14135 "statement at %L with different type objects";
14137 && last_eq_type
== SEQ_MIXED
14138 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14139 || (eq_type
== SEQ_MIXED
14140 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14143 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14144 "statement at %L with objects of different type";
14146 && last_eq_type
== SEQ_NONDEFAULT
14147 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14148 || (eq_type
== SEQ_NONDEFAULT
14149 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14152 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14153 "EQUIVALENCE statement at %L";
14154 if (last_eq_type
== SEQ_CHARACTER
14155 && eq_type
!= SEQ_CHARACTER
14156 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14159 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14160 "EQUIVALENCE statement at %L";
14161 if (last_eq_type
== SEQ_NUMERIC
14162 && eq_type
!= SEQ_NUMERIC
14163 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14168 last_where
= &e
->where
;
14173 /* Shall not be an automatic array. */
14174 if (e
->ref
->type
== REF_ARRAY
14175 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14177 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14178 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14185 /* Shall not be a structure component. */
14186 if (r
->type
== REF_COMPONENT
)
14188 gfc_error ("Structure component '%s' at %L cannot be an "
14189 "EQUIVALENCE object",
14190 r
->u
.c
.component
->name
, &e
->where
);
14194 /* A substring shall not have length zero. */
14195 if (r
->type
== REF_SUBSTRING
)
14197 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14199 gfc_error ("Substring at %L has length zero",
14200 &r
->u
.ss
.start
->where
);
14210 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14213 resolve_fntype (gfc_namespace
*ns
)
14215 gfc_entry_list
*el
;
14218 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14221 /* If there are any entries, ns->proc_name is the entry master
14222 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14224 sym
= ns
->entries
->sym
;
14226 sym
= ns
->proc_name
;
14227 if (sym
->result
== sym
14228 && sym
->ts
.type
== BT_UNKNOWN
14229 && !gfc_set_default_type (sym
, 0, NULL
)
14230 && !sym
->attr
.untyped
)
14232 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14233 sym
->name
, &sym
->declared_at
);
14234 sym
->attr
.untyped
= 1;
14237 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14238 && !sym
->attr
.contained
14239 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14240 && gfc_check_symbol_access (sym
))
14242 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14243 "%L of PRIVATE type '%s'", sym
->name
,
14244 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14248 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14250 if (el
->sym
->result
== el
->sym
14251 && el
->sym
->ts
.type
== BT_UNKNOWN
14252 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14253 && !el
->sym
->attr
.untyped
)
14255 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14256 el
->sym
->name
, &el
->sym
->declared_at
);
14257 el
->sym
->attr
.untyped
= 1;
14263 /* 12.3.2.1.1 Defined operators. */
14266 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14268 gfc_formal_arglist
*formal
;
14270 if (!sym
->attr
.function
)
14272 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14273 sym
->name
, &where
);
14277 if (sym
->ts
.type
== BT_CHARACTER
14278 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14279 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14280 && sym
->result
->ts
.u
.cl
->length
))
14282 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14283 "character length", sym
->name
, &where
);
14287 formal
= gfc_sym_get_dummy_args (sym
);
14288 if (!formal
|| !formal
->sym
)
14290 gfc_error ("User operator procedure '%s' at %L must have at least "
14291 "one argument", sym
->name
, &where
);
14295 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14297 gfc_error ("First argument of operator interface at %L must be "
14298 "INTENT(IN)", &where
);
14302 if (formal
->sym
->attr
.optional
)
14304 gfc_error ("First argument of operator interface at %L cannot be "
14305 "optional", &where
);
14309 formal
= formal
->next
;
14310 if (!formal
|| !formal
->sym
)
14313 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14315 gfc_error ("Second argument of operator interface at %L must be "
14316 "INTENT(IN)", &where
);
14320 if (formal
->sym
->attr
.optional
)
14322 gfc_error ("Second argument of operator interface at %L cannot be "
14323 "optional", &where
);
14329 gfc_error ("Operator interface at %L must have, at most, two "
14330 "arguments", &where
);
14338 gfc_resolve_uops (gfc_symtree
*symtree
)
14340 gfc_interface
*itr
;
14342 if (symtree
== NULL
)
14345 gfc_resolve_uops (symtree
->left
);
14346 gfc_resolve_uops (symtree
->right
);
14348 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14349 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14353 /* Examine all of the expressions associated with a program unit,
14354 assign types to all intermediate expressions, make sure that all
14355 assignments are to compatible types and figure out which names
14356 refer to which functions or subroutines. It doesn't check code
14357 block, which is handled by resolve_code. */
14360 resolve_types (gfc_namespace
*ns
)
14366 gfc_namespace
* old_ns
= gfc_current_ns
;
14368 /* Check that all IMPLICIT types are ok. */
14369 if (!ns
->seen_implicit_none
)
14372 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14373 if (ns
->set_flag
[letter
]
14374 && !resolve_typespec_used (&ns
->default_type
[letter
],
14375 &ns
->implicit_loc
[letter
], NULL
))
14379 gfc_current_ns
= ns
;
14381 resolve_entries (ns
);
14383 resolve_common_vars (ns
->blank_common
.head
, false);
14384 resolve_common_blocks (ns
->common_root
);
14386 resolve_contained_functions (ns
);
14388 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14389 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14390 resolve_formal_arglist (ns
->proc_name
);
14392 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14394 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14395 resolve_charlen (cl
);
14397 gfc_traverse_ns (ns
, resolve_symbol
);
14399 resolve_fntype (ns
);
14401 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14403 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14404 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14405 "also be PURE", n
->proc_name
->name
,
14406 &n
->proc_name
->declared_at
);
14412 do_concurrent_flag
= 0;
14413 gfc_check_interfaces (ns
);
14415 gfc_traverse_ns (ns
, resolve_values
);
14421 for (d
= ns
->data
; d
; d
= d
->next
)
14425 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14427 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14429 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14430 resolve_equivalence (eq
);
14432 /* Warn about unused labels. */
14433 if (warn_unused_label
)
14434 warn_unused_fortran_label (ns
->st_labels
);
14436 gfc_resolve_uops (ns
->uop_root
);
14438 gfc_current_ns
= old_ns
;
14442 /* Call resolve_code recursively. */
14445 resolve_codes (gfc_namespace
*ns
)
14448 bitmap_obstack old_obstack
;
14450 if (ns
->resolved
== 1)
14453 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14456 gfc_current_ns
= ns
;
14458 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14459 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14462 /* Set to an out of range value. */
14463 current_entry_id
= -1;
14465 old_obstack
= labels_obstack
;
14466 bitmap_obstack_initialize (&labels_obstack
);
14468 resolve_code (ns
->code
, ns
);
14470 bitmap_obstack_release (&labels_obstack
);
14471 labels_obstack
= old_obstack
;
14475 /* This function is called after a complete program unit has been compiled.
14476 Its purpose is to examine all of the expressions associated with a program
14477 unit, assign types to all intermediate expressions, make sure that all
14478 assignments are to compatible types and figure out which names refer to
14479 which functions or subroutines. */
14482 gfc_resolve (gfc_namespace
*ns
)
14484 gfc_namespace
*old_ns
;
14485 code_stack
*old_cs_base
;
14491 old_ns
= gfc_current_ns
;
14492 old_cs_base
= cs_base
;
14494 resolve_types (ns
);
14495 component_assignment_level
= 0;
14496 resolve_codes (ns
);
14498 gfc_current_ns
= old_ns
;
14499 cs_base
= old_cs_base
;
14502 gfc_run_passes (ns
);