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 int gfc_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. */
726 c
= gfc_get_code (EXEC_ENTRY
);
731 /* Create a new symbol for the master function. */
732 /* Give the internal function a unique name (within this file).
733 Also include the function name so the user has some hope of figuring
734 out what is going on. */
735 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
736 master_count
++, ns
->proc_name
->name
);
737 gfc_get_ha_symbol (name
, &proc
);
738 gcc_assert (proc
!= NULL
);
740 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
741 if (ns
->proc_name
->attr
.subroutine
)
742 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
746 gfc_typespec
*ts
, *fts
;
747 gfc_array_spec
*as
, *fas
;
748 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
750 fas
= ns
->entries
->sym
->as
;
751 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
752 fts
= &ns
->entries
->sym
->result
->ts
;
753 if (fts
->type
== BT_UNKNOWN
)
754 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
755 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
757 ts
= &el
->sym
->result
->ts
;
759 as
= as
? as
: el
->sym
->result
->as
;
760 if (ts
->type
== BT_UNKNOWN
)
761 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
763 if (! gfc_compare_types (ts
, fts
)
764 || (el
->sym
->result
->attr
.dimension
765 != ns
->entries
->sym
->result
->attr
.dimension
)
766 || (el
->sym
->result
->attr
.pointer
767 != ns
->entries
->sym
->result
->attr
.pointer
))
769 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
770 && gfc_compare_array_spec (as
, fas
) == 0)
771 gfc_error ("Function %s at %L has entries with mismatched "
772 "array specifications", ns
->entries
->sym
->name
,
773 &ns
->entries
->sym
->declared_at
);
774 /* The characteristics need to match and thus both need to have
775 the same string length, i.e. both len=*, or both len=4.
776 Having both len=<variable> is also possible, but difficult to
777 check at compile time. */
778 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
779 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
780 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
782 && ts
->u
.cl
->length
->expr_type
783 != fts
->u
.cl
->length
->expr_type
)
785 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
786 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
787 fts
->u
.cl
->length
->value
.integer
) != 0)))
788 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
789 "entries returning variables of different "
790 "string lengths", ns
->entries
->sym
->name
,
791 &ns
->entries
->sym
->declared_at
);
796 sym
= ns
->entries
->sym
->result
;
797 /* All result types the same. */
799 if (sym
->attr
.dimension
)
800 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
801 if (sym
->attr
.pointer
)
802 gfc_add_pointer (&proc
->attr
, NULL
);
806 /* Otherwise the result will be passed through a union by
808 proc
->attr
.mixed_entry_master
= 1;
809 for (el
= ns
->entries
; el
; el
= el
->next
)
811 sym
= el
->sym
->result
;
812 if (sym
->attr
.dimension
)
814 if (el
== ns
->entries
)
815 gfc_error ("FUNCTION result %s can't be an array in "
816 "FUNCTION %s at %L", sym
->name
,
817 ns
->entries
->sym
->name
, &sym
->declared_at
);
819 gfc_error ("ENTRY result %s can't be an array in "
820 "FUNCTION %s at %L", sym
->name
,
821 ns
->entries
->sym
->name
, &sym
->declared_at
);
823 else if (sym
->attr
.pointer
)
825 if (el
== ns
->entries
)
826 gfc_error ("FUNCTION result %s can't be a POINTER in "
827 "FUNCTION %s at %L", sym
->name
,
828 ns
->entries
->sym
->name
, &sym
->declared_at
);
830 gfc_error ("ENTRY result %s can't be a POINTER in "
831 "FUNCTION %s at %L", sym
->name
,
832 ns
->entries
->sym
->name
, &sym
->declared_at
);
837 if (ts
->type
== BT_UNKNOWN
)
838 ts
= gfc_get_default_type (sym
->name
, NULL
);
842 if (ts
->kind
== gfc_default_integer_kind
)
846 if (ts
->kind
== gfc_default_real_kind
847 || ts
->kind
== gfc_default_double_kind
)
851 if (ts
->kind
== gfc_default_complex_kind
)
855 if (ts
->kind
== gfc_default_logical_kind
)
859 /* We will issue error elsewhere. */
867 if (el
== ns
->entries
)
868 gfc_error ("FUNCTION result %s can't be of type %s "
869 "in FUNCTION %s at %L", sym
->name
,
870 gfc_typename (ts
), ns
->entries
->sym
->name
,
873 gfc_error ("ENTRY result %s can't be of type %s "
874 "in FUNCTION %s at %L", sym
->name
,
875 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 proc
->attr
.access
= ACCESS_PRIVATE
;
883 proc
->attr
.entry_master
= 1;
885 /* Merge all the entry point arguments. */
886 for (el
= ns
->entries
; el
; el
= el
->next
)
887 merge_argument_lists (proc
, el
->sym
->formal
);
889 /* Check the master formal arguments for any that are not
890 present in all entry points. */
891 for (el
= ns
->entries
; el
; el
= el
->next
)
892 check_argument_lists (proc
, el
->sym
->formal
);
894 /* Use the master function for the function body. */
895 ns
->proc_name
= proc
;
897 /* Finalize the new symbols. */
898 gfc_commit_symbols ();
900 /* Restore the original namespace. */
901 gfc_current_ns
= old_ns
;
905 /* Resolve common variables. */
907 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
909 gfc_symbol
*csym
= sym
;
911 for (; csym
; csym
= csym
->common_next
)
913 if (csym
->value
|| csym
->attr
.data
)
915 if (!csym
->ns
->is_block_data
)
916 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
917 "but only in BLOCK DATA initialization is "
918 "allowed", csym
->name
, &csym
->declared_at
);
919 else if (!named_common
)
920 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
921 "in a blank COMMON but initialization is only "
922 "allowed in named common blocks", csym
->name
,
926 if (UNLIMITED_POLY (csym
))
927 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
928 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
930 if (csym
->ts
.type
!= BT_DERIVED
)
933 if (!(csym
->ts
.u
.derived
->attr
.sequence
934 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
935 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
936 "has neither the SEQUENCE nor the BIND(C) "
937 "attribute", csym
->name
, &csym
->declared_at
);
938 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
939 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
940 "has an ultimate component that is "
941 "allocatable", csym
->name
, &csym
->declared_at
);
942 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
943 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
944 "may not have default initializer", csym
->name
,
947 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
948 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
952 /* Resolve common blocks. */
954 resolve_common_blocks (gfc_symtree
*common_root
)
959 if (common_root
== NULL
)
962 if (common_root
->left
)
963 resolve_common_blocks (common_root
->left
);
964 if (common_root
->right
)
965 resolve_common_blocks (common_root
->right
);
967 resolve_common_vars (common_root
->n
.common
->head
, true);
969 /* The common name is a global name - in Fortran 2003 also if it has a
970 C binding name, since Fortran 2008 only the C binding name is a global
972 if (!common_root
->n
.common
->binding_label
973 || gfc_notification_std (GFC_STD_F2008
))
975 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
976 common_root
->n
.common
->name
);
978 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
979 && gsym
->type
== GSYM_COMMON
980 && ((common_root
->n
.common
->binding_label
981 && (!gsym
->binding_label
982 || strcmp (common_root
->n
.common
->binding_label
,
983 gsym
->binding_label
) != 0))
984 || (!common_root
->n
.common
->binding_label
985 && gsym
->binding_label
)))
987 gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
988 "identifier and must thus have the same binding name "
989 "as the same-named COMMON block at %L: %s vs %s",
990 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
992 common_root
->n
.common
->binding_label
993 ? common_root
->n
.common
->binding_label
: "(blank)",
994 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
998 if (gsym
&& gsym
->type
!= GSYM_COMMON
999 && !common_root
->n
.common
->binding_label
)
1001 gfc_error ("COMMON block '%s' at %L uses the same global identifier "
1003 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1009 gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
1010 "%L sharing the identifier with global non-COMMON-block "
1011 "entity at %L", common_root
->n
.common
->name
,
1012 &common_root
->n
.common
->where
, &gsym
->where
);
1017 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1018 gsym
->type
= GSYM_COMMON
;
1019 gsym
->where
= common_root
->n
.common
->where
;
1025 if (common_root
->n
.common
->binding_label
)
1027 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1028 common_root
->n
.common
->binding_label
);
1029 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1031 gfc_error ("COMMON block at %L with binding label %s uses the same "
1032 "global identifier as entity at %L",
1033 &common_root
->n
.common
->where
,
1034 common_root
->n
.common
->binding_label
, &gsym
->where
);
1039 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1040 gsym
->type
= GSYM_COMMON
;
1041 gsym
->where
= common_root
->n
.common
->where
;
1047 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1051 if (sym
->attr
.flavor
== FL_PARAMETER
)
1052 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
1053 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1055 if (sym
->attr
.external
)
1056 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
1057 sym
->name
, &common_root
->n
.common
->where
);
1059 if (sym
->attr
.intrinsic
)
1060 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
1061 sym
->name
, &common_root
->n
.common
->where
);
1062 else if (sym
->attr
.result
1063 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1064 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1065 "that is also a function result", sym
->name
,
1066 &common_root
->n
.common
->where
);
1067 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1068 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1069 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1070 "that is also a global procedure", sym
->name
,
1071 &common_root
->n
.common
->where
);
1075 /* Resolve contained function types. Because contained functions can call one
1076 another, they have to be worked out before any of the contained procedures
1079 The good news is that if a function doesn't already have a type, the only
1080 way it can get one is through an IMPLICIT type or a RESULT variable, because
1081 by definition contained functions are contained namespace they're contained
1082 in, not in a sibling or parent namespace. */
1085 resolve_contained_functions (gfc_namespace
*ns
)
1087 gfc_namespace
*child
;
1090 resolve_formal_arglists (ns
);
1092 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1094 /* Resolve alternate entry points first. */
1095 resolve_entries (child
);
1097 /* Then check function return types. */
1098 resolve_contained_fntype (child
->proc_name
, child
);
1099 for (el
= child
->entries
; el
; el
= el
->next
)
1100 resolve_contained_fntype (el
->sym
, child
);
1105 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1108 /* Resolve all of the elements of a structure constructor and make sure that
1109 the types are correct. The 'init' flag indicates that the given
1110 constructor is an initializer. */
1113 resolve_structure_cons (gfc_expr
*expr
, int init
)
1115 gfc_constructor
*cons
;
1116 gfc_component
*comp
;
1122 if (expr
->ts
.type
== BT_DERIVED
)
1123 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1125 cons
= gfc_constructor_first (expr
->value
.constructor
);
1127 /* A constructor may have references if it is the result of substituting a
1128 parameter variable. In this case we just pull out the component we
1131 comp
= expr
->ref
->u
.c
.sym
->components
;
1133 comp
= expr
->ts
.u
.derived
->components
;
1135 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1142 if (!gfc_resolve_expr (cons
->expr
))
1148 rank
= comp
->as
? comp
->as
->rank
: 0;
1149 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1150 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1152 gfc_error ("The rank of the element in the structure "
1153 "constructor at %L does not match that of the "
1154 "component (%d/%d)", &cons
->expr
->where
,
1155 cons
->expr
->rank
, rank
);
1159 /* If we don't have the right type, try to convert it. */
1161 if (!comp
->attr
.proc_pointer
&&
1162 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1164 if (strcmp (comp
->name
, "_extends") == 0)
1166 /* Can afford to be brutal with the _extends initializer.
1167 The derived type can get lost because it is PRIVATE
1168 but it is not usage constrained by the standard. */
1169 cons
->expr
->ts
= comp
->ts
;
1171 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component '%s', is %s but should be %s",
1175 &cons
->expr
->where
, comp
->name
,
1176 gfc_basic_typename (cons
->expr
->ts
.type
),
1177 gfc_basic_typename (comp
->ts
.type
));
1182 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1188 /* For strings, the length of the constructor should be the same as
1189 the one of the structure, ensure this if the lengths are known at
1190 compile time and when we are dealing with PARAMETER or structure
1192 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1193 && comp
->ts
.u
.cl
->length
1194 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1195 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1196 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1197 && cons
->expr
->rank
!= 0
1198 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1199 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1201 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1202 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1204 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1205 to make use of the gfc_resolve_character_array_constructor
1206 machinery. The expression is later simplified away to
1207 an array of string literals. */
1208 gfc_expr
*para
= cons
->expr
;
1209 cons
->expr
= gfc_get_expr ();
1210 cons
->expr
->ts
= para
->ts
;
1211 cons
->expr
->where
= para
->where
;
1212 cons
->expr
->expr_type
= EXPR_ARRAY
;
1213 cons
->expr
->rank
= para
->rank
;
1214 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1215 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1216 para
, &cons
->expr
->where
);
1218 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1221 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1222 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1224 gfc_charlen
*cl
, *cl2
;
1227 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1229 if (cl
== cons
->expr
->ts
.u
.cl
)
1237 cl2
->next
= cl
->next
;
1239 gfc_free_expr (cl
->length
);
1243 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1244 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1245 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1246 gfc_resolve_character_array_constructor (cons
->expr
);
1250 if (cons
->expr
->expr_type
== EXPR_NULL
1251 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1252 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1253 || (comp
->ts
.type
== BT_CLASS
1254 && (CLASS_DATA (comp
)->attr
.class_pointer
1255 || CLASS_DATA (comp
)->attr
.allocatable
))))
1258 gfc_error ("The NULL in the structure constructor at %L is "
1259 "being applied to component '%s', which is neither "
1260 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1264 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1266 /* Check procedure pointer interface. */
1267 gfc_symbol
*s2
= NULL
;
1272 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1275 s2
= c2
->ts
.interface
;
1278 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1280 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1281 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1283 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1285 s2
= cons
->expr
->symtree
->n
.sym
;
1286 name
= cons
->expr
->symtree
->n
.sym
->name
;
1289 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1290 err
, sizeof (err
), NULL
, NULL
))
1292 gfc_error ("Interface mismatch for procedure-pointer component "
1293 "'%s' in structure constructor at %L: %s",
1294 comp
->name
, &cons
->expr
->where
, err
);
1299 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1300 || cons
->expr
->expr_type
== EXPR_NULL
)
1303 a
= gfc_expr_attr (cons
->expr
);
1305 if (!a
.pointer
&& !a
.target
)
1308 gfc_error ("The element in the structure constructor at %L, "
1309 "for pointer component '%s' should be a POINTER or "
1310 "a TARGET", &cons
->expr
->where
, comp
->name
);
1315 /* F08:C461. Additional checks for pointer initialization. */
1319 gfc_error ("Pointer initialization target at %L "
1320 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1325 gfc_error ("Pointer initialization target at %L "
1326 "must have the SAVE attribute", &cons
->expr
->where
);
1330 /* F2003, C1272 (3). */
1331 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1332 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1333 || gfc_is_coindexed (cons
->expr
)))
1336 gfc_error ("Invalid expression in the structure constructor for "
1337 "pointer component '%s' at %L in PURE procedure",
1338 comp
->name
, &cons
->expr
->where
);
1341 if (gfc_implicit_pure (NULL
)
1342 && cons
->expr
->expr_type
== EXPR_VARIABLE
1343 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1344 || gfc_is_coindexed (cons
->expr
)))
1345 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1353 /****************** Expression name resolution ******************/
1355 /* Returns 0 if a symbol was not declared with a type or
1356 attribute declaration statement, nonzero otherwise. */
1359 was_declared (gfc_symbol
*sym
)
1365 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1368 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1369 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1370 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1371 || a
.asynchronous
|| a
.codimension
)
1378 /* Determine if a symbol is generic or not. */
1381 generic_sym (gfc_symbol
*sym
)
1385 if (sym
->attr
.generic
||
1386 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1389 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1392 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1399 return generic_sym (s
);
1406 /* Determine if a symbol is specific or not. */
1409 specific_sym (gfc_symbol
*sym
)
1413 if (sym
->attr
.if_source
== IFSRC_IFBODY
1414 || sym
->attr
.proc
== PROC_MODULE
1415 || sym
->attr
.proc
== PROC_INTERNAL
1416 || sym
->attr
.proc
== PROC_ST_FUNCTION
1417 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1418 || sym
->attr
.external
)
1421 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1424 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1426 return (s
== NULL
) ? 0 : specific_sym (s
);
1430 /* Figure out if the procedure is specific, generic or unknown. */
1433 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1437 procedure_kind (gfc_symbol
*sym
)
1439 if (generic_sym (sym
))
1440 return PTYPE_GENERIC
;
1442 if (specific_sym (sym
))
1443 return PTYPE_SPECIFIC
;
1445 return PTYPE_UNKNOWN
;
1448 /* Check references to assumed size arrays. The flag need_full_assumed_size
1449 is nonzero when matching actual arguments. */
1451 static int need_full_assumed_size
= 0;
1454 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1456 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1459 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1460 What should it be? */
1461 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1462 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1463 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1465 gfc_error ("The upper bound in the last dimension must "
1466 "appear in the reference to the assumed size "
1467 "array '%s' at %L", sym
->name
, &e
->where
);
1474 /* Look for bad assumed size array references in argument expressions
1475 of elemental and array valued intrinsic procedures. Since this is
1476 called from procedure resolution functions, it only recurses at
1480 resolve_assumed_size_actual (gfc_expr
*e
)
1485 switch (e
->expr_type
)
1488 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1493 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1494 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1505 /* Check a generic procedure, passed as an actual argument, to see if
1506 there is a matching specific name. If none, it is an error, and if
1507 more than one, the reference is ambiguous. */
1509 count_specific_procs (gfc_expr
*e
)
1516 sym
= e
->symtree
->n
.sym
;
1518 for (p
= sym
->generic
; p
; p
= p
->next
)
1519 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1521 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1527 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1531 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1532 "argument at %L", sym
->name
, &e
->where
);
1538 /* See if a call to sym could possibly be a not allowed RECURSION because of
1539 a missing RECURSIVE declaration. This means that either sym is the current
1540 context itself, or sym is the parent of a contained procedure calling its
1541 non-RECURSIVE containing procedure.
1542 This also works if sym is an ENTRY. */
1545 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1547 gfc_symbol
* proc_sym
;
1548 gfc_symbol
* context_proc
;
1549 gfc_namespace
* real_context
;
1551 if (sym
->attr
.flavor
== FL_PROGRAM
1552 || sym
->attr
.flavor
== FL_DERIVED
)
1555 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1557 /* If we've got an ENTRY, find real procedure. */
1558 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1559 proc_sym
= sym
->ns
->entries
->sym
;
1563 /* If sym is RECURSIVE, all is well of course. */
1564 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1567 /* Find the context procedure's "real" symbol if it has entries.
1568 We look for a procedure symbol, so recurse on the parents if we don't
1569 find one (like in case of a BLOCK construct). */
1570 for (real_context
= context
; ; real_context
= real_context
->parent
)
1572 /* We should find something, eventually! */
1573 gcc_assert (real_context
);
1575 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1576 : real_context
->proc_name
);
1578 /* In some special cases, there may not be a proc_name, like for this
1580 real(bad_kind()) function foo () ...
1581 when checking the call to bad_kind ().
1582 In these cases, we simply return here and assume that the
1587 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1591 /* A call from sym's body to itself is recursion, of course. */
1592 if (context_proc
== proc_sym
)
1595 /* The same is true if context is a contained procedure and sym the
1597 if (context_proc
->attr
.contained
)
1599 gfc_symbol
* parent_proc
;
1601 gcc_assert (context
->parent
);
1602 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1603 : context
->parent
->proc_name
);
1605 if (parent_proc
== proc_sym
)
1613 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1614 its typespec and formal argument list. */
1617 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1619 gfc_intrinsic_sym
* isym
= NULL
;
1625 /* Already resolved. */
1626 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1629 /* We already know this one is an intrinsic, so we don't call
1630 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1631 gfc_find_subroutine directly to check whether it is a function or
1634 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1636 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1637 isym
= gfc_intrinsic_subroutine_by_id (id
);
1639 else if (sym
->intmod_sym_id
)
1641 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1642 isym
= gfc_intrinsic_function_by_id (id
);
1644 else if (!sym
->attr
.subroutine
)
1645 isym
= gfc_find_function (sym
->name
);
1647 if (isym
&& !sym
->attr
.subroutine
)
1649 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1650 && !sym
->attr
.implicit_type
)
1651 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1652 " ignored", sym
->name
, &sym
->declared_at
);
1654 if (!sym
->attr
.function
&&
1655 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1660 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1662 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1664 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1665 " specifier", sym
->name
, &sym
->declared_at
);
1669 if (!sym
->attr
.subroutine
&&
1670 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1675 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1680 gfc_copy_formal_args_intr (sym
, isym
);
1682 /* Check it is actually available in the standard settings. */
1683 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1685 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1686 " available in the current standard settings but %s. Use"
1687 " an appropriate -std=* option or enable -fall-intrinsics"
1688 " in order to use it.",
1689 sym
->name
, &sym
->declared_at
, symstd
);
1697 /* Resolve a procedure expression, like passing it to a called procedure or as
1698 RHS for a procedure pointer assignment. */
1701 resolve_procedure_expression (gfc_expr
* expr
)
1705 if (expr
->expr_type
!= EXPR_VARIABLE
)
1707 gcc_assert (expr
->symtree
);
1709 sym
= expr
->symtree
->n
.sym
;
1711 if (sym
->attr
.intrinsic
)
1712 gfc_resolve_intrinsic (sym
, &expr
->where
);
1714 if (sym
->attr
.flavor
!= FL_PROCEDURE
1715 || (sym
->attr
.function
&& sym
->result
== sym
))
1718 /* A non-RECURSIVE procedure that is used as procedure expression within its
1719 own body is in danger of being called recursively. */
1720 if (is_illegal_recursion (sym
, gfc_current_ns
))
1721 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1722 " itself recursively. Declare it RECURSIVE or use"
1723 " -frecursive", sym
->name
, &expr
->where
);
1729 /* Resolve an actual argument list. Most of the time, this is just
1730 resolving the expressions in the list.
1731 The exception is that we sometimes have to decide whether arguments
1732 that look like procedure arguments are really simple variable
1736 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1737 bool no_formal_args
)
1740 gfc_symtree
*parent_st
;
1742 int save_need_full_assumed_size
;
1743 bool return_value
= false;
1744 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1747 first_actual_arg
= true;
1749 for (; arg
; arg
= arg
->next
)
1754 /* Check the label is a valid branching target. */
1757 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1759 gfc_error ("Label %d referenced at %L is never defined",
1760 arg
->label
->value
, &arg
->label
->where
);
1764 first_actual_arg
= false;
1768 if (e
->expr_type
== EXPR_VARIABLE
1769 && e
->symtree
->n
.sym
->attr
.generic
1771 && count_specific_procs (e
) != 1)
1774 if (e
->ts
.type
!= BT_PROCEDURE
)
1776 save_need_full_assumed_size
= need_full_assumed_size
;
1777 if (e
->expr_type
!= EXPR_VARIABLE
)
1778 need_full_assumed_size
= 0;
1779 if (!gfc_resolve_expr (e
))
1781 need_full_assumed_size
= save_need_full_assumed_size
;
1785 /* See if the expression node should really be a variable reference. */
1787 sym
= e
->symtree
->n
.sym
;
1789 if (sym
->attr
.flavor
== FL_PROCEDURE
1790 || sym
->attr
.intrinsic
1791 || sym
->attr
.external
)
1795 /* If a procedure is not already determined to be something else
1796 check if it is intrinsic. */
1797 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1798 sym
->attr
.intrinsic
= 1;
1800 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1802 gfc_error ("Statement function '%s' at %L is not allowed as an "
1803 "actual argument", sym
->name
, &e
->where
);
1806 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1807 sym
->attr
.subroutine
);
1808 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1810 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1811 "actual argument", sym
->name
, &e
->where
);
1814 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1815 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1817 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1818 " used as actual argument at %L",
1819 sym
->name
, &e
->where
))
1823 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1825 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1826 "allowed as an actual argument at %L", sym
->name
,
1830 /* Check if a generic interface has a specific procedure
1831 with the same name before emitting an error. */
1832 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1835 /* Just in case a specific was found for the expression. */
1836 sym
= e
->symtree
->n
.sym
;
1838 /* If the symbol is the function that names the current (or
1839 parent) scope, then we really have a variable reference. */
1841 if (gfc_is_function_return_value (sym
, sym
->ns
))
1844 /* If all else fails, see if we have a specific intrinsic. */
1845 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1847 gfc_intrinsic_sym
*isym
;
1849 isym
= gfc_find_function (sym
->name
);
1850 if (isym
== NULL
|| !isym
->specific
)
1852 gfc_error ("Unable to find a specific INTRINSIC procedure "
1853 "for the reference '%s' at %L", sym
->name
,
1858 sym
->attr
.intrinsic
= 1;
1859 sym
->attr
.function
= 1;
1862 if (!gfc_resolve_expr (e
))
1867 /* See if the name is a module procedure in a parent unit. */
1869 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1872 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1874 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1878 if (parent_st
== NULL
)
1881 sym
= parent_st
->n
.sym
;
1882 e
->symtree
= parent_st
; /* Point to the right thing. */
1884 if (sym
->attr
.flavor
== FL_PROCEDURE
1885 || sym
->attr
.intrinsic
1886 || sym
->attr
.external
)
1888 if (!gfc_resolve_expr (e
))
1894 e
->expr_type
= EXPR_VARIABLE
;
1896 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1897 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1898 && CLASS_DATA (sym
)->as
))
1900 e
->rank
= sym
->ts
.type
== BT_CLASS
1901 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1902 e
->ref
= gfc_get_ref ();
1903 e
->ref
->type
= REF_ARRAY
;
1904 e
->ref
->u
.ar
.type
= AR_FULL
;
1905 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1906 ? CLASS_DATA (sym
)->as
: sym
->as
;
1909 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1910 primary.c (match_actual_arg). If above code determines that it
1911 is a variable instead, it needs to be resolved as it was not
1912 done at the beginning of this function. */
1913 save_need_full_assumed_size
= need_full_assumed_size
;
1914 if (e
->expr_type
!= EXPR_VARIABLE
)
1915 need_full_assumed_size
= 0;
1916 if (!gfc_resolve_expr (e
))
1918 need_full_assumed_size
= save_need_full_assumed_size
;
1921 /* Check argument list functions %VAL, %LOC and %REF. There is
1922 nothing to do for %REF. */
1923 if (arg
->name
&& arg
->name
[0] == '%')
1925 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1927 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1929 gfc_error ("By-value argument at %L is not of numeric "
1936 gfc_error ("By-value argument at %L cannot be an array or "
1937 "an array section", &e
->where
);
1941 /* Intrinsics are still PROC_UNKNOWN here. However,
1942 since same file external procedures are not resolvable
1943 in gfortran, it is a good deal easier to leave them to
1945 if (ptype
!= PROC_UNKNOWN
1946 && ptype
!= PROC_DUMMY
1947 && ptype
!= PROC_EXTERNAL
1948 && ptype
!= PROC_MODULE
)
1950 gfc_error ("By-value argument at %L is not allowed "
1951 "in this context", &e
->where
);
1956 /* Statement functions have already been excluded above. */
1957 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1958 && e
->ts
.type
== BT_PROCEDURE
)
1960 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1962 gfc_error ("Passing internal procedure at %L by location "
1963 "not allowed", &e
->where
);
1969 /* Fortran 2008, C1237. */
1970 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1971 && gfc_has_ultimate_pointer (e
))
1973 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1974 "component", &e
->where
);
1978 first_actual_arg
= false;
1981 return_value
= true;
1984 actual_arg
= actual_arg_sav
;
1985 first_actual_arg
= first_actual_arg_sav
;
1987 return return_value
;
1991 /* Do the checks of the actual argument list that are specific to elemental
1992 procedures. If called with c == NULL, we have a function, otherwise if
1993 expr == NULL, we have a subroutine. */
1996 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1998 gfc_actual_arglist
*arg0
;
1999 gfc_actual_arglist
*arg
;
2000 gfc_symbol
*esym
= NULL
;
2001 gfc_intrinsic_sym
*isym
= NULL
;
2003 gfc_intrinsic_arg
*iformal
= NULL
;
2004 gfc_formal_arglist
*eformal
= NULL
;
2005 bool formal_optional
= false;
2006 bool set_by_optional
= false;
2010 /* Is this an elemental procedure? */
2011 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2013 if (expr
->value
.function
.esym
!= NULL
2014 && expr
->value
.function
.esym
->attr
.elemental
)
2016 arg0
= expr
->value
.function
.actual
;
2017 esym
= expr
->value
.function
.esym
;
2019 else if (expr
->value
.function
.isym
!= NULL
2020 && expr
->value
.function
.isym
->elemental
)
2022 arg0
= expr
->value
.function
.actual
;
2023 isym
= expr
->value
.function
.isym
;
2028 else if (c
&& c
->ext
.actual
!= NULL
)
2030 arg0
= c
->ext
.actual
;
2032 if (c
->resolved_sym
)
2033 esym
= c
->resolved_sym
;
2035 esym
= c
->symtree
->n
.sym
;
2038 if (!esym
->attr
.elemental
)
2044 /* The rank of an elemental is the rank of its array argument(s). */
2045 for (arg
= arg0
; arg
; arg
= arg
->next
)
2047 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2049 rank
= arg
->expr
->rank
;
2050 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2051 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2052 set_by_optional
= true;
2054 /* Function specific; set the result rank and shape. */
2058 if (!expr
->shape
&& arg
->expr
->shape
)
2060 expr
->shape
= gfc_get_shape (rank
);
2061 for (i
= 0; i
< rank
; i
++)
2062 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2069 /* If it is an array, it shall not be supplied as an actual argument
2070 to an elemental procedure unless an array of the same rank is supplied
2071 as an actual argument corresponding to a nonoptional dummy argument of
2072 that elemental procedure(12.4.1.5). */
2073 formal_optional
= false;
2075 iformal
= isym
->formal
;
2077 eformal
= esym
->formal
;
2079 for (arg
= arg0
; arg
; arg
= arg
->next
)
2083 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2084 formal_optional
= true;
2085 eformal
= eformal
->next
;
2087 else if (isym
&& iformal
)
2089 if (iformal
->optional
)
2090 formal_optional
= true;
2091 iformal
= iformal
->next
;
2094 formal_optional
= true;
2096 if (pedantic
&& arg
->expr
!= NULL
2097 && arg
->expr
->expr_type
== EXPR_VARIABLE
2098 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2101 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2102 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2104 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2105 "MISSING, it cannot be the actual argument of an "
2106 "ELEMENTAL procedure unless there is a non-optional "
2107 "argument with the same rank (12.4.1.5)",
2108 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2112 for (arg
= arg0
; arg
; arg
= arg
->next
)
2114 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2117 /* Being elemental, the last upper bound of an assumed size array
2118 argument must be present. */
2119 if (resolve_assumed_size_actual (arg
->expr
))
2122 /* Elemental procedure's array actual arguments must conform. */
2125 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2132 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2133 is an array, the intent inout/out variable needs to be also an array. */
2134 if (rank
> 0 && esym
&& expr
== NULL
)
2135 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2136 arg
= arg
->next
, eformal
= eformal
->next
)
2137 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2138 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2139 && arg
->expr
&& arg
->expr
->rank
== 0)
2141 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2142 "ELEMENTAL subroutine '%s' is a scalar, but another "
2143 "actual argument is an array", &arg
->expr
->where
,
2144 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2145 : "INOUT", eformal
->sym
->name
, esym
->name
);
2152 /* This function does the checking of references to global procedures
2153 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2154 77 and 95 standards. It checks for a gsymbol for the name, making
2155 one if it does not already exist. If it already exists, then the
2156 reference being resolved must correspond to the type of gsymbol.
2157 Otherwise, the new symbol is equipped with the attributes of the
2158 reference. The corresponding code that is called in creating
2159 global entities is parse.c.
2161 In addition, for all but -std=legacy, the gsymbols are used to
2162 check the interfaces of external procedures from the same file.
2163 The namespace of the gsymbol is resolved and then, once this is
2164 done the interface is checked. */
2168 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2170 if (!gsym_ns
->proc_name
->attr
.recursive
)
2173 if (sym
->ns
== gsym_ns
)
2176 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2183 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2185 if (gsym_ns
->entries
)
2187 gfc_entry_list
*entry
= gsym_ns
->entries
;
2189 for (; entry
; entry
= entry
->next
)
2191 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2193 if (strcmp (gsym_ns
->proc_name
->name
,
2194 sym
->ns
->proc_name
->name
) == 0)
2198 && strcmp (gsym_ns
->proc_name
->name
,
2199 sym
->ns
->parent
->proc_name
->name
) == 0)
2208 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2211 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2213 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2215 for ( ; arg
; arg
= arg
->next
)
2220 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2222 strncpy (errmsg
, _("allocatable argument"), err_len
);
2225 else if (arg
->sym
->attr
.asynchronous
)
2227 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2230 else if (arg
->sym
->attr
.optional
)
2232 strncpy (errmsg
, _("optional argument"), err_len
);
2235 else if (arg
->sym
->attr
.pointer
)
2237 strncpy (errmsg
, _("pointer argument"), err_len
);
2240 else if (arg
->sym
->attr
.target
)
2242 strncpy (errmsg
, _("target argument"), err_len
);
2245 else if (arg
->sym
->attr
.value
)
2247 strncpy (errmsg
, _("value argument"), err_len
);
2250 else if (arg
->sym
->attr
.volatile_
)
2252 strncpy (errmsg
, _("volatile argument"), err_len
);
2255 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2257 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2260 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2262 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2265 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2267 strncpy (errmsg
, _("coarray argument"), err_len
);
2270 else if (false) /* (2d) TODO: parametrized derived type */
2272 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2275 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2277 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2280 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2282 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2285 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2287 /* As assumed-type is unlimited polymorphic (cf. above).
2288 See also TS 29113, Note 6.1. */
2289 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2294 if (sym
->attr
.function
)
2296 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2298 if (res
->attr
.dimension
) /* (3a) */
2300 strncpy (errmsg
, _("array result"), err_len
);
2303 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2305 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2308 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2309 && res
->ts
.u
.cl
->length
2310 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2312 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2317 if (sym
->attr
.elemental
) /* (4) */
2319 strncpy (errmsg
, _("elemental procedure"), err_len
);
2322 else if (sym
->attr
.is_bind_c
) /* (5) */
2324 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2333 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2334 gfc_actual_arglist
**actual
, int sub
)
2338 enum gfc_symbol_type type
;
2341 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2343 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2345 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2346 gfc_global_used (gsym
, where
);
2348 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2349 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2350 && gsym
->type
!= GSYM_UNKNOWN
2352 && gsym
->ns
->resolved
!= -1
2353 && gsym
->ns
->proc_name
2354 && not_in_recursive (sym
, gsym
->ns
)
2355 && not_entry_self_reference (sym
, gsym
->ns
))
2357 gfc_symbol
*def_sym
;
2359 /* Resolve the gsymbol namespace if needed. */
2360 if (!gsym
->ns
->resolved
)
2362 gfc_dt_list
*old_dt_list
;
2363 struct gfc_omp_saved_state old_omp_state
;
2365 /* Stash away derived types so that the backend_decls do not
2367 old_dt_list
= gfc_derived_types
;
2368 gfc_derived_types
= NULL
;
2369 /* And stash away openmp state. */
2370 gfc_omp_save_and_clear_state (&old_omp_state
);
2372 gfc_resolve (gsym
->ns
);
2374 /* Store the new derived types with the global namespace. */
2375 if (gfc_derived_types
)
2376 gsym
->ns
->derived_types
= gfc_derived_types
;
2378 /* Restore the derived types of this namespace. */
2379 gfc_derived_types
= old_dt_list
;
2380 /* And openmp state. */
2381 gfc_omp_restore_state (&old_omp_state
);
2384 /* Make sure that translation for the gsymbol occurs before
2385 the procedure currently being resolved. */
2386 ns
= gfc_global_ns_list
;
2387 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2389 if (ns
->sibling
== gsym
->ns
)
2391 ns
->sibling
= gsym
->ns
->sibling
;
2392 gsym
->ns
->sibling
= gfc_global_ns_list
;
2393 gfc_global_ns_list
= gsym
->ns
;
2398 def_sym
= gsym
->ns
->proc_name
;
2400 /* This can happen if a binding name has been specified. */
2401 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2402 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2404 if (def_sym
->attr
.entry_master
)
2406 gfc_entry_list
*entry
;
2407 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2408 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2410 def_sym
= entry
->sym
;
2415 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2417 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2418 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2419 gfc_typename (&def_sym
->ts
));
2423 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2424 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2426 gfc_error ("Explicit interface required for '%s' at %L: %s",
2427 sym
->name
, &sym
->declared_at
, reason
);
2431 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2432 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2433 gfc_errors_to_warnings (1);
2435 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2436 reason
, sizeof(reason
), NULL
, NULL
))
2438 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2439 sym
->name
, &sym
->declared_at
, reason
);
2444 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2445 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2446 gfc_errors_to_warnings (1);
2448 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2449 gfc_procedure_use (def_sym
, actual
, where
);
2453 gfc_errors_to_warnings (0);
2455 if (gsym
->type
== GSYM_UNKNOWN
)
2458 gsym
->where
= *where
;
2465 /************* Function resolution *************/
2467 /* Resolve a function call known to be generic.
2468 Section 14.1.2.4.1. */
2471 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2475 if (sym
->attr
.generic
)
2477 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2480 expr
->value
.function
.name
= s
->name
;
2481 expr
->value
.function
.esym
= s
;
2483 if (s
->ts
.type
!= BT_UNKNOWN
)
2485 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2486 expr
->ts
= s
->result
->ts
;
2489 expr
->rank
= s
->as
->rank
;
2490 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2491 expr
->rank
= s
->result
->as
->rank
;
2493 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2498 /* TODO: Need to search for elemental references in generic
2502 if (sym
->attr
.intrinsic
)
2503 return gfc_intrinsic_func_interface (expr
, 0);
2510 resolve_generic_f (gfc_expr
*expr
)
2514 gfc_interface
*intr
= NULL
;
2516 sym
= expr
->symtree
->n
.sym
;
2520 m
= resolve_generic_f0 (expr
, sym
);
2523 else if (m
== MATCH_ERROR
)
2528 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2529 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2532 if (sym
->ns
->parent
== NULL
)
2534 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2538 if (!generic_sym (sym
))
2542 /* Last ditch attempt. See if the reference is to an intrinsic
2543 that possesses a matching interface. 14.1.2.4 */
2544 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2546 gfc_error ("There is no specific function for the generic '%s' "
2547 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2553 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2556 return resolve_structure_cons (expr
, 0);
2559 m
= gfc_intrinsic_func_interface (expr
, 0);
2564 gfc_error ("Generic function '%s' at %L is not consistent with a "
2565 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2572 /* Resolve a function call known to be specific. */
2575 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2579 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2581 if (sym
->attr
.dummy
)
2583 sym
->attr
.proc
= PROC_DUMMY
;
2587 sym
->attr
.proc
= PROC_EXTERNAL
;
2591 if (sym
->attr
.proc
== PROC_MODULE
2592 || sym
->attr
.proc
== PROC_ST_FUNCTION
2593 || sym
->attr
.proc
== PROC_INTERNAL
)
2596 if (sym
->attr
.intrinsic
)
2598 m
= gfc_intrinsic_func_interface (expr
, 1);
2602 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2603 "with an intrinsic", sym
->name
, &expr
->where
);
2611 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2614 expr
->ts
= sym
->result
->ts
;
2617 expr
->value
.function
.name
= sym
->name
;
2618 expr
->value
.function
.esym
= sym
;
2619 if (sym
->as
!= NULL
)
2620 expr
->rank
= sym
->as
->rank
;
2627 resolve_specific_f (gfc_expr
*expr
)
2632 sym
= expr
->symtree
->n
.sym
;
2636 m
= resolve_specific_f0 (sym
, expr
);
2639 if (m
== MATCH_ERROR
)
2642 if (sym
->ns
->parent
== NULL
)
2645 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2651 gfc_error ("Unable to resolve the specific function '%s' at %L",
2652 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2658 /* Resolve a procedure call not known to be generic nor specific. */
2661 resolve_unknown_f (gfc_expr
*expr
)
2666 sym
= expr
->symtree
->n
.sym
;
2668 if (sym
->attr
.dummy
)
2670 sym
->attr
.proc
= PROC_DUMMY
;
2671 expr
->value
.function
.name
= sym
->name
;
2675 /* See if we have an intrinsic function reference. */
2677 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2679 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2684 /* The reference is to an external name. */
2686 sym
->attr
.proc
= PROC_EXTERNAL
;
2687 expr
->value
.function
.name
= sym
->name
;
2688 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2690 if (sym
->as
!= NULL
)
2691 expr
->rank
= sym
->as
->rank
;
2693 /* Type of the expression is either the type of the symbol or the
2694 default type of the symbol. */
2697 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2699 if (sym
->ts
.type
!= BT_UNKNOWN
)
2703 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2705 if (ts
->type
== BT_UNKNOWN
)
2707 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2708 sym
->name
, &expr
->where
);
2719 /* Return true, if the symbol is an external procedure. */
2721 is_external_proc (gfc_symbol
*sym
)
2723 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2724 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2725 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2726 && !sym
->attr
.proc_pointer
2727 && !sym
->attr
.use_assoc
2735 /* Figure out if a function reference is pure or not. Also set the name
2736 of the function for a potential error message. Return nonzero if the
2737 function is PURE, zero if not. */
2739 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2742 pure_function (gfc_expr
*e
, const char **name
)
2748 if (e
->symtree
!= NULL
2749 && e
->symtree
->n
.sym
!= NULL
2750 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2751 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2753 if (e
->value
.function
.esym
)
2755 pure
= gfc_pure (e
->value
.function
.esym
);
2756 *name
= e
->value
.function
.esym
->name
;
2758 else if (e
->value
.function
.isym
)
2760 pure
= e
->value
.function
.isym
->pure
2761 || e
->value
.function
.isym
->elemental
;
2762 *name
= e
->value
.function
.isym
->name
;
2766 /* Implicit functions are not pure. */
2768 *name
= e
->value
.function
.name
;
2776 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2777 int *f ATTRIBUTE_UNUSED
)
2781 /* Don't bother recursing into other statement functions
2782 since they will be checked individually for purity. */
2783 if (e
->expr_type
!= EXPR_FUNCTION
2785 || e
->symtree
->n
.sym
== sym
2786 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2789 return pure_function (e
, &name
) ? false : true;
2794 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2796 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2800 /* Resolve a function call, which means resolving the arguments, then figuring
2801 out which entity the name refers to. */
2804 resolve_function (gfc_expr
*expr
)
2806 gfc_actual_arglist
*arg
;
2811 procedure_type p
= PROC_INTRINSIC
;
2812 bool no_formal_args
;
2816 sym
= expr
->symtree
->n
.sym
;
2818 /* If this is a procedure pointer component, it has already been resolved. */
2819 if (gfc_is_proc_ptr_comp (expr
))
2822 if (sym
&& sym
->attr
.intrinsic
2823 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2826 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2828 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2832 /* If this ia a deferred TBP with an abstract interface (which may
2833 of course be referenced), expr->value.function.esym will be set. */
2834 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2836 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2837 sym
->name
, &expr
->where
);
2841 /* Switch off assumed size checking and do this again for certain kinds
2842 of procedure, once the procedure itself is resolved. */
2843 need_full_assumed_size
++;
2845 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2846 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2848 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2849 inquiry_argument
= true;
2850 no_formal_args
= sym
&& is_external_proc (sym
)
2851 && gfc_sym_get_dummy_args (sym
) == NULL
;
2853 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2856 inquiry_argument
= false;
2860 inquiry_argument
= false;
2862 /* Resume assumed_size checking. */
2863 need_full_assumed_size
--;
2865 /* If the procedure is external, check for usage. */
2866 if (sym
&& is_external_proc (sym
))
2867 resolve_global_procedure (sym
, &expr
->where
,
2868 &expr
->value
.function
.actual
, 0);
2870 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2872 && sym
->ts
.u
.cl
->length
== NULL
2874 && !sym
->ts
.deferred
2875 && expr
->value
.function
.esym
== NULL
2876 && !sym
->attr
.contained
)
2878 /* Internal procedures are taken care of in resolve_contained_fntype. */
2879 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2880 "be used at %L since it is not a dummy argument",
2881 sym
->name
, &expr
->where
);
2885 /* See if function is already resolved. */
2887 if (expr
->value
.function
.name
!= NULL
)
2889 if (expr
->ts
.type
== BT_UNKNOWN
)
2895 /* Apply the rules of section 14.1.2. */
2897 switch (procedure_kind (sym
))
2900 t
= resolve_generic_f (expr
);
2903 case PTYPE_SPECIFIC
:
2904 t
= resolve_specific_f (expr
);
2908 t
= resolve_unknown_f (expr
);
2912 gfc_internal_error ("resolve_function(): bad function type");
2916 /* If the expression is still a function (it might have simplified),
2917 then we check to see if we are calling an elemental function. */
2919 if (expr
->expr_type
!= EXPR_FUNCTION
)
2922 temp
= need_full_assumed_size
;
2923 need_full_assumed_size
= 0;
2925 if (!resolve_elemental_actual (expr
, NULL
))
2928 if (omp_workshare_flag
2929 && expr
->value
.function
.esym
2930 && ! gfc_elemental (expr
->value
.function
.esym
))
2932 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2933 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2938 #define GENERIC_ID expr->value.function.isym->id
2939 else if (expr
->value
.function
.actual
!= NULL
2940 && expr
->value
.function
.isym
!= NULL
2941 && GENERIC_ID
!= GFC_ISYM_LBOUND
2942 && GENERIC_ID
!= GFC_ISYM_LEN
2943 && GENERIC_ID
!= GFC_ISYM_LOC
2944 && GENERIC_ID
!= GFC_ISYM_C_LOC
2945 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2947 /* Array intrinsics must also have the last upper bound of an
2948 assumed size array argument. UBOUND and SIZE have to be
2949 excluded from the check if the second argument is anything
2952 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2954 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2955 && arg
== expr
->value
.function
.actual
2956 && arg
->next
!= NULL
&& arg
->next
->expr
)
2958 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2961 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2964 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2969 if (arg
->expr
!= NULL
2970 && arg
->expr
->rank
> 0
2971 && resolve_assumed_size_actual (arg
->expr
))
2977 need_full_assumed_size
= temp
;
2980 if (!pure_function (expr
, &name
) && name
)
2984 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2985 "FORALL %s", name
, &expr
->where
,
2986 forall_flag
== 2 ? "mask" : "block");
2989 else if (gfc_do_concurrent_flag
)
2991 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2992 "DO CONCURRENT %s", name
, &expr
->where
,
2993 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2996 else if (gfc_pure (NULL
))
2998 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2999 "procedure within a PURE procedure", name
, &expr
->where
);
3003 if (gfc_implicit_pure (NULL
))
3004 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3007 /* Functions without the RECURSIVE attribution are not allowed to
3008 * call themselves. */
3009 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3012 esym
= expr
->value
.function
.esym
;
3014 if (is_illegal_recursion (esym
, gfc_current_ns
))
3016 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3017 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3018 " function '%s' is not RECURSIVE",
3019 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3021 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3022 " is not RECURSIVE", esym
->name
, &expr
->where
);
3028 /* Character lengths of use associated functions may contains references to
3029 symbols not referenced from the current program unit otherwise. Make sure
3030 those symbols are marked as referenced. */
3032 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3033 && expr
->value
.function
.esym
->attr
.use_assoc
)
3035 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3038 /* Make sure that the expression has a typespec that works. */
3039 if (expr
->ts
.type
== BT_UNKNOWN
)
3041 if (expr
->symtree
->n
.sym
->result
3042 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3043 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3044 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3051 /************* Subroutine resolution *************/
3054 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3060 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3061 sym
->name
, &c
->loc
);
3062 else if (gfc_do_concurrent_flag
)
3063 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3064 "PURE", sym
->name
, &c
->loc
);
3065 else if (gfc_pure (NULL
))
3066 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3069 if (gfc_implicit_pure (NULL
))
3070 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3075 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3079 if (sym
->attr
.generic
)
3081 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3084 c
->resolved_sym
= s
;
3085 pure_subroutine (c
, s
);
3089 /* TODO: Need to search for elemental references in generic interface. */
3092 if (sym
->attr
.intrinsic
)
3093 return gfc_intrinsic_sub_interface (c
, 0);
3100 resolve_generic_s (gfc_code
*c
)
3105 sym
= c
->symtree
->n
.sym
;
3109 m
= resolve_generic_s0 (c
, sym
);
3112 else if (m
== MATCH_ERROR
)
3116 if (sym
->ns
->parent
== NULL
)
3118 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3122 if (!generic_sym (sym
))
3126 /* Last ditch attempt. See if the reference is to an intrinsic
3127 that possesses a matching interface. 14.1.2.4 */
3128 sym
= c
->symtree
->n
.sym
;
3130 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3132 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3133 sym
->name
, &c
->loc
);
3137 m
= gfc_intrinsic_sub_interface (c
, 0);
3141 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3142 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3148 /* Resolve a subroutine call known to be specific. */
3151 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3155 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3157 if (sym
->attr
.dummy
)
3159 sym
->attr
.proc
= PROC_DUMMY
;
3163 sym
->attr
.proc
= PROC_EXTERNAL
;
3167 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3170 if (sym
->attr
.intrinsic
)
3172 m
= gfc_intrinsic_sub_interface (c
, 1);
3176 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3177 "with an intrinsic", sym
->name
, &c
->loc
);
3185 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3187 c
->resolved_sym
= sym
;
3188 pure_subroutine (c
, sym
);
3195 resolve_specific_s (gfc_code
*c
)
3200 sym
= c
->symtree
->n
.sym
;
3204 m
= resolve_specific_s0 (c
, sym
);
3207 if (m
== MATCH_ERROR
)
3210 if (sym
->ns
->parent
== NULL
)
3213 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3219 sym
= c
->symtree
->n
.sym
;
3220 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3221 sym
->name
, &c
->loc
);
3227 /* Resolve a subroutine call not known to be generic nor specific. */
3230 resolve_unknown_s (gfc_code
*c
)
3234 sym
= c
->symtree
->n
.sym
;
3236 if (sym
->attr
.dummy
)
3238 sym
->attr
.proc
= PROC_DUMMY
;
3242 /* See if we have an intrinsic function reference. */
3244 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3246 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3251 /* The reference is to an external name. */
3254 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3256 c
->resolved_sym
= sym
;
3258 pure_subroutine (c
, sym
);
3264 /* Resolve a subroutine call. Although it was tempting to use the same code
3265 for functions, subroutines and functions are stored differently and this
3266 makes things awkward. */
3269 resolve_call (gfc_code
*c
)
3272 procedure_type ptype
= PROC_INTRINSIC
;
3273 gfc_symbol
*csym
, *sym
;
3274 bool no_formal_args
;
3276 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3278 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3280 gfc_error ("'%s' at %L has a type, which is not consistent with "
3281 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3285 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3288 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3289 sym
= st
? st
->n
.sym
: NULL
;
3290 if (sym
&& csym
!= sym
3291 && sym
->ns
== gfc_current_ns
3292 && sym
->attr
.flavor
== FL_PROCEDURE
3293 && sym
->attr
.contained
)
3296 if (csym
->attr
.generic
)
3297 c
->symtree
->n
.sym
= sym
;
3300 csym
= c
->symtree
->n
.sym
;
3304 /* If this ia a deferred TBP, c->expr1 will be set. */
3305 if (!c
->expr1
&& csym
)
3307 if (csym
->attr
.abstract
)
3309 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3310 csym
->name
, &c
->loc
);
3314 /* Subroutines without the RECURSIVE attribution are not allowed to
3316 if (is_illegal_recursion (csym
, gfc_current_ns
))
3318 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3319 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3320 "as subroutine '%s' is not RECURSIVE",
3321 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3323 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3324 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3330 /* Switch off assumed size checking and do this again for certain kinds
3331 of procedure, once the procedure itself is resolved. */
3332 need_full_assumed_size
++;
3335 ptype
= csym
->attr
.proc
;
3337 no_formal_args
= csym
&& is_external_proc (csym
)
3338 && gfc_sym_get_dummy_args (csym
) == NULL
;
3339 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3342 /* Resume assumed_size checking. */
3343 need_full_assumed_size
--;
3345 /* If external, check for usage. */
3346 if (csym
&& is_external_proc (csym
))
3347 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3350 if (c
->resolved_sym
== NULL
)
3352 c
->resolved_isym
= NULL
;
3353 switch (procedure_kind (csym
))
3356 t
= resolve_generic_s (c
);
3359 case PTYPE_SPECIFIC
:
3360 t
= resolve_specific_s (c
);
3364 t
= resolve_unknown_s (c
);
3368 gfc_internal_error ("resolve_subroutine(): bad function type");
3372 /* Some checks of elemental subroutine actual arguments. */
3373 if (!resolve_elemental_actual (NULL
, c
))
3380 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3381 op1->shape and op2->shape are non-NULL return true if their shapes
3382 match. If both op1->shape and op2->shape are non-NULL return false
3383 if their shapes do not match. If either op1->shape or op2->shape is
3384 NULL, return true. */
3387 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3394 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3396 for (i
= 0; i
< op1
->rank
; i
++)
3398 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3400 gfc_error ("Shapes for operands at %L and %L are not conformable",
3401 &op1
->where
, &op2
->where
);
3412 /* Resolve an operator expression node. This can involve replacing the
3413 operation with a user defined function call. */
3416 resolve_operator (gfc_expr
*e
)
3418 gfc_expr
*op1
, *op2
;
3420 bool dual_locus_error
;
3423 /* Resolve all subnodes-- give them types. */
3425 switch (e
->value
.op
.op
)
3428 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3431 /* Fall through... */
3434 case INTRINSIC_UPLUS
:
3435 case INTRINSIC_UMINUS
:
3436 case INTRINSIC_PARENTHESES
:
3437 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3442 /* Typecheck the new node. */
3444 op1
= e
->value
.op
.op1
;
3445 op2
= e
->value
.op
.op2
;
3446 dual_locus_error
= false;
3448 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3449 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3451 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3455 switch (e
->value
.op
.op
)
3457 case INTRINSIC_UPLUS
:
3458 case INTRINSIC_UMINUS
:
3459 if (op1
->ts
.type
== BT_INTEGER
3460 || op1
->ts
.type
== BT_REAL
3461 || op1
->ts
.type
== BT_COMPLEX
)
3467 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3468 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3471 case INTRINSIC_PLUS
:
3472 case INTRINSIC_MINUS
:
3473 case INTRINSIC_TIMES
:
3474 case INTRINSIC_DIVIDE
:
3475 case INTRINSIC_POWER
:
3476 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3478 gfc_type_convert_binary (e
, 1);
3483 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3484 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3485 gfc_typename (&op2
->ts
));
3488 case INTRINSIC_CONCAT
:
3489 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3490 && op1
->ts
.kind
== op2
->ts
.kind
)
3492 e
->ts
.type
= BT_CHARACTER
;
3493 e
->ts
.kind
= op1
->ts
.kind
;
3498 _("Operands of string concatenation operator at %%L are %s/%s"),
3499 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3505 case INTRINSIC_NEQV
:
3506 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3508 e
->ts
.type
= BT_LOGICAL
;
3509 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3510 if (op1
->ts
.kind
< e
->ts
.kind
)
3511 gfc_convert_type (op1
, &e
->ts
, 2);
3512 else if (op2
->ts
.kind
< e
->ts
.kind
)
3513 gfc_convert_type (op2
, &e
->ts
, 2);
3517 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3518 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3519 gfc_typename (&op2
->ts
));
3524 if (op1
->ts
.type
== BT_LOGICAL
)
3526 e
->ts
.type
= BT_LOGICAL
;
3527 e
->ts
.kind
= op1
->ts
.kind
;
3531 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3532 gfc_typename (&op1
->ts
));
3536 case INTRINSIC_GT_OS
:
3538 case INTRINSIC_GE_OS
:
3540 case INTRINSIC_LT_OS
:
3542 case INTRINSIC_LE_OS
:
3543 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3545 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3549 /* Fall through... */
3552 case INTRINSIC_EQ_OS
:
3554 case INTRINSIC_NE_OS
:
3555 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3556 && op1
->ts
.kind
== op2
->ts
.kind
)
3558 e
->ts
.type
= BT_LOGICAL
;
3559 e
->ts
.kind
= gfc_default_logical_kind
;
3563 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3565 gfc_type_convert_binary (e
, 1);
3567 e
->ts
.type
= BT_LOGICAL
;
3568 e
->ts
.kind
= gfc_default_logical_kind
;
3570 if (gfc_option
.warn_compare_reals
)
3572 gfc_intrinsic_op op
= e
->value
.op
.op
;
3574 /* Type conversion has made sure that the types of op1 and op2
3575 agree, so it is only necessary to check the first one. */
3576 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3577 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3578 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3582 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3583 msg
= "Equality comparison for %s at %L";
3585 msg
= "Inequality comparison for %s at %L";
3587 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3594 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3596 _("Logicals at %%L must be compared with %s instead of %s"),
3597 (e
->value
.op
.op
== INTRINSIC_EQ
3598 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3599 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3602 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3603 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3604 gfc_typename (&op2
->ts
));
3608 case INTRINSIC_USER
:
3609 if (e
->value
.op
.uop
->op
== NULL
)
3610 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3611 else if (op2
== NULL
)
3612 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3613 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3616 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3617 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3618 gfc_typename (&op2
->ts
));
3619 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3624 case INTRINSIC_PARENTHESES
:
3626 if (e
->ts
.type
== BT_CHARACTER
)
3627 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3631 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3634 /* Deal with arrayness of an operand through an operator. */
3638 switch (e
->value
.op
.op
)
3640 case INTRINSIC_PLUS
:
3641 case INTRINSIC_MINUS
:
3642 case INTRINSIC_TIMES
:
3643 case INTRINSIC_DIVIDE
:
3644 case INTRINSIC_POWER
:
3645 case INTRINSIC_CONCAT
:
3649 case INTRINSIC_NEQV
:
3651 case INTRINSIC_EQ_OS
:
3653 case INTRINSIC_NE_OS
:
3655 case INTRINSIC_GT_OS
:
3657 case INTRINSIC_GE_OS
:
3659 case INTRINSIC_LT_OS
:
3661 case INTRINSIC_LE_OS
:
3663 if (op1
->rank
== 0 && op2
->rank
== 0)
3666 if (op1
->rank
== 0 && op2
->rank
!= 0)
3668 e
->rank
= op2
->rank
;
3670 if (e
->shape
== NULL
)
3671 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3674 if (op1
->rank
!= 0 && op2
->rank
== 0)
3676 e
->rank
= op1
->rank
;
3678 if (e
->shape
== NULL
)
3679 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3682 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3684 if (op1
->rank
== op2
->rank
)
3686 e
->rank
= op1
->rank
;
3687 if (e
->shape
== NULL
)
3689 t
= compare_shapes (op1
, op2
);
3693 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3698 /* Allow higher level expressions to work. */
3701 /* Try user-defined operators, and otherwise throw an error. */
3702 dual_locus_error
= true;
3704 _("Inconsistent ranks for operator at %%L and %%L"));
3711 case INTRINSIC_PARENTHESES
:
3713 case INTRINSIC_UPLUS
:
3714 case INTRINSIC_UMINUS
:
3715 /* Simply copy arrayness attribute */
3716 e
->rank
= op1
->rank
;
3718 if (e
->shape
== NULL
)
3719 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3727 /* Attempt to simplify the expression. */
3730 t
= gfc_simplify_expr (e
, 0);
3731 /* Some calls do not succeed in simplification and return false
3732 even though there is no error; e.g. variable references to
3733 PARAMETER arrays. */
3734 if (!gfc_is_constant_expr (e
))
3742 match m
= gfc_extend_expr (e
);
3745 if (m
== MATCH_ERROR
)
3749 if (dual_locus_error
)
3750 gfc_error (msg
, &op1
->where
, &op2
->where
);
3752 gfc_error (msg
, &e
->where
);
3758 /************** Array resolution subroutines **************/
3761 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3764 /* Compare two integer expressions. */
3767 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3771 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3772 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3775 /* If either of the types isn't INTEGER, we must have
3776 raised an error earlier. */
3778 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3781 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3791 /* Compare an integer expression with an integer. */
3794 compare_bound_int (gfc_expr
*a
, int b
)
3798 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3801 if (a
->ts
.type
!= BT_INTEGER
)
3802 gfc_internal_error ("compare_bound_int(): Bad expression");
3804 i
= mpz_cmp_si (a
->value
.integer
, b
);
3814 /* Compare an integer expression with a mpz_t. */
3817 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3821 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3824 if (a
->ts
.type
!= BT_INTEGER
)
3825 gfc_internal_error ("compare_bound_int(): Bad expression");
3827 i
= mpz_cmp (a
->value
.integer
, b
);
3837 /* Compute the last value of a sequence given by a triplet.
3838 Return 0 if it wasn't able to compute the last value, or if the
3839 sequence if empty, and 1 otherwise. */
3842 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3843 gfc_expr
*stride
, mpz_t last
)
3847 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3848 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3849 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3852 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3853 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3856 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3858 if (compare_bound (start
, end
) == CMP_GT
)
3860 mpz_set (last
, end
->value
.integer
);
3864 if (compare_bound_int (stride
, 0) == CMP_GT
)
3866 /* Stride is positive */
3867 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3872 /* Stride is negative */
3873 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3878 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3879 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3880 mpz_sub (last
, end
->value
.integer
, rem
);
3887 /* Compare a single dimension of an array reference to the array
3891 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3895 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3897 gcc_assert (ar
->stride
[i
] == NULL
);
3898 /* This implies [*] as [*:] and [*:3] are not possible. */
3899 if (ar
->start
[i
] == NULL
)
3901 gcc_assert (ar
->end
[i
] == NULL
);
3906 /* Given start, end and stride values, calculate the minimum and
3907 maximum referenced indexes. */
3909 switch (ar
->dimen_type
[i
])
3912 case DIMEN_THIS_IMAGE
:
3917 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3920 gfc_warning ("Array reference at %L is out of bounds "
3921 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3922 mpz_get_si (ar
->start
[i
]->value
.integer
),
3923 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3925 gfc_warning ("Array reference at %L is out of bounds "
3926 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3927 mpz_get_si (ar
->start
[i
]->value
.integer
),
3928 mpz_get_si (as
->lower
[i
]->value
.integer
),
3932 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3935 gfc_warning ("Array reference at %L is out of bounds "
3936 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3937 mpz_get_si (ar
->start
[i
]->value
.integer
),
3938 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3940 gfc_warning ("Array reference at %L is out of bounds "
3941 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3942 mpz_get_si (ar
->start
[i
]->value
.integer
),
3943 mpz_get_si (as
->upper
[i
]->value
.integer
),
3952 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3953 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3955 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3957 /* Check for zero stride, which is not allowed. */
3958 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3960 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3964 /* if start == len || (stride > 0 && start < len)
3965 || (stride < 0 && start > len),
3966 then the array section contains at least one element. In this
3967 case, there is an out-of-bounds access if
3968 (start < lower || start > upper). */
3969 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3970 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3971 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3972 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3973 && comp_start_end
== CMP_GT
))
3975 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3977 gfc_warning ("Lower array reference at %L is out of bounds "
3978 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3979 mpz_get_si (AR_START
->value
.integer
),
3980 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3983 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3985 gfc_warning ("Lower array reference at %L is out of bounds "
3986 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3987 mpz_get_si (AR_START
->value
.integer
),
3988 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3993 /* If we can compute the highest index of the array section,
3994 then it also has to be between lower and upper. */
3995 mpz_init (last_value
);
3996 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3999 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4001 gfc_warning ("Upper array reference at %L is out of bounds "
4002 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4003 mpz_get_si (last_value
),
4004 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4005 mpz_clear (last_value
);
4008 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4010 gfc_warning ("Upper array reference at %L is out of bounds "
4011 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4012 mpz_get_si (last_value
),
4013 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4014 mpz_clear (last_value
);
4018 mpz_clear (last_value
);
4026 gfc_internal_error ("check_dimension(): Bad array reference");
4033 /* Compare an array reference with an array specification. */
4036 compare_spec_to_ref (gfc_array_ref
*ar
)
4043 /* TODO: Full array sections are only allowed as actual parameters. */
4044 if (as
->type
== AS_ASSUMED_SIZE
4045 && (/*ar->type == AR_FULL
4046 ||*/ (ar
->type
== AR_SECTION
4047 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4049 gfc_error ("Rightmost upper bound of assumed size array section "
4050 "not specified at %L", &ar
->where
);
4054 if (ar
->type
== AR_FULL
)
4057 if (as
->rank
!= ar
->dimen
)
4059 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4060 &ar
->where
, ar
->dimen
, as
->rank
);
4064 /* ar->codimen == 0 is a local array. */
4065 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4067 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4068 &ar
->where
, ar
->codimen
, as
->corank
);
4072 for (i
= 0; i
< as
->rank
; i
++)
4073 if (!check_dimension (i
, ar
, as
))
4076 /* Local access has no coarray spec. */
4077 if (ar
->codimen
!= 0)
4078 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4080 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4081 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4083 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4084 i
+ 1 - as
->rank
, &ar
->where
);
4087 if (!check_dimension (i
, ar
, as
))
4095 /* Resolve one part of an array index. */
4098 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4099 int force_index_integer_kind
)
4106 if (!gfc_resolve_expr (index
))
4109 if (check_scalar
&& index
->rank
!= 0)
4111 gfc_error ("Array index at %L must be scalar", &index
->where
);
4115 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4117 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4118 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4122 if (index
->ts
.type
== BT_REAL
)
4123 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4127 if ((index
->ts
.kind
!= gfc_index_integer_kind
4128 && force_index_integer_kind
)
4129 || index
->ts
.type
!= BT_INTEGER
)
4132 ts
.type
= BT_INTEGER
;
4133 ts
.kind
= gfc_index_integer_kind
;
4135 gfc_convert_type_warn (index
, &ts
, 2, 0);
4141 /* Resolve one part of an array index. */
4144 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4146 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4149 /* Resolve a dim argument to an intrinsic function. */
4152 gfc_resolve_dim_arg (gfc_expr
*dim
)
4157 if (!gfc_resolve_expr (dim
))
4162 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4167 if (dim
->ts
.type
!= BT_INTEGER
)
4169 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4173 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4178 ts
.type
= BT_INTEGER
;
4179 ts
.kind
= gfc_index_integer_kind
;
4181 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4187 /* Given an expression that contains array references, update those array
4188 references to point to the right array specifications. While this is
4189 filled in during matching, this information is difficult to save and load
4190 in a module, so we take care of it here.
4192 The idea here is that the original array reference comes from the
4193 base symbol. We traverse the list of reference structures, setting
4194 the stored reference to references. Component references can
4195 provide an additional array specification. */
4198 find_array_spec (gfc_expr
*e
)
4204 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4205 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4207 as
= e
->symtree
->n
.sym
->as
;
4209 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4214 gfc_internal_error ("find_array_spec(): Missing spec");
4221 c
= ref
->u
.c
.component
;
4222 if (c
->attr
.dimension
)
4225 gfc_internal_error ("find_array_spec(): unused as(1)");
4236 gfc_internal_error ("find_array_spec(): unused as(2)");
4240 /* Resolve an array reference. */
4243 resolve_array_ref (gfc_array_ref
*ar
)
4245 int i
, check_scalar
;
4248 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4250 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4252 /* Do not force gfc_index_integer_kind for the start. We can
4253 do fine with any integer kind. This avoids temporary arrays
4254 created for indexing with a vector. */
4255 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4257 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4259 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4264 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4268 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4272 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4273 if (e
->expr_type
== EXPR_VARIABLE
4274 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4275 ar
->start
[i
] = gfc_get_parentheses (e
);
4279 gfc_error ("Array index at %L is an array of rank %d",
4280 &ar
->c_where
[i
], e
->rank
);
4284 /* Fill in the upper bound, which may be lower than the
4285 specified one for something like a(2:10:5), which is
4286 identical to a(2:7:5). Only relevant for strides not equal
4287 to one. Don't try a division by zero. */
4288 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4289 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4290 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4291 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4295 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4297 if (ar
->end
[i
] == NULL
)
4300 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4302 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4304 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4305 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4307 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4318 if (ar
->type
== AR_FULL
)
4320 if (ar
->as
->rank
== 0)
4321 ar
->type
= AR_ELEMENT
;
4323 /* Make sure array is the same as array(:,:), this way
4324 we don't need to special case all the time. */
4325 ar
->dimen
= ar
->as
->rank
;
4326 for (i
= 0; i
< ar
->dimen
; i
++)
4328 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4330 gcc_assert (ar
->start
[i
] == NULL
);
4331 gcc_assert (ar
->end
[i
] == NULL
);
4332 gcc_assert (ar
->stride
[i
] == NULL
);
4336 /* If the reference type is unknown, figure out what kind it is. */
4338 if (ar
->type
== AR_UNKNOWN
)
4340 ar
->type
= AR_ELEMENT
;
4341 for (i
= 0; i
< ar
->dimen
; i
++)
4342 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4343 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4345 ar
->type
= AR_SECTION
;
4350 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4353 if (ar
->as
->corank
&& ar
->codimen
== 0)
4356 ar
->codimen
= ar
->as
->corank
;
4357 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4358 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4366 resolve_substring (gfc_ref
*ref
)
4368 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4370 if (ref
->u
.ss
.start
!= NULL
)
4372 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4375 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4377 gfc_error ("Substring start index at %L must be of type INTEGER",
4378 &ref
->u
.ss
.start
->where
);
4382 if (ref
->u
.ss
.start
->rank
!= 0)
4384 gfc_error ("Substring start index at %L must be scalar",
4385 &ref
->u
.ss
.start
->where
);
4389 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4390 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4391 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4393 gfc_error ("Substring start index at %L is less than one",
4394 &ref
->u
.ss
.start
->where
);
4399 if (ref
->u
.ss
.end
!= NULL
)
4401 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4404 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4406 gfc_error ("Substring end index at %L must be of type INTEGER",
4407 &ref
->u
.ss
.end
->where
);
4411 if (ref
->u
.ss
.end
->rank
!= 0)
4413 gfc_error ("Substring end index at %L must be scalar",
4414 &ref
->u
.ss
.end
->where
);
4418 if (ref
->u
.ss
.length
!= NULL
4419 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4420 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4421 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4423 gfc_error ("Substring end index at %L exceeds the string length",
4424 &ref
->u
.ss
.start
->where
);
4428 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4429 gfc_integer_kinds
[k
].huge
) == CMP_GT
4430 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4431 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4433 gfc_error ("Substring end index at %L is too large",
4434 &ref
->u
.ss
.end
->where
);
4443 /* This function supplies missing substring charlens. */
4446 gfc_resolve_substring_charlen (gfc_expr
*e
)
4449 gfc_expr
*start
, *end
;
4451 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4452 if (char_ref
->type
== REF_SUBSTRING
)
4458 gcc_assert (char_ref
->next
== NULL
);
4462 if (e
->ts
.u
.cl
->length
)
4463 gfc_free_expr (e
->ts
.u
.cl
->length
);
4464 else if (e
->expr_type
== EXPR_VARIABLE
4465 && e
->symtree
->n
.sym
->attr
.dummy
)
4469 e
->ts
.type
= BT_CHARACTER
;
4470 e
->ts
.kind
= gfc_default_character_kind
;
4473 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4475 if (char_ref
->u
.ss
.start
)
4476 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4478 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4480 if (char_ref
->u
.ss
.end
)
4481 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4482 else if (e
->expr_type
== EXPR_VARIABLE
)
4483 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4489 gfc_free_expr (start
);
4490 gfc_free_expr (end
);
4494 /* Length = (end - start +1). */
4495 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4496 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4497 gfc_get_int_expr (gfc_default_integer_kind
,
4500 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4501 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4503 /* Make sure that the length is simplified. */
4504 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4505 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4509 /* Resolve subtype references. */
4512 resolve_ref (gfc_expr
*expr
)
4514 int current_part_dimension
, n_components
, seen_part_dimension
;
4517 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4518 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4520 find_array_spec (expr
);
4524 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4528 if (!resolve_array_ref (&ref
->u
.ar
))
4536 if (!resolve_substring (ref
))
4541 /* Check constraints on part references. */
4543 current_part_dimension
= 0;
4544 seen_part_dimension
= 0;
4547 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4552 switch (ref
->u
.ar
.type
)
4555 /* Coarray scalar. */
4556 if (ref
->u
.ar
.as
->rank
== 0)
4558 current_part_dimension
= 0;
4563 current_part_dimension
= 1;
4567 current_part_dimension
= 0;
4571 gfc_internal_error ("resolve_ref(): Bad array reference");
4577 if (current_part_dimension
|| seen_part_dimension
)
4580 if (ref
->u
.c
.component
->attr
.pointer
4581 || ref
->u
.c
.component
->attr
.proc_pointer
4582 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4583 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4585 gfc_error ("Component to the right of a part reference "
4586 "with nonzero rank must not have the POINTER "
4587 "attribute at %L", &expr
->where
);
4590 else if (ref
->u
.c
.component
->attr
.allocatable
4591 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4592 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4595 gfc_error ("Component to the right of a part reference "
4596 "with nonzero rank must not have the ALLOCATABLE "
4597 "attribute at %L", &expr
->where
);
4609 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4610 || ref
->next
== NULL
)
4611 && current_part_dimension
4612 && seen_part_dimension
)
4614 gfc_error ("Two or more part references with nonzero rank must "
4615 "not be specified at %L", &expr
->where
);
4619 if (ref
->type
== REF_COMPONENT
)
4621 if (current_part_dimension
)
4622 seen_part_dimension
= 1;
4624 /* reset to make sure */
4625 current_part_dimension
= 0;
4633 /* Given an expression, determine its shape. This is easier than it sounds.
4634 Leaves the shape array NULL if it is not possible to determine the shape. */
4637 expression_shape (gfc_expr
*e
)
4639 mpz_t array
[GFC_MAX_DIMENSIONS
];
4642 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4645 for (i
= 0; i
< e
->rank
; i
++)
4646 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4649 e
->shape
= gfc_get_shape (e
->rank
);
4651 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4656 for (i
--; i
>= 0; i
--)
4657 mpz_clear (array
[i
]);
4661 /* Given a variable expression node, compute the rank of the expression by
4662 examining the base symbol and any reference structures it may have. */
4665 expression_rank (gfc_expr
*e
)
4670 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4671 could lead to serious confusion... */
4672 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4676 if (e
->expr_type
== EXPR_ARRAY
)
4678 /* Constructors can have a rank different from one via RESHAPE(). */
4680 if (e
->symtree
== NULL
)
4686 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4687 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4693 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4695 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4696 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4697 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4699 if (ref
->type
!= REF_ARRAY
)
4702 if (ref
->u
.ar
.type
== AR_FULL
)
4704 rank
= ref
->u
.ar
.as
->rank
;
4708 if (ref
->u
.ar
.type
== AR_SECTION
)
4710 /* Figure out the rank of the section. */
4712 gfc_internal_error ("expression_rank(): Two array specs");
4714 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4715 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4716 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4726 expression_shape (e
);
4730 /* Resolve a variable expression. */
4733 resolve_variable (gfc_expr
*e
)
4740 if (e
->symtree
== NULL
)
4742 sym
= e
->symtree
->n
.sym
;
4744 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4745 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4746 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4748 if (!actual_arg
|| inquiry_argument
)
4750 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4751 "be used as actual argument", sym
->name
, &e
->where
);
4755 /* TS 29113, 407b. */
4756 else if (e
->ts
.type
== BT_ASSUMED
)
4760 gfc_error ("Assumed-type variable %s at %L may only be used "
4761 "as actual argument", sym
->name
, &e
->where
);
4764 else if (inquiry_argument
&& !first_actual_arg
)
4766 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4767 for all inquiry functions in resolve_function; the reason is
4768 that the function-name resolution happens too late in that
4770 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4771 "an inquiry function shall be the first argument",
4772 sym
->name
, &e
->where
);
4776 /* TS 29113, C535b. */
4777 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4778 && CLASS_DATA (sym
)->as
4779 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4780 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4781 && sym
->as
->type
== AS_ASSUMED_RANK
))
4785 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4786 "actual argument", sym
->name
, &e
->where
);
4789 else if (inquiry_argument
&& !first_actual_arg
)
4791 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4792 for all inquiry functions in resolve_function; the reason is
4793 that the function-name resolution happens too late in that
4795 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4796 "to an inquiry function shall be the first argument",
4797 sym
->name
, &e
->where
);
4802 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4803 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4804 && e
->ref
->next
== NULL
))
4806 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4807 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4810 /* TS 29113, 407b. */
4811 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4812 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4813 && e
->ref
->next
== NULL
))
4815 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4816 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4820 /* TS 29113, C535b. */
4821 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4822 && CLASS_DATA (sym
)->as
4823 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4824 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4825 && sym
->as
->type
== AS_ASSUMED_RANK
))
4827 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4828 && e
->ref
->next
== NULL
))
4830 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4831 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4836 /* If this is an associate-name, it may be parsed with an array reference
4837 in error even though the target is scalar. Fail directly in this case.
4838 TODO Understand why class scalar expressions must be excluded. */
4839 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4841 if (sym
->ts
.type
== BT_CLASS
)
4842 gfc_fix_class_refs (e
);
4843 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4847 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4848 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4850 /* On the other hand, the parser may not have known this is an array;
4851 in this case, we have to add a FULL reference. */
4852 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4854 e
->ref
= gfc_get_ref ();
4855 e
->ref
->type
= REF_ARRAY
;
4856 e
->ref
->u
.ar
.type
= AR_FULL
;
4857 e
->ref
->u
.ar
.dimen
= 0;
4860 if (e
->ref
&& !resolve_ref (e
))
4863 if (sym
->attr
.flavor
== FL_PROCEDURE
4864 && (!sym
->attr
.function
4865 || (sym
->attr
.function
&& sym
->result
4866 && sym
->result
->attr
.proc_pointer
4867 && !sym
->result
->attr
.function
)))
4869 e
->ts
.type
= BT_PROCEDURE
;
4870 goto resolve_procedure
;
4873 if (sym
->ts
.type
!= BT_UNKNOWN
)
4874 gfc_variable_attr (e
, &e
->ts
);
4877 /* Must be a simple variable reference. */
4878 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4883 if (check_assumed_size_reference (sym
, e
))
4886 /* Deal with forward references to entries during resolve_code, to
4887 satisfy, at least partially, 12.5.2.5. */
4888 if (gfc_current_ns
->entries
4889 && current_entry_id
== sym
->entry_id
4892 && cs_base
->current
->op
!= EXEC_ENTRY
)
4894 gfc_entry_list
*entry
;
4895 gfc_formal_arglist
*formal
;
4897 bool seen
, saved_specification_expr
;
4899 /* If the symbol is a dummy... */
4900 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4902 entry
= gfc_current_ns
->entries
;
4905 /* ...test if the symbol is a parameter of previous entries. */
4906 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4907 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4909 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4916 /* If it has not been seen as a dummy, this is an error. */
4919 if (specification_expr
)
4920 gfc_error ("Variable '%s', used in a specification expression"
4921 ", is referenced at %L before the ENTRY statement "
4922 "in which it is a parameter",
4923 sym
->name
, &cs_base
->current
->loc
);
4925 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4926 "statement in which it is a parameter",
4927 sym
->name
, &cs_base
->current
->loc
);
4932 /* Now do the same check on the specification expressions. */
4933 saved_specification_expr
= specification_expr
;
4934 specification_expr
= true;
4935 if (sym
->ts
.type
== BT_CHARACTER
4936 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4940 for (n
= 0; n
< sym
->as
->rank
; n
++)
4942 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4944 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4947 specification_expr
= saved_specification_expr
;
4950 /* Update the symbol's entry level. */
4951 sym
->entry_id
= current_entry_id
+ 1;
4954 /* If a symbol has been host_associated mark it. This is used latter,
4955 to identify if aliasing is possible via host association. */
4956 if (sym
->attr
.flavor
== FL_VARIABLE
4957 && gfc_current_ns
->parent
4958 && (gfc_current_ns
->parent
== sym
->ns
4959 || (gfc_current_ns
->parent
->parent
4960 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4961 sym
->attr
.host_assoc
= 1;
4964 if (t
&& !resolve_procedure_expression (e
))
4967 /* F2008, C617 and C1229. */
4968 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4969 && gfc_is_coindexed (e
))
4971 gfc_ref
*ref
, *ref2
= NULL
;
4973 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4975 if (ref
->type
== REF_COMPONENT
)
4977 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4981 for ( ; ref
; ref
= ref
->next
)
4982 if (ref
->type
== REF_COMPONENT
)
4985 /* Expression itself is not coindexed object. */
4986 if (ref
&& e
->ts
.type
== BT_CLASS
)
4988 gfc_error ("Polymorphic subobject of coindexed object at %L",
4993 /* Expression itself is coindexed object. */
4997 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
4998 for ( ; c
; c
= c
->next
)
4999 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5001 gfc_error ("Coindexed object with polymorphic allocatable "
5002 "subcomponent at %L", &e
->where
);
5013 /* Checks to see that the correct symbol has been host associated.
5014 The only situation where this arises is that in which a twice
5015 contained function is parsed after the host association is made.
5016 Therefore, on detecting this, change the symbol in the expression
5017 and convert the array reference into an actual arglist if the old
5018 symbol is a variable. */
5020 check_host_association (gfc_expr
*e
)
5022 gfc_symbol
*sym
, *old_sym
;
5026 gfc_actual_arglist
*arg
, *tail
= NULL
;
5027 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5029 /* If the expression is the result of substitution in
5030 interface.c(gfc_extend_expr) because there is no way in
5031 which the host association can be wrong. */
5032 if (e
->symtree
== NULL
5033 || e
->symtree
->n
.sym
== NULL
5034 || e
->user_operator
)
5037 old_sym
= e
->symtree
->n
.sym
;
5039 if (gfc_current_ns
->parent
5040 && old_sym
->ns
!= gfc_current_ns
)
5042 /* Use the 'USE' name so that renamed module symbols are
5043 correctly handled. */
5044 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5046 if (sym
&& old_sym
!= sym
5047 && sym
->ts
.type
== old_sym
->ts
.type
5048 && sym
->attr
.flavor
== FL_PROCEDURE
5049 && sym
->attr
.contained
)
5051 /* Clear the shape, since it might not be valid. */
5052 gfc_free_shape (&e
->shape
, e
->rank
);
5054 /* Give the expression the right symtree! */
5055 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5056 gcc_assert (st
!= NULL
);
5058 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5059 || e
->expr_type
== EXPR_FUNCTION
)
5061 /* Original was function so point to the new symbol, since
5062 the actual argument list is already attached to the
5064 e
->value
.function
.esym
= NULL
;
5069 /* Original was variable so convert array references into
5070 an actual arglist. This does not need any checking now
5071 since resolve_function will take care of it. */
5072 e
->value
.function
.actual
= NULL
;
5073 e
->expr_type
= EXPR_FUNCTION
;
5076 /* Ambiguity will not arise if the array reference is not
5077 the last reference. */
5078 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5079 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5082 gcc_assert (ref
->type
== REF_ARRAY
);
5084 /* Grab the start expressions from the array ref and
5085 copy them into actual arguments. */
5086 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5088 arg
= gfc_get_actual_arglist ();
5089 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5090 if (e
->value
.function
.actual
== NULL
)
5091 tail
= e
->value
.function
.actual
= arg
;
5099 /* Dump the reference list and set the rank. */
5100 gfc_free_ref_list (e
->ref
);
5102 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5105 gfc_resolve_expr (e
);
5109 /* This might have changed! */
5110 return e
->expr_type
== EXPR_FUNCTION
;
5115 gfc_resolve_character_operator (gfc_expr
*e
)
5117 gfc_expr
*op1
= e
->value
.op
.op1
;
5118 gfc_expr
*op2
= e
->value
.op
.op2
;
5119 gfc_expr
*e1
= NULL
;
5120 gfc_expr
*e2
= NULL
;
5122 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5124 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5125 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5126 else if (op1
->expr_type
== EXPR_CONSTANT
)
5127 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5128 op1
->value
.character
.length
);
5130 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5131 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5132 else if (op2
->expr_type
== EXPR_CONSTANT
)
5133 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5134 op2
->value
.character
.length
);
5136 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5146 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5147 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5148 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5149 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5150 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5156 /* Ensure that an character expression has a charlen and, if possible, a
5157 length expression. */
5160 fixup_charlen (gfc_expr
*e
)
5162 /* The cases fall through so that changes in expression type and the need
5163 for multiple fixes are picked up. In all circumstances, a charlen should
5164 be available for the middle end to hang a backend_decl on. */
5165 switch (e
->expr_type
)
5168 gfc_resolve_character_operator (e
);
5171 if (e
->expr_type
== EXPR_ARRAY
)
5172 gfc_resolve_character_array_constructor (e
);
5174 case EXPR_SUBSTRING
:
5175 if (!e
->ts
.u
.cl
&& e
->ref
)
5176 gfc_resolve_substring_charlen (e
);
5180 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5187 /* Update an actual argument to include the passed-object for type-bound
5188 procedures at the right position. */
5190 static gfc_actual_arglist
*
5191 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5194 gcc_assert (argpos
> 0);
5198 gfc_actual_arglist
* result
;
5200 result
= gfc_get_actual_arglist ();
5204 result
->name
= name
;
5210 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5212 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5217 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5220 extract_compcall_passed_object (gfc_expr
* e
)
5224 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5226 if (e
->value
.compcall
.base_object
)
5227 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5230 po
= gfc_get_expr ();
5231 po
->expr_type
= EXPR_VARIABLE
;
5232 po
->symtree
= e
->symtree
;
5233 po
->ref
= gfc_copy_ref (e
->ref
);
5234 po
->where
= e
->where
;
5237 if (!gfc_resolve_expr (po
))
5244 /* Update the arglist of an EXPR_COMPCALL expression to include the
5248 update_compcall_arglist (gfc_expr
* e
)
5251 gfc_typebound_proc
* tbp
;
5253 tbp
= e
->value
.compcall
.tbp
;
5258 po
= extract_compcall_passed_object (e
);
5262 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5268 gcc_assert (tbp
->pass_arg_num
> 0);
5269 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5277 /* Extract the passed object from a PPC call (a copy of it). */
5280 extract_ppc_passed_object (gfc_expr
*e
)
5285 po
= gfc_get_expr ();
5286 po
->expr_type
= EXPR_VARIABLE
;
5287 po
->symtree
= e
->symtree
;
5288 po
->ref
= gfc_copy_ref (e
->ref
);
5289 po
->where
= e
->where
;
5291 /* Remove PPC reference. */
5293 while ((*ref
)->next
)
5294 ref
= &(*ref
)->next
;
5295 gfc_free_ref_list (*ref
);
5298 if (!gfc_resolve_expr (po
))
5305 /* Update the actual arglist of a procedure pointer component to include the
5309 update_ppc_arglist (gfc_expr
* e
)
5313 gfc_typebound_proc
* tb
;
5315 ppc
= gfc_get_proc_ptr_comp (e
);
5323 else if (tb
->nopass
)
5326 po
= extract_ppc_passed_object (e
);
5333 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5338 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5340 gfc_error ("Base object for procedure-pointer component call at %L is of"
5341 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5345 gcc_assert (tb
->pass_arg_num
> 0);
5346 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5354 /* Check that the object a TBP is called on is valid, i.e. it must not be
5355 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5358 check_typebound_baseobject (gfc_expr
* e
)
5361 bool return_value
= false;
5363 base
= extract_compcall_passed_object (e
);
5367 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5369 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5373 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5375 gfc_error ("Base object for type-bound procedure call at %L is of"
5376 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5380 /* F08:C1230. If the procedure called is NOPASS,
5381 the base object must be scalar. */
5382 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5384 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5385 " be scalar", &e
->where
);
5389 return_value
= true;
5392 gfc_free_expr (base
);
5393 return return_value
;
5397 /* Resolve a call to a type-bound procedure, either function or subroutine,
5398 statically from the data in an EXPR_COMPCALL expression. The adapted
5399 arglist and the target-procedure symtree are returned. */
5402 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5403 gfc_actual_arglist
** actual
)
5405 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5406 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5408 /* Update the actual arglist for PASS. */
5409 if (!update_compcall_arglist (e
))
5412 *actual
= e
->value
.compcall
.actual
;
5413 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5415 gfc_free_ref_list (e
->ref
);
5417 e
->value
.compcall
.actual
= NULL
;
5419 /* If we find a deferred typebound procedure, check for derived types
5420 that an overriding typebound procedure has not been missed. */
5421 if (e
->value
.compcall
.name
5422 && !e
->value
.compcall
.tbp
->non_overridable
5423 && e
->value
.compcall
.base_object
5424 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5427 gfc_symbol
*derived
;
5429 /* Use the derived type of the base_object. */
5430 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5433 /* If necessary, go through the inheritance chain. */
5434 while (!st
&& derived
)
5436 /* Look for the typebound procedure 'name'. */
5437 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5438 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5439 e
->value
.compcall
.name
);
5441 derived
= gfc_get_derived_super_type (derived
);
5444 /* Now find the specific name in the derived type namespace. */
5445 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5446 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5447 derived
->ns
, 1, &st
);
5455 /* Get the ultimate declared type from an expression. In addition,
5456 return the last class/derived type reference and the copy of the
5457 reference list. If check_types is set true, derived types are
5458 identified as well as class references. */
5460 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5461 gfc_expr
*e
, bool check_types
)
5463 gfc_symbol
*declared
;
5470 *new_ref
= gfc_copy_ref (e
->ref
);
5472 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5474 if (ref
->type
!= REF_COMPONENT
)
5477 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5478 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5479 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5481 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5487 if (declared
== NULL
)
5488 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5494 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5495 which of the specific bindings (if any) matches the arglist and transform
5496 the expression into a call of that binding. */
5499 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5501 gfc_typebound_proc
* genproc
;
5502 const char* genname
;
5504 gfc_symbol
*derived
;
5506 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5507 genname
= e
->value
.compcall
.name
;
5508 genproc
= e
->value
.compcall
.tbp
;
5510 if (!genproc
->is_generic
)
5513 /* Try the bindings on this type and in the inheritance hierarchy. */
5514 for (; genproc
; genproc
= genproc
->overridden
)
5518 gcc_assert (genproc
->is_generic
);
5519 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5522 gfc_actual_arglist
* args
;
5525 gcc_assert (g
->specific
);
5527 if (g
->specific
->error
)
5530 target
= g
->specific
->u
.specific
->n
.sym
;
5532 /* Get the right arglist by handling PASS/NOPASS. */
5533 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5534 if (!g
->specific
->nopass
)
5537 po
= extract_compcall_passed_object (e
);
5540 gfc_free_actual_arglist (args
);
5544 gcc_assert (g
->specific
->pass_arg_num
> 0);
5545 gcc_assert (!g
->specific
->error
);
5546 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5547 g
->specific
->pass_arg
);
5549 resolve_actual_arglist (args
, target
->attr
.proc
,
5550 is_external_proc (target
)
5551 && gfc_sym_get_dummy_args (target
) == NULL
);
5553 /* Check if this arglist matches the formal. */
5554 matches
= gfc_arglist_matches_symbol (&args
, target
);
5556 /* Clean up and break out of the loop if we've found it. */
5557 gfc_free_actual_arglist (args
);
5560 e
->value
.compcall
.tbp
= g
->specific
;
5561 genname
= g
->specific_st
->name
;
5562 /* Pass along the name for CLASS methods, where the vtab
5563 procedure pointer component has to be referenced. */
5571 /* Nothing matching found! */
5572 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5573 " '%s' at %L", genname
, &e
->where
);
5577 /* Make sure that we have the right specific instance for the name. */
5578 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5580 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5582 e
->value
.compcall
.tbp
= st
->n
.tb
;
5588 /* Resolve a call to a type-bound subroutine. */
5591 resolve_typebound_call (gfc_code
* c
, const char **name
)
5593 gfc_actual_arglist
* newactual
;
5594 gfc_symtree
* target
;
5596 /* Check that's really a SUBROUTINE. */
5597 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5599 gfc_error ("'%s' at %L should be a SUBROUTINE",
5600 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5604 if (!check_typebound_baseobject (c
->expr1
))
5607 /* Pass along the name for CLASS methods, where the vtab
5608 procedure pointer component has to be referenced. */
5610 *name
= c
->expr1
->value
.compcall
.name
;
5612 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5615 /* Transform into an ordinary EXEC_CALL for now. */
5617 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5620 c
->ext
.actual
= newactual
;
5621 c
->symtree
= target
;
5622 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5624 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5626 gfc_free_expr (c
->expr1
);
5627 c
->expr1
= gfc_get_expr ();
5628 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5629 c
->expr1
->symtree
= target
;
5630 c
->expr1
->where
= c
->loc
;
5632 return resolve_call (c
);
5636 /* Resolve a component-call expression. */
5638 resolve_compcall (gfc_expr
* e
, const char **name
)
5640 gfc_actual_arglist
* newactual
;
5641 gfc_symtree
* target
;
5643 /* Check that's really a FUNCTION. */
5644 if (!e
->value
.compcall
.tbp
->function
)
5646 gfc_error ("'%s' at %L should be a FUNCTION",
5647 e
->value
.compcall
.name
, &e
->where
);
5651 /* These must not be assign-calls! */
5652 gcc_assert (!e
->value
.compcall
.assign
);
5654 if (!check_typebound_baseobject (e
))
5657 /* Pass along the name for CLASS methods, where the vtab
5658 procedure pointer component has to be referenced. */
5660 *name
= e
->value
.compcall
.name
;
5662 if (!resolve_typebound_generic_call (e
, name
))
5664 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5666 /* Take the rank from the function's symbol. */
5667 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5668 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5670 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5671 arglist to the TBP's binding target. */
5673 if (!resolve_typebound_static (e
, &target
, &newactual
))
5676 e
->value
.function
.actual
= newactual
;
5677 e
->value
.function
.name
= NULL
;
5678 e
->value
.function
.esym
= target
->n
.sym
;
5679 e
->value
.function
.isym
= NULL
;
5680 e
->symtree
= target
;
5681 e
->ts
= target
->n
.sym
->ts
;
5682 e
->expr_type
= EXPR_FUNCTION
;
5684 /* Resolution is not necessary if this is a class subroutine; this
5685 function only has to identify the specific proc. Resolution of
5686 the call will be done next in resolve_typebound_call. */
5687 return gfc_resolve_expr (e
);
5691 static bool resolve_fl_derived (gfc_symbol
*sym
);
5694 /* Resolve a typebound function, or 'method'. First separate all
5695 the non-CLASS references by calling resolve_compcall directly. */
5698 resolve_typebound_function (gfc_expr
* e
)
5700 gfc_symbol
*declared
;
5712 /* Deal with typebound operators for CLASS objects. */
5713 expr
= e
->value
.compcall
.base_object
;
5714 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5715 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5717 /* If the base_object is not a variable, the corresponding actual
5718 argument expression must be stored in e->base_expression so
5719 that the corresponding tree temporary can be used as the base
5720 object in gfc_conv_procedure_call. */
5721 if (expr
->expr_type
!= EXPR_VARIABLE
)
5723 gfc_actual_arglist
*args
;
5725 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5727 if (expr
== args
->expr
)
5732 /* Since the typebound operators are generic, we have to ensure
5733 that any delays in resolution are corrected and that the vtab
5736 declared
= ts
.u
.derived
;
5737 c
= gfc_find_component (declared
, "_vptr", true, true);
5738 if (c
->ts
.u
.derived
== NULL
)
5739 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5741 if (!resolve_compcall (e
, &name
))
5744 /* Use the generic name if it is there. */
5745 name
= name
? name
: e
->value
.function
.esym
->name
;
5746 e
->symtree
= expr
->symtree
;
5747 e
->ref
= gfc_copy_ref (expr
->ref
);
5748 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5750 /* Trim away the extraneous references that emerge from nested
5751 use of interface.c (extend_expr). */
5752 if (class_ref
&& class_ref
->next
)
5754 gfc_free_ref_list (class_ref
->next
);
5755 class_ref
->next
= NULL
;
5757 else if (e
->ref
&& !class_ref
)
5759 gfc_free_ref_list (e
->ref
);
5763 gfc_add_vptr_component (e
);
5764 gfc_add_component_ref (e
, name
);
5765 e
->value
.function
.esym
= NULL
;
5766 if (expr
->expr_type
!= EXPR_VARIABLE
)
5767 e
->base_expr
= expr
;
5772 return resolve_compcall (e
, NULL
);
5774 if (!resolve_ref (e
))
5777 /* Get the CLASS declared type. */
5778 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5780 if (!resolve_fl_derived (declared
))
5783 /* Weed out cases of the ultimate component being a derived type. */
5784 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5785 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5787 gfc_free_ref_list (new_ref
);
5788 return resolve_compcall (e
, NULL
);
5791 c
= gfc_find_component (declared
, "_data", true, true);
5792 declared
= c
->ts
.u
.derived
;
5794 /* Treat the call as if it is a typebound procedure, in order to roll
5795 out the correct name for the specific function. */
5796 if (!resolve_compcall (e
, &name
))
5798 gfc_free_ref_list (new_ref
);
5805 /* Convert the expression to a procedure pointer component call. */
5806 e
->value
.function
.esym
= NULL
;
5812 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5813 gfc_add_vptr_component (e
);
5814 gfc_add_component_ref (e
, name
);
5816 /* Recover the typespec for the expression. This is really only
5817 necessary for generic procedures, where the additional call
5818 to gfc_add_component_ref seems to throw the collection of the
5819 correct typespec. */
5823 gfc_free_ref_list (new_ref
);
5828 /* Resolve a typebound subroutine, or 'method'. First separate all
5829 the non-CLASS references by calling resolve_typebound_call
5833 resolve_typebound_subroutine (gfc_code
*code
)
5835 gfc_symbol
*declared
;
5845 st
= code
->expr1
->symtree
;
5847 /* Deal with typebound operators for CLASS objects. */
5848 expr
= code
->expr1
->value
.compcall
.base_object
;
5849 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5850 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5852 /* If the base_object is not a variable, the corresponding actual
5853 argument expression must be stored in e->base_expression so
5854 that the corresponding tree temporary can be used as the base
5855 object in gfc_conv_procedure_call. */
5856 if (expr
->expr_type
!= EXPR_VARIABLE
)
5858 gfc_actual_arglist
*args
;
5860 args
= code
->expr1
->value
.function
.actual
;
5861 for (; args
; args
= args
->next
)
5862 if (expr
== args
->expr
)
5866 /* Since the typebound operators are generic, we have to ensure
5867 that any delays in resolution are corrected and that the vtab
5869 declared
= expr
->ts
.u
.derived
;
5870 c
= gfc_find_component (declared
, "_vptr", true, true);
5871 if (c
->ts
.u
.derived
== NULL
)
5872 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5874 if (!resolve_typebound_call (code
, &name
))
5877 /* Use the generic name if it is there. */
5878 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5879 code
->expr1
->symtree
= expr
->symtree
;
5880 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5882 /* Trim away the extraneous references that emerge from nested
5883 use of interface.c (extend_expr). */
5884 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5885 if (class_ref
&& class_ref
->next
)
5887 gfc_free_ref_list (class_ref
->next
);
5888 class_ref
->next
= NULL
;
5890 else if (code
->expr1
->ref
&& !class_ref
)
5892 gfc_free_ref_list (code
->expr1
->ref
);
5893 code
->expr1
->ref
= NULL
;
5896 /* Now use the procedure in the vtable. */
5897 gfc_add_vptr_component (code
->expr1
);
5898 gfc_add_component_ref (code
->expr1
, name
);
5899 code
->expr1
->value
.function
.esym
= NULL
;
5900 if (expr
->expr_type
!= EXPR_VARIABLE
)
5901 code
->expr1
->base_expr
= expr
;
5906 return resolve_typebound_call (code
, NULL
);
5908 if (!resolve_ref (code
->expr1
))
5911 /* Get the CLASS declared type. */
5912 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5914 /* Weed out cases of the ultimate component being a derived type. */
5915 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5916 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5918 gfc_free_ref_list (new_ref
);
5919 return resolve_typebound_call (code
, NULL
);
5922 if (!resolve_typebound_call (code
, &name
))
5924 gfc_free_ref_list (new_ref
);
5927 ts
= code
->expr1
->ts
;
5931 /* Convert the expression to a procedure pointer component call. */
5932 code
->expr1
->value
.function
.esym
= NULL
;
5933 code
->expr1
->symtree
= st
;
5936 code
->expr1
->ref
= new_ref
;
5938 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5939 gfc_add_vptr_component (code
->expr1
);
5940 gfc_add_component_ref (code
->expr1
, name
);
5942 /* Recover the typespec for the expression. This is really only
5943 necessary for generic procedures, where the additional call
5944 to gfc_add_component_ref seems to throw the collection of the
5945 correct typespec. */
5946 code
->expr1
->ts
= ts
;
5949 gfc_free_ref_list (new_ref
);
5955 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5958 resolve_ppc_call (gfc_code
* c
)
5960 gfc_component
*comp
;
5962 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5963 gcc_assert (comp
!= NULL
);
5965 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5966 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5968 if (!comp
->attr
.subroutine
)
5969 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5971 if (!resolve_ref (c
->expr1
))
5974 if (!update_ppc_arglist (c
->expr1
))
5977 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5979 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5980 !(comp
->ts
.interface
5981 && comp
->ts
.interface
->formal
)))
5984 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5990 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5993 resolve_expr_ppc (gfc_expr
* e
)
5995 gfc_component
*comp
;
5997 comp
= gfc_get_proc_ptr_comp (e
);
5998 gcc_assert (comp
!= NULL
);
6000 /* Convert to EXPR_FUNCTION. */
6001 e
->expr_type
= EXPR_FUNCTION
;
6002 e
->value
.function
.isym
= NULL
;
6003 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6005 if (comp
->as
!= NULL
)
6006 e
->rank
= comp
->as
->rank
;
6008 if (!comp
->attr
.function
)
6009 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6011 if (!resolve_ref (e
))
6014 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6015 !(comp
->ts
.interface
6016 && comp
->ts
.interface
->formal
)))
6019 if (!update_ppc_arglist (e
))
6022 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6029 gfc_is_expandable_expr (gfc_expr
*e
)
6031 gfc_constructor
*con
;
6033 if (e
->expr_type
== EXPR_ARRAY
)
6035 /* Traverse the constructor looking for variables that are flavor
6036 parameter. Parameters must be expanded since they are fully used at
6038 con
= gfc_constructor_first (e
->value
.constructor
);
6039 for (; con
; con
= gfc_constructor_next (con
))
6041 if (con
->expr
->expr_type
== EXPR_VARIABLE
6042 && con
->expr
->symtree
6043 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6044 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6046 if (con
->expr
->expr_type
== EXPR_ARRAY
6047 && gfc_is_expandable_expr (con
->expr
))
6055 /* Resolve an expression. That is, make sure that types of operands agree
6056 with their operators, intrinsic operators are converted to function calls
6057 for overloaded types and unresolved function references are resolved. */
6060 gfc_resolve_expr (gfc_expr
*e
)
6063 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6068 /* inquiry_argument only applies to variables. */
6069 inquiry_save
= inquiry_argument
;
6070 actual_arg_save
= actual_arg
;
6071 first_actual_arg_save
= first_actual_arg
;
6073 if (e
->expr_type
!= EXPR_VARIABLE
)
6075 inquiry_argument
= false;
6077 first_actual_arg
= false;
6080 switch (e
->expr_type
)
6083 t
= resolve_operator (e
);
6089 if (check_host_association (e
))
6090 t
= resolve_function (e
);
6093 t
= resolve_variable (e
);
6095 expression_rank (e
);
6098 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6099 && e
->ref
->type
!= REF_SUBSTRING
)
6100 gfc_resolve_substring_charlen (e
);
6105 t
= resolve_typebound_function (e
);
6108 case EXPR_SUBSTRING
:
6109 t
= resolve_ref (e
);
6118 t
= resolve_expr_ppc (e
);
6123 if (!resolve_ref (e
))
6126 t
= gfc_resolve_array_constructor (e
);
6127 /* Also try to expand a constructor. */
6130 expression_rank (e
);
6131 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6132 gfc_expand_constructor (e
, false);
6135 /* This provides the opportunity for the length of constructors with
6136 character valued function elements to propagate the string length
6137 to the expression. */
6138 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6140 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6141 here rather then add a duplicate test for it above. */
6142 gfc_expand_constructor (e
, false);
6143 t
= gfc_resolve_character_array_constructor (e
);
6148 case EXPR_STRUCTURE
:
6149 t
= resolve_ref (e
);
6153 t
= resolve_structure_cons (e
, 0);
6157 t
= gfc_simplify_expr (e
, 0);
6161 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6164 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6167 inquiry_argument
= inquiry_save
;
6168 actual_arg
= actual_arg_save
;
6169 first_actual_arg
= first_actual_arg_save
;
6175 /* Resolve an expression from an iterator. They must be scalar and have
6176 INTEGER or (optionally) REAL type. */
6179 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6180 const char *name_msgid
)
6182 if (!gfc_resolve_expr (expr
))
6185 if (expr
->rank
!= 0)
6187 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6191 if (expr
->ts
.type
!= BT_INTEGER
)
6193 if (expr
->ts
.type
== BT_REAL
)
6196 return gfc_notify_std (GFC_STD_F95_DEL
,
6197 "%s at %L must be integer",
6198 _(name_msgid
), &expr
->where
);
6201 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6208 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6216 /* Resolve the expressions in an iterator structure. If REAL_OK is
6217 false allow only INTEGER type iterators, otherwise allow REAL types.
6218 Set own_scope to true for ac-implied-do and data-implied-do as those
6219 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6222 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6224 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6227 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6228 _("iterator variable")))
6231 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6232 "Start expression in DO loop"))
6235 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6236 "End expression in DO loop"))
6239 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6240 "Step expression in DO loop"))
6243 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6245 if ((iter
->step
->ts
.type
== BT_INTEGER
6246 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6247 || (iter
->step
->ts
.type
== BT_REAL
6248 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6250 gfc_error ("Step expression in DO loop at %L cannot be zero",
6251 &iter
->step
->where
);
6256 /* Convert start, end, and step to the same type as var. */
6257 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6258 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6259 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6261 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6262 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6263 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6265 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6266 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6267 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6269 if (iter
->start
->expr_type
== EXPR_CONSTANT
6270 && iter
->end
->expr_type
== EXPR_CONSTANT
6271 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6274 if (iter
->start
->ts
.type
== BT_INTEGER
)
6276 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6277 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6281 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6282 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6284 if (gfc_option
.warn_zerotrip
&&
6285 ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6286 gfc_warning ("DO loop at %L will be executed zero times"
6287 " (use -Wno-zerotrip to suppress)",
6288 &iter
->step
->where
);
6295 /* Traversal function for find_forall_index. f == 2 signals that
6296 that variable itself is not to be checked - only the references. */
6299 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6301 if (expr
->expr_type
!= EXPR_VARIABLE
)
6304 /* A scalar assignment */
6305 if (!expr
->ref
|| *f
== 1)
6307 if (expr
->symtree
->n
.sym
== sym
)
6319 /* Check whether the FORALL index appears in the expression or not.
6320 Returns true if SYM is found in EXPR. */
6323 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6325 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6332 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6333 to be a scalar INTEGER variable. The subscripts and stride are scalar
6334 INTEGERs, and if stride is a constant it must be nonzero.
6335 Furthermore "A subscript or stride in a forall-triplet-spec shall
6336 not contain a reference to any index-name in the
6337 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6340 resolve_forall_iterators (gfc_forall_iterator
*it
)
6342 gfc_forall_iterator
*iter
, *iter2
;
6344 for (iter
= it
; iter
; iter
= iter
->next
)
6346 if (gfc_resolve_expr (iter
->var
)
6347 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6348 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6351 if (gfc_resolve_expr (iter
->start
)
6352 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6353 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6354 &iter
->start
->where
);
6355 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6356 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6358 if (gfc_resolve_expr (iter
->end
)
6359 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6360 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6362 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6363 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6365 if (gfc_resolve_expr (iter
->stride
))
6367 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6368 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6369 &iter
->stride
->where
, "INTEGER");
6371 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6372 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6373 gfc_error ("FORALL stride expression at %L cannot be zero",
6374 &iter
->stride
->where
);
6376 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6377 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6380 for (iter
= it
; iter
; iter
= iter
->next
)
6381 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6383 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6384 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6385 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6386 gfc_error ("FORALL index '%s' may not appear in triplet "
6387 "specification at %L", iter
->var
->symtree
->name
,
6388 &iter2
->start
->where
);
6393 /* Given a pointer to a symbol that is a derived type, see if it's
6394 inaccessible, i.e. if it's defined in another module and the components are
6395 PRIVATE. The search is recursive if necessary. Returns zero if no
6396 inaccessible components are found, nonzero otherwise. */
6399 derived_inaccessible (gfc_symbol
*sym
)
6403 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6406 for (c
= sym
->components
; c
; c
= c
->next
)
6408 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6416 /* Resolve the argument of a deallocate expression. The expression must be
6417 a pointer or a full array. */
6420 resolve_deallocate_expr (gfc_expr
*e
)
6422 symbol_attribute attr
;
6423 int allocatable
, pointer
;
6429 if (!gfc_resolve_expr (e
))
6432 if (e
->expr_type
!= EXPR_VARIABLE
)
6435 sym
= e
->symtree
->n
.sym
;
6436 unlimited
= UNLIMITED_POLY(sym
);
6438 if (sym
->ts
.type
== BT_CLASS
)
6440 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6441 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6445 allocatable
= sym
->attr
.allocatable
;
6446 pointer
= sym
->attr
.pointer
;
6448 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6453 if (ref
->u
.ar
.type
!= AR_FULL
6454 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6455 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6460 c
= ref
->u
.c
.component
;
6461 if (c
->ts
.type
== BT_CLASS
)
6463 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6464 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6468 allocatable
= c
->attr
.allocatable
;
6469 pointer
= c
->attr
.pointer
;
6479 attr
= gfc_expr_attr (e
);
6481 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6484 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6490 if (gfc_is_coindexed (e
))
6492 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6497 && !gfc_check_vardef_context (e
, true, true, false,
6498 _("DEALLOCATE object")))
6500 if (!gfc_check_vardef_context (e
, false, true, false,
6501 _("DEALLOCATE object")))
6508 /* Returns true if the expression e contains a reference to the symbol sym. */
6510 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6512 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6519 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6521 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6525 /* Given the expression node e for an allocatable/pointer of derived type to be
6526 allocated, get the expression node to be initialized afterwards (needed for
6527 derived types with default initializers, and derived types with allocatable
6528 components that need nullification.) */
6531 gfc_expr_to_initialize (gfc_expr
*e
)
6537 result
= gfc_copy_expr (e
);
6539 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6540 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6541 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6543 ref
->u
.ar
.type
= AR_FULL
;
6545 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6546 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6551 gfc_free_shape (&result
->shape
, result
->rank
);
6553 /* Recalculate rank, shape, etc. */
6554 gfc_resolve_expr (result
);
6559 /* If the last ref of an expression is an array ref, return a copy of the
6560 expression with that one removed. Otherwise, a copy of the original
6561 expression. This is used for allocate-expressions and pointer assignment
6562 LHS, where there may be an array specification that needs to be stripped
6563 off when using gfc_check_vardef_context. */
6566 remove_last_array_ref (gfc_expr
* e
)
6571 e2
= gfc_copy_expr (e
);
6572 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6573 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6575 gfc_free_ref_list (*r
);
6584 /* Used in resolve_allocate_expr to check that a allocation-object and
6585 a source-expr are conformable. This does not catch all possible
6586 cases; in particular a runtime checking is needed. */
6589 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6592 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6594 /* First compare rank. */
6595 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6597 gfc_error ("Source-expr at %L must be scalar or have the "
6598 "same rank as the allocate-object at %L",
6599 &e1
->where
, &e2
->where
);
6610 for (i
= 0; i
< e1
->rank
; i
++)
6612 if (tail
->u
.ar
.start
[i
] == NULL
)
6615 if (tail
->u
.ar
.end
[i
])
6617 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6618 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6619 mpz_add_ui (s
, s
, 1);
6623 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6626 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6628 gfc_error ("Source-expr at %L and allocate-object at %L must "
6629 "have the same shape", &e1
->where
, &e2
->where
);
6642 /* Resolve the expression in an ALLOCATE statement, doing the additional
6643 checks to see whether the expression is OK or not. The expression must
6644 have a trailing array reference that gives the size of the array. */
6647 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6649 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6653 symbol_attribute attr
;
6654 gfc_ref
*ref
, *ref2
;
6657 gfc_symbol
*sym
= NULL
;
6662 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6663 checking of coarrays. */
6664 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6665 if (ref
->next
== NULL
)
6668 if (ref
&& ref
->type
== REF_ARRAY
)
6669 ref
->u
.ar
.in_allocate
= true;
6671 if (!gfc_resolve_expr (e
))
6674 /* Make sure the expression is allocatable or a pointer. If it is
6675 pointer, the next-to-last reference must be a pointer. */
6679 sym
= e
->symtree
->n
.sym
;
6681 /* Check whether ultimate component is abstract and CLASS. */
6684 /* Is the allocate-object unlimited polymorphic? */
6685 unlimited
= UNLIMITED_POLY(e
);
6687 if (e
->expr_type
!= EXPR_VARIABLE
)
6690 attr
= gfc_expr_attr (e
);
6691 pointer
= attr
.pointer
;
6692 dimension
= attr
.dimension
;
6693 codimension
= attr
.codimension
;
6697 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6699 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6700 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6701 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6702 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6703 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6707 allocatable
= sym
->attr
.allocatable
;
6708 pointer
= sym
->attr
.pointer
;
6709 dimension
= sym
->attr
.dimension
;
6710 codimension
= sym
->attr
.codimension
;
6715 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6720 if (ref
->u
.ar
.codimen
> 0)
6723 for (n
= ref
->u
.ar
.dimen
;
6724 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6725 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6732 if (ref
->next
!= NULL
)
6740 gfc_error ("Coindexed allocatable object at %L",
6745 c
= ref
->u
.c
.component
;
6746 if (c
->ts
.type
== BT_CLASS
)
6748 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6749 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6750 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6751 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6752 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6756 allocatable
= c
->attr
.allocatable
;
6757 pointer
= c
->attr
.pointer
;
6758 dimension
= c
->attr
.dimension
;
6759 codimension
= c
->attr
.codimension
;
6760 is_abstract
= c
->attr
.abstract
;
6772 /* Check for F08:C628. */
6773 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6775 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6780 /* Some checks for the SOURCE tag. */
6783 /* Check F03:C631. */
6784 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6786 gfc_error ("Type of entity at %L is type incompatible with "
6787 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6791 /* Check F03:C632 and restriction following Note 6.18. */
6792 if (code
->expr3
->rank
> 0 && !unlimited
6793 && !conformable_arrays (code
->expr3
, e
))
6796 /* Check F03:C633. */
6797 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6799 gfc_error ("The allocate-object at %L and the source-expr at %L "
6800 "shall have the same kind type parameter",
6801 &e
->where
, &code
->expr3
->where
);
6805 /* Check F2008, C642. */
6806 if (code
->expr3
->ts
.type
== BT_DERIVED
6807 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6808 || (code
->expr3
->ts
.u
.derived
->from_intmod
6809 == INTMOD_ISO_FORTRAN_ENV
6810 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6811 == ISOFORTRAN_LOCK_TYPE
)))
6813 gfc_error ("The source-expr at %L shall neither be of type "
6814 "LOCK_TYPE nor have a LOCK_TYPE component if "
6815 "allocate-object at %L is a coarray",
6816 &code
->expr3
->where
, &e
->where
);
6821 /* Check F08:C629. */
6822 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6825 gcc_assert (e
->ts
.type
== BT_CLASS
);
6826 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6827 "type-spec or source-expr", sym
->name
, &e
->where
);
6831 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6833 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6834 code
->ext
.alloc
.ts
.u
.cl
->length
);
6835 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6837 gfc_error ("Allocating %s at %L with type-spec requires the same "
6838 "character-length parameter as in the declaration",
6839 sym
->name
, &e
->where
);
6844 /* In the variable definition context checks, gfc_expr_attr is used
6845 on the expression. This is fooled by the array specification
6846 present in e, thus we have to eliminate that one temporarily. */
6847 e2
= remove_last_array_ref (e
);
6850 t
= gfc_check_vardef_context (e2
, true, true, false,
6851 _("ALLOCATE object"));
6853 t
= gfc_check_vardef_context (e2
, false, true, false,
6854 _("ALLOCATE object"));
6859 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6860 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6862 /* For class arrays, the initialization with SOURCE is done
6863 using _copy and trans_call. It is convenient to exploit that
6864 when the allocated type is different from the declared type but
6865 no SOURCE exists by setting expr3. */
6866 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6868 else if (!code
->expr3
)
6870 /* Set up default initializer if needed. */
6874 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6875 ts
= code
->ext
.alloc
.ts
;
6879 if (ts
.type
== BT_CLASS
)
6880 ts
= ts
.u
.derived
->components
->ts
;
6882 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6884 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6885 init_st
->loc
= code
->loc
;
6886 init_st
->expr1
= gfc_expr_to_initialize (e
);
6887 init_st
->expr2
= init_e
;
6888 init_st
->next
= code
->next
;
6889 code
->next
= init_st
;
6892 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6894 /* Default initialization via MOLD (non-polymorphic). */
6895 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6896 gfc_resolve_expr (rhs
);
6897 gfc_free_expr (code
->expr3
);
6901 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6903 /* Make sure the vtab symbol is present when
6904 the module variables are generated. */
6905 gfc_typespec ts
= e
->ts
;
6907 ts
= code
->expr3
->ts
;
6908 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6909 ts
= code
->ext
.alloc
.ts
;
6911 gfc_find_derived_vtab (ts
.u
.derived
);
6914 e
= gfc_expr_to_initialize (e
);
6916 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6918 /* Again, make sure the vtab symbol is present when
6919 the module variables are generated. */
6920 gfc_typespec
*ts
= NULL
;
6922 ts
= &code
->expr3
->ts
;
6924 ts
= &code
->ext
.alloc
.ts
;
6928 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6929 gfc_find_derived_vtab (ts
->u
.derived
);
6931 gfc_find_intrinsic_vtab (ts
);
6934 e
= gfc_expr_to_initialize (e
);
6937 if (dimension
== 0 && codimension
== 0)
6940 /* Make sure the last reference node is an array specification. */
6942 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6943 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6945 gfc_error ("Array specification required in ALLOCATE statement "
6946 "at %L", &e
->where
);
6950 /* Make sure that the array section reference makes sense in the
6951 context of an ALLOCATE specification. */
6956 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6957 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6959 gfc_error ("Coarray specification required in ALLOCATE statement "
6960 "at %L", &e
->where
);
6964 for (i
= 0; i
< ar
->dimen
; i
++)
6966 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6969 switch (ar
->dimen_type
[i
])
6975 if (ar
->start
[i
] != NULL
6976 && ar
->end
[i
] != NULL
6977 && ar
->stride
[i
] == NULL
)
6980 /* Fall Through... */
6985 case DIMEN_THIS_IMAGE
:
6986 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6992 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6994 sym
= a
->expr
->symtree
->n
.sym
;
6996 /* TODO - check derived type components. */
6997 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7000 if ((ar
->start
[i
] != NULL
7001 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7002 || (ar
->end
[i
] != NULL
7003 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7005 gfc_error ("'%s' must not appear in the array specification at "
7006 "%L in the same ALLOCATE statement where it is "
7007 "itself allocated", sym
->name
, &ar
->where
);
7013 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7015 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7016 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7018 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7020 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7021 "statement at %L", &e
->where
);
7027 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7028 && ar
->stride
[i
] == NULL
)
7031 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7044 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7046 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7047 gfc_alloc
*a
, *p
, *q
;
7050 errmsg
= code
->expr2
;
7052 /* Check the stat variable. */
7055 gfc_check_vardef_context (stat
, false, false, false,
7056 _("STAT variable"));
7058 if ((stat
->ts
.type
!= BT_INTEGER
7059 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7060 || stat
->ref
->type
== REF_COMPONENT
)))
7062 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7063 "variable", &stat
->where
);
7065 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7066 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7068 gfc_ref
*ref1
, *ref2
;
7071 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7072 ref1
= ref1
->next
, ref2
= ref2
->next
)
7074 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7076 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7085 gfc_error ("Stat-variable at %L shall not be %sd within "
7086 "the same %s statement", &stat
->where
, fcn
, fcn
);
7092 /* Check the errmsg variable. */
7096 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7099 gfc_check_vardef_context (errmsg
, false, false, false,
7100 _("ERRMSG variable"));
7102 if ((errmsg
->ts
.type
!= BT_CHARACTER
7104 && (errmsg
->ref
->type
== REF_ARRAY
7105 || errmsg
->ref
->type
== REF_COMPONENT
)))
7106 || errmsg
->rank
> 0 )
7107 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7108 "variable", &errmsg
->where
);
7110 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7111 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7113 gfc_ref
*ref1
, *ref2
;
7116 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7117 ref1
= ref1
->next
, ref2
= ref2
->next
)
7119 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7121 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7130 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7131 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7137 /* Check that an allocate-object appears only once in the statement. */
7139 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7142 for (q
= p
->next
; q
; q
= q
->next
)
7145 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7147 /* This is a potential collision. */
7148 gfc_ref
*pr
= pe
->ref
;
7149 gfc_ref
*qr
= qe
->ref
;
7151 /* Follow the references until
7152 a) They start to differ, in which case there is no error;
7153 you can deallocate a%b and a%c in a single statement
7154 b) Both of them stop, which is an error
7155 c) One of them stops, which is also an error. */
7158 if (pr
== NULL
&& qr
== NULL
)
7160 gfc_error ("Allocate-object at %L also appears at %L",
7161 &pe
->where
, &qe
->where
);
7164 else if (pr
!= NULL
&& qr
== NULL
)
7166 gfc_error ("Allocate-object at %L is subobject of"
7167 " object at %L", &pe
->where
, &qe
->where
);
7170 else if (pr
== NULL
&& qr
!= NULL
)
7172 gfc_error ("Allocate-object at %L is subobject of"
7173 " object at %L", &qe
->where
, &pe
->where
);
7176 /* Here, pr != NULL && qr != NULL */
7177 gcc_assert(pr
->type
== qr
->type
);
7178 if (pr
->type
== REF_ARRAY
)
7180 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7182 gcc_assert (qr
->type
== REF_ARRAY
);
7184 if (pr
->next
&& qr
->next
)
7187 gfc_array_ref
*par
= &(pr
->u
.ar
);
7188 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7190 for (i
=0; i
<par
->dimen
; i
++)
7192 if ((par
->start
[i
] != NULL
7193 || qar
->start
[i
] != NULL
)
7194 && gfc_dep_compare_expr (par
->start
[i
],
7195 qar
->start
[i
]) != 0)
7202 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7215 if (strcmp (fcn
, "ALLOCATE") == 0)
7217 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7218 resolve_allocate_expr (a
->expr
, code
);
7222 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7223 resolve_deallocate_expr (a
->expr
);
7228 /************ SELECT CASE resolution subroutines ************/
7230 /* Callback function for our mergesort variant. Determines interval
7231 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7232 op1 > op2. Assumes we're not dealing with the default case.
7233 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7234 There are nine situations to check. */
7237 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7241 if (op1
->low
== NULL
) /* op1 = (:L) */
7243 /* op2 = (:N), so overlap. */
7245 /* op2 = (M:) or (M:N), L < M */
7246 if (op2
->low
!= NULL
7247 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7250 else if (op1
->high
== NULL
) /* op1 = (K:) */
7252 /* op2 = (M:), so overlap. */
7254 /* op2 = (:N) or (M:N), K > N */
7255 if (op2
->high
!= NULL
7256 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7259 else /* op1 = (K:L) */
7261 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7262 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7264 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7265 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7267 else /* op2 = (M:N) */
7271 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7274 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7283 /* Merge-sort a double linked case list, detecting overlap in the
7284 process. LIST is the head of the double linked case list before it
7285 is sorted. Returns the head of the sorted list if we don't see any
7286 overlap, or NULL otherwise. */
7289 check_case_overlap (gfc_case
*list
)
7291 gfc_case
*p
, *q
, *e
, *tail
;
7292 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7294 /* If the passed list was empty, return immediately. */
7301 /* Loop unconditionally. The only exit from this loop is a return
7302 statement, when we've finished sorting the case list. */
7309 /* Count the number of merges we do in this pass. */
7312 /* Loop while there exists a merge to be done. */
7317 /* Count this merge. */
7320 /* Cut the list in two pieces by stepping INSIZE places
7321 forward in the list, starting from P. */
7324 for (i
= 0; i
< insize
; i
++)
7333 /* Now we have two lists. Merge them! */
7334 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7336 /* See from which the next case to merge comes from. */
7339 /* P is empty so the next case must come from Q. */
7344 else if (qsize
== 0 || q
== NULL
)
7353 cmp
= compare_cases (p
, q
);
7356 /* The whole case range for P is less than the
7364 /* The whole case range for Q is greater than
7365 the case range for P. */
7372 /* The cases overlap, or they are the same
7373 element in the list. Either way, we must
7374 issue an error and get the next case from P. */
7375 /* FIXME: Sort P and Q by line number. */
7376 gfc_error ("CASE label at %L overlaps with CASE "
7377 "label at %L", &p
->where
, &q
->where
);
7385 /* Add the next element to the merged list. */
7394 /* P has now stepped INSIZE places along, and so has Q. So
7395 they're the same. */
7400 /* If we have done only one merge or none at all, we've
7401 finished sorting the cases. */
7410 /* Otherwise repeat, merging lists twice the size. */
7416 /* Check to see if an expression is suitable for use in a CASE statement.
7417 Makes sure that all case expressions are scalar constants of the same
7418 type. Return false if anything is wrong. */
7421 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7423 if (e
== NULL
) return true;
7425 if (e
->ts
.type
!= case_expr
->ts
.type
)
7427 gfc_error ("Expression in CASE statement at %L must be of type %s",
7428 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7432 /* C805 (R808) For a given case-construct, each case-value shall be of
7433 the same type as case-expr. For character type, length differences
7434 are allowed, but the kind type parameters shall be the same. */
7436 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7438 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7439 &e
->where
, case_expr
->ts
.kind
);
7443 /* Convert the case value kind to that of case expression kind,
7446 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7447 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7451 gfc_error ("Expression in CASE statement at %L must be scalar",
7460 /* Given a completely parsed select statement, we:
7462 - Validate all expressions and code within the SELECT.
7463 - Make sure that the selection expression is not of the wrong type.
7464 - Make sure that no case ranges overlap.
7465 - Eliminate unreachable cases and unreachable code resulting from
7466 removing case labels.
7468 The standard does allow unreachable cases, e.g. CASE (5:3). But
7469 they are a hassle for code generation, and to prevent that, we just
7470 cut them out here. This is not necessary for overlapping cases
7471 because they are illegal and we never even try to generate code.
7473 We have the additional caveat that a SELECT construct could have
7474 been a computed GOTO in the source code. Fortunately we can fairly
7475 easily work around that here: The case_expr for a "real" SELECT CASE
7476 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7477 we have to do is make sure that the case_expr is a scalar integer
7481 resolve_select (gfc_code
*code
, bool select_type
)
7484 gfc_expr
*case_expr
;
7485 gfc_case
*cp
, *default_case
, *tail
, *head
;
7486 int seen_unreachable
;
7492 if (code
->expr1
== NULL
)
7494 /* This was actually a computed GOTO statement. */
7495 case_expr
= code
->expr2
;
7496 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7497 gfc_error ("Selection expression in computed GOTO statement "
7498 "at %L must be a scalar integer expression",
7501 /* Further checking is not necessary because this SELECT was built
7502 by the compiler, so it should always be OK. Just move the
7503 case_expr from expr2 to expr so that we can handle computed
7504 GOTOs as normal SELECTs from here on. */
7505 code
->expr1
= code
->expr2
;
7510 case_expr
= code
->expr1
;
7511 type
= case_expr
->ts
.type
;
7514 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7516 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7517 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7519 /* Punt. Going on here just produce more garbage error messages. */
7524 if (!select_type
&& case_expr
->rank
!= 0)
7526 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7527 "expression", &case_expr
->where
);
7533 /* Raise a warning if an INTEGER case value exceeds the range of
7534 the case-expr. Later, all expressions will be promoted to the
7535 largest kind of all case-labels. */
7537 if (type
== BT_INTEGER
)
7538 for (body
= code
->block
; body
; body
= body
->block
)
7539 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7542 && gfc_check_integer_range (cp
->low
->value
.integer
,
7543 case_expr
->ts
.kind
) != ARITH_OK
)
7544 gfc_warning ("Expression in CASE statement at %L is "
7545 "not in the range of %s", &cp
->low
->where
,
7546 gfc_typename (&case_expr
->ts
));
7549 && cp
->low
!= cp
->high
7550 && gfc_check_integer_range (cp
->high
->value
.integer
,
7551 case_expr
->ts
.kind
) != ARITH_OK
)
7552 gfc_warning ("Expression in CASE statement at %L is "
7553 "not in the range of %s", &cp
->high
->where
,
7554 gfc_typename (&case_expr
->ts
));
7557 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7558 of the SELECT CASE expression and its CASE values. Walk the lists
7559 of case values, and if we find a mismatch, promote case_expr to
7560 the appropriate kind. */
7562 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7564 for (body
= code
->block
; body
; body
= body
->block
)
7566 /* Walk the case label list. */
7567 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7569 /* Intercept the DEFAULT case. It does not have a kind. */
7570 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7573 /* Unreachable case ranges are discarded, so ignore. */
7574 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7575 && cp
->low
!= cp
->high
7576 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7580 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7581 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7583 if (cp
->high
!= NULL
7584 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7585 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7590 /* Assume there is no DEFAULT case. */
7591 default_case
= NULL
;
7596 for (body
= code
->block
; body
; body
= body
->block
)
7598 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7600 seen_unreachable
= 0;
7602 /* Walk the case label list, making sure that all case labels
7604 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7606 /* Count the number of cases in the whole construct. */
7609 /* Intercept the DEFAULT case. */
7610 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7612 if (default_case
!= NULL
)
7614 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7615 "by a second DEFAULT CASE at %L",
7616 &default_case
->where
, &cp
->where
);
7627 /* Deal with single value cases and case ranges. Errors are
7628 issued from the validation function. */
7629 if (!validate_case_label_expr (cp
->low
, case_expr
)
7630 || !validate_case_label_expr (cp
->high
, case_expr
))
7636 if (type
== BT_LOGICAL
7637 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7638 || cp
->low
!= cp
->high
))
7640 gfc_error ("Logical range in CASE statement at %L is not "
7641 "allowed", &cp
->low
->where
);
7646 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7649 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7650 if (value
& seen_logical
)
7652 gfc_error ("Constant logical value in CASE statement "
7653 "is repeated at %L",
7658 seen_logical
|= value
;
7661 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7662 && cp
->low
!= cp
->high
7663 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7665 if (gfc_option
.warn_surprising
)
7666 gfc_warning ("Range specification at %L can never "
7667 "be matched", &cp
->where
);
7669 cp
->unreachable
= 1;
7670 seen_unreachable
= 1;
7674 /* If the case range can be matched, it can also overlap with
7675 other cases. To make sure it does not, we put it in a
7676 double linked list here. We sort that with a merge sort
7677 later on to detect any overlapping cases. */
7681 head
->right
= head
->left
= NULL
;
7686 tail
->right
->left
= tail
;
7693 /* It there was a failure in the previous case label, give up
7694 for this case label list. Continue with the next block. */
7698 /* See if any case labels that are unreachable have been seen.
7699 If so, we eliminate them. This is a bit of a kludge because
7700 the case lists for a single case statement (label) is a
7701 single forward linked lists. */
7702 if (seen_unreachable
)
7704 /* Advance until the first case in the list is reachable. */
7705 while (body
->ext
.block
.case_list
!= NULL
7706 && body
->ext
.block
.case_list
->unreachable
)
7708 gfc_case
*n
= body
->ext
.block
.case_list
;
7709 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7711 gfc_free_case_list (n
);
7714 /* Strip all other unreachable cases. */
7715 if (body
->ext
.block
.case_list
)
7717 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7719 if (cp
->next
->unreachable
)
7721 gfc_case
*n
= cp
->next
;
7722 cp
->next
= cp
->next
->next
;
7724 gfc_free_case_list (n
);
7731 /* See if there were overlapping cases. If the check returns NULL,
7732 there was overlap. In that case we don't do anything. If head
7733 is non-NULL, we prepend the DEFAULT case. The sorted list can
7734 then used during code generation for SELECT CASE constructs with
7735 a case expression of a CHARACTER type. */
7738 head
= check_case_overlap (head
);
7740 /* Prepend the default_case if it is there. */
7741 if (head
!= NULL
&& default_case
)
7743 default_case
->left
= NULL
;
7744 default_case
->right
= head
;
7745 head
->left
= default_case
;
7749 /* Eliminate dead blocks that may be the result if we've seen
7750 unreachable case labels for a block. */
7751 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7753 if (body
->block
->ext
.block
.case_list
== NULL
)
7755 /* Cut the unreachable block from the code chain. */
7756 gfc_code
*c
= body
->block
;
7757 body
->block
= c
->block
;
7759 /* Kill the dead block, but not the blocks below it. */
7761 gfc_free_statements (c
);
7765 /* More than two cases is legal but insane for logical selects.
7766 Issue a warning for it. */
7767 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7769 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7774 /* Check if a derived type is extensible. */
7777 gfc_type_is_extensible (gfc_symbol
*sym
)
7779 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7780 || (sym
->attr
.is_class
7781 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7785 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7786 correct as well as possibly the array-spec. */
7789 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7793 gcc_assert (sym
->assoc
);
7794 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7796 /* If this is for SELECT TYPE, the target may not yet be set. In that
7797 case, return. Resolution will be called later manually again when
7799 target
= sym
->assoc
->target
;
7802 gcc_assert (!sym
->assoc
->dangling
);
7804 if (resolve_target
&& !gfc_resolve_expr (target
))
7807 /* For variable targets, we get some attributes from the target. */
7808 if (target
->expr_type
== EXPR_VARIABLE
)
7812 gcc_assert (target
->symtree
);
7813 tsym
= target
->symtree
->n
.sym
;
7815 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7816 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7818 sym
->attr
.target
= tsym
->attr
.target
7819 || gfc_expr_attr (target
).pointer
;
7822 /* Get type if this was not already set. Note that it can be
7823 some other type than the target in case this is a SELECT TYPE
7824 selector! So we must not update when the type is already there. */
7825 if (sym
->ts
.type
== BT_UNKNOWN
)
7826 sym
->ts
= target
->ts
;
7827 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7829 /* See if this is a valid association-to-variable. */
7830 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7831 && !gfc_has_vector_subscript (target
));
7833 /* Finally resolve if this is an array or not. */
7834 if (sym
->attr
.dimension
&& target
->rank
== 0)
7836 gfc_error ("Associate-name '%s' at %L is used as array",
7837 sym
->name
, &sym
->declared_at
);
7838 sym
->attr
.dimension
= 0;
7842 /* We cannot deal with class selectors that need temporaries. */
7843 if (target
->ts
.type
== BT_CLASS
7844 && gfc_ref_needs_temporary_p (target
->ref
))
7846 gfc_error ("CLASS selector at %L needs a temporary which is not "
7847 "yet implemented", &target
->where
);
7851 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7852 sym
->attr
.dimension
= 1;
7853 else if (target
->ts
.type
== BT_CLASS
)
7854 gfc_fix_class_refs (target
);
7856 /* The associate-name will have a correct type by now. Make absolutely
7857 sure that it has not picked up a dimension attribute. */
7858 if (sym
->ts
.type
== BT_CLASS
)
7859 sym
->attr
.dimension
= 0;
7861 if (sym
->attr
.dimension
)
7863 sym
->as
= gfc_get_array_spec ();
7864 sym
->as
->rank
= target
->rank
;
7865 sym
->as
->type
= AS_DEFERRED
;
7867 /* Target must not be coindexed, thus the associate-variable
7869 sym
->as
->corank
= 0;
7872 /* Mark this as an associate variable. */
7873 sym
->attr
.associate_var
= 1;
7875 /* If the target is a good class object, so is the associate variable. */
7876 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7877 sym
->attr
.class_ok
= 1;
7881 /* Resolve a SELECT TYPE statement. */
7884 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7886 gfc_symbol
*selector_type
;
7887 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7888 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7891 char name
[GFC_MAX_SYMBOL_LEN
];
7896 ns
= code
->ext
.block
.ns
;
7899 /* Check for F03:C813. */
7900 if (code
->expr1
->ts
.type
!= BT_CLASS
7901 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7903 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7904 "at %L", &code
->loc
);
7908 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7913 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7914 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7915 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7917 /* F2008: C803 The selector expression must not be coindexed. */
7918 if (gfc_is_coindexed (code
->expr2
))
7920 gfc_error ("Selector at %L must not be coindexed",
7921 &code
->expr2
->where
);
7928 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7930 if (gfc_is_coindexed (code
->expr1
))
7932 gfc_error ("Selector at %L must not be coindexed",
7933 &code
->expr1
->where
);
7938 /* Loop over TYPE IS / CLASS IS cases. */
7939 for (body
= code
->block
; body
; body
= body
->block
)
7941 c
= body
->ext
.block
.case_list
;
7943 /* Check F03:C815. */
7944 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7945 && !selector_type
->attr
.unlimited_polymorphic
7946 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7948 gfc_error ("Derived type '%s' at %L must be extensible",
7949 c
->ts
.u
.derived
->name
, &c
->where
);
7954 /* Check F03:C816. */
7955 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
7956 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
7957 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
7959 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7960 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7961 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7963 gfc_error ("Unexpected intrinsic type '%s' at %L",
7964 gfc_basic_typename (c
->ts
.type
), &c
->where
);
7969 /* Check F03:C814. */
7970 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
7972 gfc_error ("The type-spec at %L shall specify that each length "
7973 "type parameter is assumed", &c
->where
);
7978 /* Intercept the DEFAULT case. */
7979 if (c
->ts
.type
== BT_UNKNOWN
)
7981 /* Check F03:C818. */
7984 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7985 "by a second DEFAULT CASE at %L",
7986 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7991 default_case
= body
;
7998 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7999 target if present. If there are any EXIT statements referring to the
8000 SELECT TYPE construct, this is no problem because the gfc_code
8001 reference stays the same and EXIT is equally possible from the BLOCK
8002 it is changed to. */
8003 code
->op
= EXEC_BLOCK
;
8006 gfc_association_list
* assoc
;
8008 assoc
= gfc_get_association_list ();
8009 assoc
->st
= code
->expr1
->symtree
;
8010 assoc
->target
= gfc_copy_expr (code
->expr2
);
8011 assoc
->target
->where
= code
->expr2
->where
;
8012 /* assoc->variable will be set by resolve_assoc_var. */
8014 code
->ext
.block
.assoc
= assoc
;
8015 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8017 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8020 code
->ext
.block
.assoc
= NULL
;
8022 /* Add EXEC_SELECT to switch on type. */
8023 new_st
= gfc_get_code (code
->op
);
8024 new_st
->expr1
= code
->expr1
;
8025 new_st
->expr2
= code
->expr2
;
8026 new_st
->block
= code
->block
;
8027 code
->expr1
= code
->expr2
= NULL
;
8032 ns
->code
->next
= new_st
;
8034 code
->op
= EXEC_SELECT
;
8036 gfc_add_vptr_component (code
->expr1
);
8037 gfc_add_hash_component (code
->expr1
);
8039 /* Loop over TYPE IS / CLASS IS cases. */
8040 for (body
= code
->block
; body
; body
= body
->block
)
8042 c
= body
->ext
.block
.case_list
;
8044 if (c
->ts
.type
== BT_DERIVED
)
8045 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8046 c
->ts
.u
.derived
->hash_value
);
8047 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8052 ivtab
= gfc_find_intrinsic_vtab (&c
->ts
);
8053 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8054 e
= CLASS_DATA (ivtab
)->initializer
;
8055 c
->low
= c
->high
= gfc_copy_expr (e
);
8058 else if (c
->ts
.type
== BT_UNKNOWN
)
8061 /* Associate temporary to selector. This should only be done
8062 when this case is actually true, so build a new ASSOCIATE
8063 that does precisely this here (instead of using the
8066 if (c
->ts
.type
== BT_CLASS
)
8067 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8068 else if (c
->ts
.type
== BT_DERIVED
)
8069 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8070 else if (c
->ts
.type
== BT_CHARACTER
)
8072 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8073 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8074 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8075 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8076 charlen
, c
->ts
.kind
);
8079 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8082 st
= gfc_find_symtree (ns
->sym_root
, name
);
8083 gcc_assert (st
->n
.sym
->assoc
);
8084 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8085 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8086 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8087 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8089 new_st
= gfc_get_code (EXEC_BLOCK
);
8090 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8091 new_st
->ext
.block
.ns
->code
= body
->next
;
8092 body
->next
= new_st
;
8094 /* Chain in the new list only if it is marked as dangling. Otherwise
8095 there is a CASE label overlap and this is already used. Just ignore,
8096 the error is diagnosed elsewhere. */
8097 if (st
->n
.sym
->assoc
->dangling
)
8099 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8100 st
->n
.sym
->assoc
->dangling
= 0;
8103 resolve_assoc_var (st
->n
.sym
, false);
8106 /* Take out CLASS IS cases for separate treatment. */
8108 while (body
&& body
->block
)
8110 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8112 /* Add to class_is list. */
8113 if (class_is
== NULL
)
8115 class_is
= body
->block
;
8120 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8121 tail
->block
= body
->block
;
8124 /* Remove from EXEC_SELECT list. */
8125 body
->block
= body
->block
->block
;
8138 /* Add a default case to hold the CLASS IS cases. */
8139 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8140 tail
->block
= gfc_get_code (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 (EXEC_IF
);
8186 for (body
= class_is
; body
; body
= body
->block
)
8188 new_st
->block
= gfc_get_code (EXEC_IF
);
8189 new_st
= new_st
->block
;
8190 /* Set up IF condition: Call _gfortran_is_extension_of. */
8191 new_st
->expr1
= gfc_get_expr ();
8192 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8193 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8194 new_st
->expr1
->ts
.kind
= 4;
8195 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8196 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8197 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8198 /* Set up arguments. */
8199 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8200 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8201 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8202 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8203 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8204 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8205 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8206 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8207 new_st
->next
= body
->next
;
8209 if (default_case
->next
)
8211 new_st
->block
= gfc_get_code (EXEC_IF
);
8212 new_st
= new_st
->block
;
8213 new_st
->next
= default_case
->next
;
8216 /* Replace CLASS DEFAULT code by the IF chain. */
8217 default_case
->next
= if_st
;
8220 /* Resolve the internal code. This can not be done earlier because
8221 it requires that the sym->assoc of selectors is set already. */
8222 gfc_current_ns
= ns
;
8223 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8224 gfc_current_ns
= old_ns
;
8226 resolve_select (code
, true);
8230 /* Resolve a transfer statement. This is making sure that:
8231 -- a derived type being transferred has only non-pointer components
8232 -- a derived type being transferred doesn't have private components, unless
8233 it's being transferred from the module where the type was defined
8234 -- we're not trying to transfer a whole assumed size array. */
8237 resolve_transfer (gfc_code
*code
)
8246 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8247 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8248 exp
= exp
->value
.op
.op1
;
8250 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8252 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8253 "MOLD=", &exp
->where
);
8257 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8258 && exp
->expr_type
!= EXPR_FUNCTION
))
8261 /* If we are reading, the variable will be changed. Note that
8262 code->ext.dt may be NULL if the TRANSFER is related to
8263 an INQUIRE statement -- but in this case, we are not reading, either. */
8264 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8265 && !gfc_check_vardef_context (exp
, false, false, false,
8269 sym
= exp
->symtree
->n
.sym
;
8272 /* Go to actual component transferred. */
8273 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8274 if (ref
->type
== REF_COMPONENT
)
8275 ts
= &ref
->u
.c
.component
->ts
;
8277 if (ts
->type
== BT_CLASS
)
8279 /* FIXME: Test for defined input/output. */
8280 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8281 "it is processed by a defined input/output procedure",
8286 if (ts
->type
== BT_DERIVED
)
8288 /* Check that transferred derived type doesn't contain POINTER
8290 if (ts
->u
.derived
->attr
.pointer_comp
)
8292 gfc_error ("Data transfer element at %L cannot have POINTER "
8293 "components unless it is processed by a defined "
8294 "input/output procedure", &code
->loc
);
8299 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8301 gfc_error ("Data transfer element at %L cannot have "
8302 "procedure pointer components", &code
->loc
);
8306 if (ts
->u
.derived
->attr
.alloc_comp
)
8308 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8309 "components unless it is processed by a defined "
8310 "input/output procedure", &code
->loc
);
8314 /* C_PTR and C_FUNPTR have private components which means they can not
8315 be printed. However, if -std=gnu and not -pedantic, allow
8316 the component to be printed to help debugging. */
8317 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8319 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8320 "cannot have PRIVATE components", &code
->loc
))
8323 else if (derived_inaccessible (ts
->u
.derived
))
8325 gfc_error ("Data transfer element at %L cannot have "
8326 "PRIVATE components",&code
->loc
);
8331 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8332 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8334 gfc_error ("Data transfer element at %L cannot be a full reference to "
8335 "an assumed-size array", &code
->loc
);
8341 /*********** Toplevel code resolution subroutines ***********/
8343 /* Find the set of labels that are reachable from this block. We also
8344 record the last statement in each block. */
8347 find_reachable_labels (gfc_code
*block
)
8354 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8356 /* Collect labels in this block. We don't keep those corresponding
8357 to END {IF|SELECT}, these are checked in resolve_branch by going
8358 up through the code_stack. */
8359 for (c
= block
; c
; c
= c
->next
)
8361 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8362 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8365 /* Merge with labels from parent block. */
8368 gcc_assert (cs_base
->prev
->reachable_labels
);
8369 bitmap_ior_into (cs_base
->reachable_labels
,
8370 cs_base
->prev
->reachable_labels
);
8376 resolve_lock_unlock (gfc_code
*code
)
8378 if (code
->expr1
->ts
.type
!= BT_DERIVED
8379 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8380 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8381 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8382 || code
->expr1
->rank
!= 0
8383 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8384 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8385 &code
->expr1
->where
);
8389 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8390 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8391 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8392 &code
->expr2
->where
);
8395 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8396 _("STAT variable")))
8401 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8402 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8403 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8404 &code
->expr3
->where
);
8407 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8408 _("ERRMSG variable")))
8411 /* Check ACQUIRED_LOCK. */
8413 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8414 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8415 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8416 "variable", &code
->expr4
->where
);
8419 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8420 _("ACQUIRED_LOCK variable")))
8426 resolve_sync (gfc_code
*code
)
8428 /* Check imageset. The * case matches expr1 == NULL. */
8431 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8432 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8433 "INTEGER expression", &code
->expr1
->where
);
8434 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8435 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8436 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8437 &code
->expr1
->where
);
8438 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8439 && gfc_simplify_expr (code
->expr1
, 0))
8441 gfc_constructor
*cons
;
8442 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8443 for (; cons
; cons
= gfc_constructor_next (cons
))
8444 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8445 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8446 gfc_error ("Imageset argument at %L must between 1 and "
8447 "num_images()", &cons
->expr
->where
);
8453 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8454 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8455 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8456 &code
->expr2
->where
);
8460 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8461 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8462 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8463 &code
->expr3
->where
);
8467 /* Given a branch to a label, see if the branch is conforming.
8468 The code node describes where the branch is located. */
8471 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8478 /* Step one: is this a valid branching target? */
8480 if (label
->defined
== ST_LABEL_UNKNOWN
)
8482 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8487 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8489 gfc_error ("Statement at %L is not a valid branch target statement "
8490 "for the branch statement at %L", &label
->where
, &code
->loc
);
8494 /* Step two: make sure this branch is not a branch to itself ;-) */
8496 if (code
->here
== label
)
8498 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8502 /* Step three: See if the label is in the same block as the
8503 branching statement. The hard work has been done by setting up
8504 the bitmap reachable_labels. */
8506 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8508 /* Check now whether there is a CRITICAL construct; if so, check
8509 whether the label is still visible outside of the CRITICAL block,
8510 which is invalid. */
8511 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8513 if (stack
->current
->op
== EXEC_CRITICAL
8514 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8515 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8516 "label at %L", &code
->loc
, &label
->where
);
8517 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8518 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8519 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8520 "for label at %L", &code
->loc
, &label
->where
);
8526 /* Step four: If we haven't found the label in the bitmap, it may
8527 still be the label of the END of the enclosing block, in which
8528 case we find it by going up the code_stack. */
8530 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8532 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8534 if (stack
->current
->op
== EXEC_CRITICAL
)
8536 /* Note: A label at END CRITICAL does not leave the CRITICAL
8537 construct as END CRITICAL is still part of it. */
8538 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8539 " at %L", &code
->loc
, &label
->where
);
8542 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8544 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8545 "label at %L", &code
->loc
, &label
->where
);
8552 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8556 /* The label is not in an enclosing block, so illegal. This was
8557 allowed in Fortran 66, so we allow it as extension. No
8558 further checks are necessary in this case. */
8559 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8560 "as the GOTO statement at %L", &label
->where
,
8566 /* Check whether EXPR1 has the same shape as EXPR2. */
8569 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8571 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8572 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8573 bool result
= false;
8576 /* Compare the rank. */
8577 if (expr1
->rank
!= expr2
->rank
)
8580 /* Compare the size of each dimension. */
8581 for (i
=0; i
<expr1
->rank
; i
++)
8583 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8586 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8589 if (mpz_cmp (shape
[i
], shape2
[i
]))
8593 /* When either of the two expression is an assumed size array, we
8594 ignore the comparison of dimension sizes. */
8599 gfc_clear_shape (shape
, i
);
8600 gfc_clear_shape (shape2
, i
);
8605 /* Check whether a WHERE assignment target or a WHERE mask expression
8606 has the same shape as the outmost WHERE mask expression. */
8609 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8615 cblock
= code
->block
;
8617 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8618 In case of nested WHERE, only the outmost one is stored. */
8619 if (mask
== NULL
) /* outmost WHERE */
8621 else /* inner WHERE */
8628 /* Check if the mask-expr has a consistent shape with the
8629 outmost WHERE mask-expr. */
8630 if (!resolve_where_shape (cblock
->expr1
, e
))
8631 gfc_error ("WHERE mask at %L has inconsistent shape",
8632 &cblock
->expr1
->where
);
8635 /* the assignment statement of a WHERE statement, or the first
8636 statement in where-body-construct of a WHERE construct */
8637 cnext
= cblock
->next
;
8642 /* WHERE assignment statement */
8645 /* Check shape consistent for WHERE assignment target. */
8646 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8647 gfc_error ("WHERE assignment target at %L has "
8648 "inconsistent shape", &cnext
->expr1
->where
);
8652 case EXEC_ASSIGN_CALL
:
8653 resolve_call (cnext
);
8654 if (!cnext
->resolved_sym
->attr
.elemental
)
8655 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8656 &cnext
->ext
.actual
->expr
->where
);
8659 /* WHERE or WHERE construct is part of a where-body-construct */
8661 resolve_where (cnext
, e
);
8665 gfc_error ("Unsupported statement inside WHERE at %L",
8668 /* the next statement within the same where-body-construct */
8669 cnext
= cnext
->next
;
8671 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8672 cblock
= cblock
->block
;
8677 /* Resolve assignment in FORALL construct.
8678 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8679 FORALL index variables. */
8682 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8686 for (n
= 0; n
< nvar
; n
++)
8688 gfc_symbol
*forall_index
;
8690 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8692 /* Check whether the assignment target is one of the FORALL index
8694 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8695 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8696 gfc_error ("Assignment to a FORALL index variable at %L",
8697 &code
->expr1
->where
);
8700 /* If one of the FORALL index variables doesn't appear in the
8701 assignment variable, then there could be a many-to-one
8702 assignment. Emit a warning rather than an error because the
8703 mask could be resolving this problem. */
8704 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8705 gfc_warning ("The FORALL with index '%s' is not used on the "
8706 "left side of the assignment at %L and so might "
8707 "cause multiple assignment to this object",
8708 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8714 /* Resolve WHERE statement in FORALL construct. */
8717 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8718 gfc_expr
**var_expr
)
8723 cblock
= code
->block
;
8726 /* the assignment statement of a WHERE statement, or the first
8727 statement in where-body-construct of a WHERE construct */
8728 cnext
= cblock
->next
;
8733 /* WHERE assignment statement */
8735 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8738 /* WHERE operator assignment statement */
8739 case EXEC_ASSIGN_CALL
:
8740 resolve_call (cnext
);
8741 if (!cnext
->resolved_sym
->attr
.elemental
)
8742 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8743 &cnext
->ext
.actual
->expr
->where
);
8746 /* WHERE or WHERE construct is part of a where-body-construct */
8748 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8752 gfc_error ("Unsupported statement inside WHERE at %L",
8755 /* the next statement within the same where-body-construct */
8756 cnext
= cnext
->next
;
8758 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8759 cblock
= cblock
->block
;
8764 /* Traverse the FORALL body to check whether the following errors exist:
8765 1. For assignment, check if a many-to-one assignment happens.
8766 2. For WHERE statement, check the WHERE body to see if there is any
8767 many-to-one assignment. */
8770 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8774 c
= code
->block
->next
;
8780 case EXEC_POINTER_ASSIGN
:
8781 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8784 case EXEC_ASSIGN_CALL
:
8788 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8789 there is no need to handle it here. */
8793 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8798 /* The next statement in the FORALL body. */
8804 /* Counts the number of iterators needed inside a forall construct, including
8805 nested forall constructs. This is used to allocate the needed memory
8806 in gfc_resolve_forall. */
8809 gfc_count_forall_iterators (gfc_code
*code
)
8811 int max_iters
, sub_iters
, current_iters
;
8812 gfc_forall_iterator
*fa
;
8814 gcc_assert(code
->op
== EXEC_FORALL
);
8818 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8821 code
= code
->block
->next
;
8825 if (code
->op
== EXEC_FORALL
)
8827 sub_iters
= gfc_count_forall_iterators (code
);
8828 if (sub_iters
> max_iters
)
8829 max_iters
= sub_iters
;
8834 return current_iters
+ max_iters
;
8838 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8839 gfc_resolve_forall_body to resolve the FORALL body. */
8842 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8844 static gfc_expr
**var_expr
;
8845 static int total_var
= 0;
8846 static int nvar
= 0;
8848 gfc_forall_iterator
*fa
;
8853 /* Start to resolve a FORALL construct */
8854 if (forall_save
== 0)
8856 /* Count the total number of FORALL index in the nested FORALL
8857 construct in order to allocate the VAR_EXPR with proper size. */
8858 total_var
= gfc_count_forall_iterators (code
);
8860 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8861 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8864 /* The information about FORALL iterator, including FORALL index start, end
8865 and stride. The FORALL index can not appear in start, end or stride. */
8866 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8868 /* Check if any outer FORALL index name is the same as the current
8870 for (i
= 0; i
< nvar
; i
++)
8872 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8874 gfc_error ("An outer FORALL construct already has an index "
8875 "with this name %L", &fa
->var
->where
);
8879 /* Record the current FORALL index. */
8880 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8884 /* No memory leak. */
8885 gcc_assert (nvar
<= total_var
);
8888 /* Resolve the FORALL body. */
8889 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8891 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8892 gfc_resolve_blocks (code
->block
, ns
);
8896 /* Free only the VAR_EXPRs allocated in this frame. */
8897 for (i
= nvar
; i
< tmp
; i
++)
8898 gfc_free_expr (var_expr
[i
]);
8902 /* We are in the outermost FORALL construct. */
8903 gcc_assert (forall_save
== 0);
8905 /* VAR_EXPR is not needed any more. */
8912 /* Resolve a BLOCK construct statement. */
8915 resolve_block_construct (gfc_code
* code
)
8917 /* Resolve the BLOCK's namespace. */
8918 gfc_resolve (code
->ext
.block
.ns
);
8920 /* For an ASSOCIATE block, the associations (and their targets) are already
8921 resolved during resolve_symbol. */
8925 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8928 static void resolve_code (gfc_code
*, gfc_namespace
*);
8931 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8935 for (; b
; b
= b
->block
)
8937 t
= gfc_resolve_expr (b
->expr1
);
8938 if (!gfc_resolve_expr (b
->expr2
))
8944 if (t
&& b
->expr1
!= NULL
8945 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8946 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8953 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8954 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8959 resolve_branch (b
->label1
, b
);
8963 resolve_block_construct (b
);
8967 case EXEC_SELECT_TYPE
:
8971 case EXEC_DO_CONCURRENT
:
8979 case EXEC_OMP_ATOMIC
:
8980 case EXEC_OMP_CRITICAL
:
8982 case EXEC_OMP_MASTER
:
8983 case EXEC_OMP_ORDERED
:
8984 case EXEC_OMP_PARALLEL
:
8985 case EXEC_OMP_PARALLEL_DO
:
8986 case EXEC_OMP_PARALLEL_SECTIONS
:
8987 case EXEC_OMP_PARALLEL_WORKSHARE
:
8988 case EXEC_OMP_SECTIONS
:
8989 case EXEC_OMP_SINGLE
:
8991 case EXEC_OMP_TASKWAIT
:
8992 case EXEC_OMP_TASKYIELD
:
8993 case EXEC_OMP_WORKSHARE
:
8997 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9000 resolve_code (b
->next
, ns
);
9005 /* Does everything to resolve an ordinary assignment. Returns true
9006 if this is an interface assignment. */
9008 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9017 symbol_attribute attr
;
9019 if (gfc_extend_assign (code
, ns
))
9023 if (code
->op
== EXEC_ASSIGN_CALL
)
9025 lhs
= code
->ext
.actual
->expr
;
9026 rhsptr
= &code
->ext
.actual
->next
->expr
;
9030 gfc_actual_arglist
* args
;
9031 gfc_typebound_proc
* tbp
;
9033 gcc_assert (code
->op
== EXEC_COMPCALL
);
9035 args
= code
->expr1
->value
.compcall
.actual
;
9037 rhsptr
= &args
->next
->expr
;
9039 tbp
= code
->expr1
->value
.compcall
.tbp
;
9040 gcc_assert (!tbp
->is_generic
);
9043 /* Make a temporary rhs when there is a default initializer
9044 and rhs is the same symbol as the lhs. */
9045 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9046 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9047 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9048 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9049 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9058 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9059 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9063 /* Handle the case of a BOZ literal on the RHS. */
9064 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9067 if (gfc_option
.warn_surprising
)
9068 gfc_warning ("BOZ literal at %L is bitwise transferred "
9069 "non-integer symbol '%s'", &code
->loc
,
9070 lhs
->symtree
->n
.sym
->name
);
9072 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9074 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9076 if (rc
== ARITH_UNDERFLOW
)
9077 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9078 ". This check can be disabled with the option "
9079 "-fno-range-check", &rhs
->where
);
9080 else if (rc
== ARITH_OVERFLOW
)
9081 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9082 ". This check can be disabled with the option "
9083 "-fno-range-check", &rhs
->where
);
9084 else if (rc
== ARITH_NAN
)
9085 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9086 ". This check can be disabled with the option "
9087 "-fno-range-check", &rhs
->where
);
9092 if (lhs
->ts
.type
== BT_CHARACTER
9093 && gfc_option
.warn_character_truncation
)
9095 if (lhs
->ts
.u
.cl
!= NULL
9096 && lhs
->ts
.u
.cl
->length
!= NULL
9097 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9098 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9100 if (rhs
->expr_type
== EXPR_CONSTANT
)
9101 rlen
= rhs
->value
.character
.length
;
9103 else if (rhs
->ts
.u
.cl
!= NULL
9104 && rhs
->ts
.u
.cl
->length
!= NULL
9105 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9106 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9108 if (rlen
&& llen
&& rlen
> llen
)
9109 gfc_warning_now ("CHARACTER expression will be truncated "
9110 "in assignment (%d/%d) at %L",
9111 llen
, rlen
, &code
->loc
);
9114 /* Ensure that a vector index expression for the lvalue is evaluated
9115 to a temporary if the lvalue symbol is referenced in it. */
9118 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9119 if (ref
->type
== REF_ARRAY
)
9121 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9122 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9123 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9124 ref
->u
.ar
.start
[n
]))
9126 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9130 if (gfc_pure (NULL
))
9132 if (lhs
->ts
.type
== BT_DERIVED
9133 && lhs
->expr_type
== EXPR_VARIABLE
9134 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9135 && rhs
->expr_type
== EXPR_VARIABLE
9136 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9137 || gfc_is_coindexed (rhs
)))
9140 if (gfc_is_coindexed (rhs
))
9141 gfc_error ("Coindexed expression at %L is assigned to "
9142 "a derived type variable with a POINTER "
9143 "component in a PURE procedure",
9146 gfc_error ("The impure variable at %L is assigned to "
9147 "a derived type variable with a POINTER "
9148 "component in a PURE procedure (12.6)",
9153 /* Fortran 2008, C1283. */
9154 if (gfc_is_coindexed (lhs
))
9156 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9157 "procedure", &rhs
->where
);
9162 if (gfc_implicit_pure (NULL
))
9164 if (lhs
->expr_type
== EXPR_VARIABLE
9165 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9166 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9167 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9169 if (lhs
->ts
.type
== BT_DERIVED
9170 && lhs
->expr_type
== EXPR_VARIABLE
9171 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9172 && rhs
->expr_type
== EXPR_VARIABLE
9173 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9174 || gfc_is_coindexed (rhs
)))
9175 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9177 /* Fortran 2008, C1283. */
9178 if (gfc_is_coindexed (lhs
))
9179 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9182 /* F2008, 7.2.1.2. */
9183 attr
= gfc_expr_attr (lhs
);
9184 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9186 if (attr
.codimension
)
9188 gfc_error ("Assignment to polymorphic coarray at %L is not "
9189 "permitted", &lhs
->where
);
9192 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9193 "polymorphic variable at %L", &lhs
->where
))
9195 if (!gfc_option
.flag_realloc_lhs
)
9197 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9198 "requires -frealloc-lhs", &lhs
->where
);
9202 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9203 "is not yet supported", &lhs
->where
);
9206 else if (lhs
->ts
.type
== BT_CLASS
)
9208 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9209 "assignment at %L - check that there is a matching specific "
9210 "subroutine for '=' operator", &lhs
->where
);
9214 /* F2008, Section 7.2.1.2. */
9215 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9217 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9218 "component in assignment at %L", &lhs
->where
);
9222 gfc_check_assign (lhs
, rhs
, 1);
9227 /* Add a component reference onto an expression. */
9230 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9235 ref
= &((*ref
)->next
);
9236 *ref
= gfc_get_ref ();
9237 (*ref
)->type
= REF_COMPONENT
;
9238 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9239 (*ref
)->u
.c
.component
= c
;
9242 /* Add a full array ref, as necessary. */
9245 gfc_add_full_array_ref (e
, c
->as
);
9246 e
->rank
= c
->as
->rank
;
9251 /* Build an assignment. Keep the argument 'op' for future use, so that
9252 pointer assignments can be made. */
9255 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9256 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9258 gfc_code
*this_code
;
9260 this_code
= gfc_get_code (op
);
9261 this_code
->next
= NULL
;
9262 this_code
->expr1
= gfc_copy_expr (expr1
);
9263 this_code
->expr2
= gfc_copy_expr (expr2
);
9264 this_code
->loc
= loc
;
9267 add_comp_ref (this_code
->expr1
, comp1
);
9268 add_comp_ref (this_code
->expr2
, comp2
);
9275 /* Makes a temporary variable expression based on the characteristics of
9276 a given variable expression. */
9279 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9281 static int serial
= 0;
9282 char name
[GFC_MAX_SYMBOL_LEN
];
9285 gfc_array_ref
*aref
;
9288 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9289 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9290 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9296 /* This function could be expanded to support other expression type
9297 but this is not needed here. */
9298 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9300 /* Obtain the arrayspec for the temporary. */
9303 aref
= gfc_find_array_ref (e
);
9304 if (e
->expr_type
== EXPR_VARIABLE
9305 && e
->symtree
->n
.sym
->as
== aref
->as
)
9309 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9310 if (ref
->type
== REF_COMPONENT
9311 && ref
->u
.c
.component
->as
== aref
->as
)
9319 /* Add the attributes and the arrayspec to the temporary. */
9320 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9321 tmp
->n
.sym
->attr
.function
= 0;
9322 tmp
->n
.sym
->attr
.result
= 0;
9323 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9327 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9330 if (as
->type
== AS_DEFERRED
)
9331 tmp
->n
.sym
->attr
.allocatable
= 1;
9334 tmp
->n
.sym
->attr
.dimension
= 0;
9336 gfc_set_sym_referenced (tmp
->n
.sym
);
9337 gfc_commit_symbol (tmp
->n
.sym
);
9338 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9340 /* Should the lhs be a section, use its array ref for the
9341 temporary expression. */
9342 if (aref
&& aref
->type
!= AR_FULL
)
9344 gfc_free_ref_list (e
->ref
);
9345 e
->ref
= gfc_copy_ref (ref
);
9351 /* Add one line of code to the code chain, making sure that 'head' and
9352 'tail' are appropriately updated. */
9355 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9357 gcc_assert (this_code
);
9359 *head
= *tail
= *this_code
;
9361 *tail
= gfc_append_code (*tail
, *this_code
);
9366 /* Counts the potential number of part array references that would
9367 result from resolution of typebound defined assignments. */
9370 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9373 int c_depth
= 0, t_depth
;
9375 for (c
= derived
->components
; c
; c
= c
->next
)
9377 if ((c
->ts
.type
!= BT_DERIVED
9379 || c
->attr
.allocatable
9380 || c
->attr
.proc_pointer_comp
9381 || c
->attr
.class_pointer
9382 || c
->attr
.proc_pointer
)
9383 && !c
->attr
.defined_assign_comp
)
9386 if (c
->as
&& c_depth
== 0)
9389 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9390 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9395 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9397 return depth
+ c_depth
;
9401 /* Implement 7.2.1.3 of the F08 standard:
9402 "An intrinsic assignment where the variable is of derived type is
9403 performed as if each component of the variable were assigned from the
9404 corresponding component of expr using pointer assignment (7.2.2) for
9405 each pointer component, defined assignment for each nonpointer
9406 nonallocatable component of a type that has a type-bound defined
9407 assignment consistent with the component, intrinsic assignment for
9408 each other nonpointer nonallocatable component, ..."
9410 The pointer assignments are taken care of by the intrinsic
9411 assignment of the structure itself. This function recursively adds
9412 defined assignments where required. The recursion is accomplished
9413 by calling resolve_code.
9415 When the lhs in a defined assignment has intent INOUT, we need a
9416 temporary for the lhs. In pseudo-code:
9418 ! Only call function lhs once.
9419 if (lhs is not a constant or an variable)
9422 ! Do the intrinsic assignment
9424 ! Now do the defined assignments
9425 do over components with typebound defined assignment [%cmp]
9426 #if one component's assignment procedure is INOUT
9428 #if expr2 non-variable
9434 t1%cmp {defined=} expr2%cmp
9440 expr1%cmp {defined=} expr2%cmp
9444 /* The temporary assignments have to be put on top of the additional
9445 code to avoid the result being changed by the intrinsic assignment.
9447 static int component_assignment_level
= 0;
9448 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9451 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9453 gfc_component
*comp1
, *comp2
;
9454 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9456 int error_count
, depth
;
9458 gfc_get_errors (NULL
, &error_count
);
9460 /* Filter out continuing processing after an error. */
9462 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9463 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9466 /* TODO: Handle more than one part array reference in assignments. */
9467 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9468 (*code
)->expr1
->rank
? 1 : 0);
9471 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9472 "done because multiple part array references would "
9473 "occur in intermediate expressions.", &(*code
)->loc
);
9477 component_assignment_level
++;
9479 /* Create a temporary so that functions get called only once. */
9480 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9481 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9485 /* Assign the rhs to the temporary. */
9486 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9487 this_code
= build_assignment (EXEC_ASSIGN
,
9488 tmp_expr
, (*code
)->expr2
,
9489 NULL
, NULL
, (*code
)->loc
);
9490 /* Add the code and substitute the rhs expression. */
9491 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9492 gfc_free_expr ((*code
)->expr2
);
9493 (*code
)->expr2
= tmp_expr
;
9496 /* Do the intrinsic assignment. This is not needed if the lhs is one
9497 of the temporaries generated here, since the intrinsic assignment
9498 to the final result already does this. */
9499 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9501 this_code
= build_assignment (EXEC_ASSIGN
,
9502 (*code
)->expr1
, (*code
)->expr2
,
9503 NULL
, NULL
, (*code
)->loc
);
9504 add_code_to_chain (&this_code
, &head
, &tail
);
9507 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9508 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9511 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9515 /* The intrinsic assignment does the right thing for pointers
9516 of all kinds and allocatable components. */
9517 if (comp1
->ts
.type
!= BT_DERIVED
9518 || comp1
->attr
.pointer
9519 || comp1
->attr
.allocatable
9520 || comp1
->attr
.proc_pointer_comp
9521 || comp1
->attr
.class_pointer
9522 || comp1
->attr
.proc_pointer
)
9525 /* Make an assigment for this component. */
9526 this_code
= build_assignment (EXEC_ASSIGN
,
9527 (*code
)->expr1
, (*code
)->expr2
,
9528 comp1
, comp2
, (*code
)->loc
);
9530 /* Convert the assignment if there is a defined assignment for
9531 this type. Otherwise, using the call from resolve_code,
9532 recurse into its components. */
9533 resolve_code (this_code
, ns
);
9535 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9537 gfc_formal_arglist
*dummy_args
;
9539 /* Check that there is a typebound defined assignment. If not,
9540 then this must be a module defined assignment. We cannot
9541 use the defined_assign_comp attribute here because it must
9542 be this derived type that has the defined assignment and not
9544 if (!(comp1
->ts
.u
.derived
->f2k_derived
9545 && comp1
->ts
.u
.derived
->f2k_derived
9546 ->tb_op
[INTRINSIC_ASSIGN
]))
9548 gfc_free_statements (this_code
);
9553 /* If the first argument of the subroutine has intent INOUT
9554 a temporary must be generated and used instead. */
9555 rsym
= this_code
->resolved_sym
;
9556 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9558 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9560 gfc_code
*temp_code
;
9563 /* Build the temporary required for the assignment and put
9564 it at the head of the generated code. */
9567 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9568 temp_code
= build_assignment (EXEC_ASSIGN
,
9570 NULL
, NULL
, (*code
)->loc
);
9572 /* For allocatable LHS, check whether it is allocated. Note
9573 that allocatable components with defined assignment are
9574 not yet support. See PR 57696. */
9575 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9579 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9580 block
= gfc_get_code (EXEC_IF
);
9581 block
->block
= gfc_get_code (EXEC_IF
);
9583 = gfc_build_intrinsic_call (ns
,
9584 GFC_ISYM_ALLOCATED
, "allocated",
9585 (*code
)->loc
, 1, e
);
9586 block
->block
->next
= temp_code
;
9589 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9592 /* Replace the first actual arg with the component of the
9594 gfc_free_expr (this_code
->ext
.actual
->expr
);
9595 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9596 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9598 /* If the LHS variable is allocatable and wasn't allocated and
9599 the temporary is allocatable, pointer assign the address of
9600 the freshly allocated LHS to the temporary. */
9601 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9602 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9607 cond
= gfc_get_expr ();
9608 cond
->ts
.type
= BT_LOGICAL
;
9609 cond
->ts
.kind
= gfc_default_logical_kind
;
9610 cond
->expr_type
= EXPR_OP
;
9611 cond
->where
= (*code
)->loc
;
9612 cond
->value
.op
.op
= INTRINSIC_NOT
;
9613 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9614 GFC_ISYM_ALLOCATED
, "allocated",
9615 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9616 block
= gfc_get_code (EXEC_IF
);
9617 block
->block
= gfc_get_code (EXEC_IF
);
9618 block
->block
->expr1
= cond
;
9619 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9621 NULL
, NULL
, (*code
)->loc
);
9622 add_code_to_chain (&block
, &head
, &tail
);
9626 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9628 /* Don't add intrinsic assignments since they are already
9629 effected by the intrinsic assignment of the structure. */
9630 gfc_free_statements (this_code
);
9635 add_code_to_chain (&this_code
, &head
, &tail
);
9639 /* Transfer the value to the final result. */
9640 this_code
= build_assignment (EXEC_ASSIGN
,
9642 comp1
, comp2
, (*code
)->loc
);
9643 add_code_to_chain (&this_code
, &head
, &tail
);
9647 /* Put the temporary assignments at the top of the generated code. */
9648 if (tmp_head
&& component_assignment_level
== 1)
9650 gfc_append_code (tmp_head
, head
);
9652 tmp_head
= tmp_tail
= NULL
;
9655 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9656 // not accidentally deallocated. Hence, nullify t1.
9657 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9658 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9664 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9665 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9666 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9667 block
= gfc_get_code (EXEC_IF
);
9668 block
->block
= gfc_get_code (EXEC_IF
);
9669 block
->block
->expr1
= cond
;
9670 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9671 t1
, gfc_get_null_expr (&(*code
)->loc
),
9672 NULL
, NULL
, (*code
)->loc
);
9673 gfc_append_code (tail
, block
);
9677 /* Now attach the remaining code chain to the input code. Step on
9678 to the end of the new code since resolution is complete. */
9679 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9680 tail
->next
= (*code
)->next
;
9681 /* Overwrite 'code' because this would place the intrinsic assignment
9682 before the temporary for the lhs is created. */
9683 gfc_free_expr ((*code
)->expr1
);
9684 gfc_free_expr ((*code
)->expr2
);
9690 component_assignment_level
--;
9694 /* Given a block of code, recursively resolve everything pointed to by this
9698 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9700 int omp_workshare_save
;
9701 int forall_save
, do_concurrent_save
;
9705 frame
.prev
= cs_base
;
9709 find_reachable_labels (code
);
9711 for (; code
; code
= code
->next
)
9713 frame
.current
= code
;
9714 forall_save
= forall_flag
;
9715 do_concurrent_save
= gfc_do_concurrent_flag
;
9717 if (code
->op
== EXEC_FORALL
)
9720 gfc_resolve_forall (code
, ns
, forall_save
);
9723 else if (code
->block
)
9725 omp_workshare_save
= -1;
9728 case EXEC_OMP_PARALLEL_WORKSHARE
:
9729 omp_workshare_save
= omp_workshare_flag
;
9730 omp_workshare_flag
= 1;
9731 gfc_resolve_omp_parallel_blocks (code
, ns
);
9733 case EXEC_OMP_PARALLEL
:
9734 case EXEC_OMP_PARALLEL_DO
:
9735 case EXEC_OMP_PARALLEL_SECTIONS
:
9737 omp_workshare_save
= omp_workshare_flag
;
9738 omp_workshare_flag
= 0;
9739 gfc_resolve_omp_parallel_blocks (code
, ns
);
9742 gfc_resolve_omp_do_blocks (code
, ns
);
9744 case EXEC_SELECT_TYPE
:
9745 /* Blocks are handled in resolve_select_type because we have
9746 to transform the SELECT TYPE into ASSOCIATE first. */
9748 case EXEC_DO_CONCURRENT
:
9749 gfc_do_concurrent_flag
= 1;
9750 gfc_resolve_blocks (code
->block
, ns
);
9751 gfc_do_concurrent_flag
= 2;
9753 case EXEC_OMP_WORKSHARE
:
9754 omp_workshare_save
= omp_workshare_flag
;
9755 omp_workshare_flag
= 1;
9758 gfc_resolve_blocks (code
->block
, ns
);
9762 if (omp_workshare_save
!= -1)
9763 omp_workshare_flag
= omp_workshare_save
;
9767 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9768 t
= gfc_resolve_expr (code
->expr1
);
9769 forall_flag
= forall_save
;
9770 gfc_do_concurrent_flag
= do_concurrent_save
;
9772 if (!gfc_resolve_expr (code
->expr2
))
9775 if (code
->op
== EXEC_ALLOCATE
9776 && !gfc_resolve_expr (code
->expr3
))
9782 case EXEC_END_BLOCK
:
9783 case EXEC_END_NESTED_BLOCK
:
9787 case EXEC_ERROR_STOP
:
9791 case EXEC_ASSIGN_CALL
:
9796 case EXEC_SYNC_IMAGES
:
9797 case EXEC_SYNC_MEMORY
:
9798 resolve_sync (code
);
9803 resolve_lock_unlock (code
);
9807 /* Keep track of which entry we are up to. */
9808 current_entry_id
= code
->ext
.entry
->id
;
9812 resolve_where (code
, NULL
);
9816 if (code
->expr1
!= NULL
)
9818 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9819 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9820 "INTEGER variable", &code
->expr1
->where
);
9821 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9822 gfc_error ("Variable '%s' has not been assigned a target "
9823 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9824 &code
->expr1
->where
);
9827 resolve_branch (code
->label1
, code
);
9831 if (code
->expr1
!= NULL
9832 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9833 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9834 "INTEGER return specifier", &code
->expr1
->where
);
9837 case EXEC_INIT_ASSIGN
:
9838 case EXEC_END_PROCEDURE
:
9845 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9849 if (resolve_ordinary_assign (code
, ns
))
9851 if (code
->op
== EXEC_COMPCALL
)
9857 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9858 if (code
->expr1
->ts
.type
== BT_DERIVED
9859 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9860 generate_component_assignments (&code
, ns
);
9864 case EXEC_LABEL_ASSIGN
:
9865 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9866 gfc_error ("Label %d referenced at %L is never defined",
9867 code
->label1
->value
, &code
->label1
->where
);
9869 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9870 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9871 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9872 != gfc_default_integer_kind
9873 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9874 gfc_error ("ASSIGN statement at %L requires a scalar "
9875 "default INTEGER variable", &code
->expr1
->where
);
9878 case EXEC_POINTER_ASSIGN
:
9885 /* This is both a variable definition and pointer assignment
9886 context, so check both of them. For rank remapping, a final
9887 array ref may be present on the LHS and fool gfc_expr_attr
9888 used in gfc_check_vardef_context. Remove it. */
9889 e
= remove_last_array_ref (code
->expr1
);
9890 t
= gfc_check_vardef_context (e
, true, false, false,
9891 _("pointer assignment"));
9893 t
= gfc_check_vardef_context (e
, false, false, false,
9894 _("pointer assignment"));
9899 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9903 case EXEC_ARITHMETIC_IF
:
9905 && code
->expr1
->ts
.type
!= BT_INTEGER
9906 && code
->expr1
->ts
.type
!= BT_REAL
)
9907 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9908 "expression", &code
->expr1
->where
);
9910 resolve_branch (code
->label1
, code
);
9911 resolve_branch (code
->label2
, code
);
9912 resolve_branch (code
->label3
, code
);
9916 if (t
&& code
->expr1
!= NULL
9917 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9918 || code
->expr1
->rank
!= 0))
9919 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9920 &code
->expr1
->where
);
9925 resolve_call (code
);
9930 resolve_typebound_subroutine (code
);
9934 resolve_ppc_call (code
);
9938 /* Select is complicated. Also, a SELECT construct could be
9939 a transformed computed GOTO. */
9940 resolve_select (code
, false);
9943 case EXEC_SELECT_TYPE
:
9944 resolve_select_type (code
, ns
);
9948 resolve_block_construct (code
);
9952 if (code
->ext
.iterator
!= NULL
)
9954 gfc_iterator
*iter
= code
->ext
.iterator
;
9955 if (gfc_resolve_iterator (iter
, true, false))
9956 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9961 if (code
->expr1
== NULL
)
9962 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9964 && (code
->expr1
->rank
!= 0
9965 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9966 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9967 "a scalar LOGICAL expression", &code
->expr1
->where
);
9972 resolve_allocate_deallocate (code
, "ALLOCATE");
9976 case EXEC_DEALLOCATE
:
9978 resolve_allocate_deallocate (code
, "DEALLOCATE");
9983 if (!gfc_resolve_open (code
->ext
.open
))
9986 resolve_branch (code
->ext
.open
->err
, code
);
9990 if (!gfc_resolve_close (code
->ext
.close
))
9993 resolve_branch (code
->ext
.close
->err
, code
);
9996 case EXEC_BACKSPACE
:
10000 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10003 resolve_branch (code
->ext
.filepos
->err
, code
);
10007 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10010 resolve_branch (code
->ext
.inquire
->err
, code
);
10013 case EXEC_IOLENGTH
:
10014 gcc_assert (code
->ext
.inquire
!= NULL
);
10015 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10018 resolve_branch (code
->ext
.inquire
->err
, code
);
10022 if (!gfc_resolve_wait (code
->ext
.wait
))
10025 resolve_branch (code
->ext
.wait
->err
, code
);
10026 resolve_branch (code
->ext
.wait
->end
, code
);
10027 resolve_branch (code
->ext
.wait
->eor
, code
);
10032 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10035 resolve_branch (code
->ext
.dt
->err
, code
);
10036 resolve_branch (code
->ext
.dt
->end
, code
);
10037 resolve_branch (code
->ext
.dt
->eor
, code
);
10040 case EXEC_TRANSFER
:
10041 resolve_transfer (code
);
10044 case EXEC_DO_CONCURRENT
:
10046 resolve_forall_iterators (code
->ext
.forall_iterator
);
10048 if (code
->expr1
!= NULL
10049 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10050 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10051 "expression", &code
->expr1
->where
);
10054 case EXEC_OMP_ATOMIC
:
10055 case EXEC_OMP_BARRIER
:
10056 case EXEC_OMP_CRITICAL
:
10057 case EXEC_OMP_FLUSH
:
10059 case EXEC_OMP_MASTER
:
10060 case EXEC_OMP_ORDERED
:
10061 case EXEC_OMP_SECTIONS
:
10062 case EXEC_OMP_SINGLE
:
10063 case EXEC_OMP_TASKWAIT
:
10064 case EXEC_OMP_TASKYIELD
:
10065 case EXEC_OMP_WORKSHARE
:
10066 gfc_resolve_omp_directive (code
, ns
);
10069 case EXEC_OMP_PARALLEL
:
10070 case EXEC_OMP_PARALLEL_DO
:
10071 case EXEC_OMP_PARALLEL_SECTIONS
:
10072 case EXEC_OMP_PARALLEL_WORKSHARE
:
10073 case EXEC_OMP_TASK
:
10074 omp_workshare_save
= omp_workshare_flag
;
10075 omp_workshare_flag
= 0;
10076 gfc_resolve_omp_directive (code
, ns
);
10077 omp_workshare_flag
= omp_workshare_save
;
10081 gfc_internal_error ("resolve_code(): Bad statement code");
10085 cs_base
= frame
.prev
;
10089 /* Resolve initial values and make sure they are compatible with
10093 resolve_values (gfc_symbol
*sym
)
10097 if (sym
->value
== NULL
)
10100 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10101 t
= resolve_structure_cons (sym
->value
, 1);
10103 t
= gfc_resolve_expr (sym
->value
);
10108 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10112 /* Verify any BIND(C) derived types in the namespace so we can report errors
10113 for them once, rather than for each variable declared of that type. */
10116 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10118 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10119 && derived_sym
->attr
.is_bind_c
== 1)
10120 verify_bind_c_derived_type (derived_sym
);
10126 /* Verify that any binding labels used in a given namespace do not collide
10127 with the names or binding labels of any global symbols. Multiple INTERFACE
10128 for the same procedure are permitted. */
10131 gfc_verify_binding_labels (gfc_symbol
*sym
)
10134 const char *module
;
10136 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10137 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10140 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10143 module
= sym
->module
;
10144 else if (sym
->ns
&& sym
->ns
->proc_name
10145 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10146 module
= sym
->ns
->proc_name
->name
;
10147 else if (sym
->ns
&& sym
->ns
->parent
10148 && sym
->ns
&& sym
->ns
->parent
->proc_name
10149 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10150 module
= sym
->ns
->parent
->proc_name
->name
;
10156 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10159 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10160 gsym
->where
= sym
->declared_at
;
10161 gsym
->sym_name
= sym
->name
;
10162 gsym
->binding_label
= sym
->binding_label
;
10163 gsym
->binding_label
= sym
->binding_label
;
10164 gsym
->ns
= sym
->ns
;
10165 gsym
->mod_name
= module
;
10166 if (sym
->attr
.function
)
10167 gsym
->type
= GSYM_FUNCTION
;
10168 else if (sym
->attr
.subroutine
)
10169 gsym
->type
= GSYM_SUBROUTINE
;
10170 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10171 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10175 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10177 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10178 "identifier as entity at %L", sym
->name
,
10179 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10180 /* Clear the binding label to prevent checking multiple times. */
10181 sym
->binding_label
= NULL
;
10184 else if (sym
->attr
.flavor
== FL_VARIABLE
10185 && (strcmp (module
, gsym
->mod_name
) != 0
10186 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10188 /* This can only happen if the variable is defined in a module - if it
10189 isn't the same module, reject it. */
10190 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10191 "the same global identifier as entity at %L from module %s",
10192 sym
->name
, module
, sym
->binding_label
,
10193 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10194 sym
->binding_label
= NULL
;
10196 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10197 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10198 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10199 && sym
!= gsym
->ns
->proc_name
10200 && (strcmp (gsym
->sym_name
, sym
->name
) != 0
10201 || module
!= gsym
->mod_name
10202 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10204 /* Print an error if the procdure is defined multiple times; we have to
10205 exclude references to the same procedure via module association or
10206 multiple checks for the same procedure. */
10207 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10208 "global identifier as entity at %L", sym
->name
,
10209 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10210 sym
->binding_label
= NULL
;
10215 /* Resolve an index expression. */
10218 resolve_index_expr (gfc_expr
*e
)
10220 if (!gfc_resolve_expr (e
))
10223 if (!gfc_simplify_expr (e
, 0))
10226 if (!gfc_specification_expr (e
))
10233 /* Resolve a charlen structure. */
10236 resolve_charlen (gfc_charlen
*cl
)
10239 bool saved_specification_expr
;
10245 saved_specification_expr
= specification_expr
;
10246 specification_expr
= true;
10248 if (cl
->length_from_typespec
)
10250 if (!gfc_resolve_expr (cl
->length
))
10252 specification_expr
= saved_specification_expr
;
10256 if (!gfc_simplify_expr (cl
->length
, 0))
10258 specification_expr
= saved_specification_expr
;
10265 if (!resolve_index_expr (cl
->length
))
10267 specification_expr
= saved_specification_expr
;
10272 /* "If the character length parameter value evaluates to a negative
10273 value, the length of character entities declared is zero." */
10274 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10276 if (gfc_option
.warn_surprising
)
10277 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10278 " the length has been set to zero",
10279 &cl
->length
->where
, i
);
10280 gfc_replace_expr (cl
->length
,
10281 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10284 /* Check that the character length is not too large. */
10285 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10286 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10287 && cl
->length
->ts
.type
== BT_INTEGER
10288 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10290 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10291 specification_expr
= saved_specification_expr
;
10295 specification_expr
= saved_specification_expr
;
10300 /* Test for non-constant shape arrays. */
10303 is_non_constant_shape_array (gfc_symbol
*sym
)
10309 not_constant
= false;
10310 if (sym
->as
!= NULL
)
10312 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10313 has not been simplified; parameter array references. Do the
10314 simplification now. */
10315 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10317 e
= sym
->as
->lower
[i
];
10318 if (e
&& (!resolve_index_expr(e
)
10319 || !gfc_is_constant_expr (e
)))
10320 not_constant
= true;
10321 e
= sym
->as
->upper
[i
];
10322 if (e
&& (!resolve_index_expr(e
)
10323 || !gfc_is_constant_expr (e
)))
10324 not_constant
= true;
10327 return not_constant
;
10330 /* Given a symbol and an initialization expression, add code to initialize
10331 the symbol to the function entry. */
10333 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10337 gfc_namespace
*ns
= sym
->ns
;
10339 /* Search for the function namespace if this is a contained
10340 function without an explicit result. */
10341 if (sym
->attr
.function
&& sym
== sym
->result
10342 && sym
->name
!= sym
->ns
->proc_name
->name
)
10344 ns
= ns
->contained
;
10345 for (;ns
; ns
= ns
->sibling
)
10346 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10352 gfc_free_expr (init
);
10356 /* Build an l-value expression for the result. */
10357 lval
= gfc_lval_expr_from_sym (sym
);
10359 /* Add the code at scope entry. */
10360 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10361 init_st
->next
= ns
->code
;
10362 ns
->code
= init_st
;
10364 /* Assign the default initializer to the l-value. */
10365 init_st
->loc
= sym
->declared_at
;
10366 init_st
->expr1
= lval
;
10367 init_st
->expr2
= init
;
10370 /* Assign the default initializer to a derived type variable or result. */
10373 apply_default_init (gfc_symbol
*sym
)
10375 gfc_expr
*init
= NULL
;
10377 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10380 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10381 init
= gfc_default_initializer (&sym
->ts
);
10383 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10386 build_init_assign (sym
, init
);
10387 sym
->attr
.referenced
= 1;
10390 /* Build an initializer for a local integer, real, complex, logical, or
10391 character variable, based on the command line flags finit-local-zero,
10392 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10393 null if the symbol should not have a default initialization. */
10395 build_default_init_expr (gfc_symbol
*sym
)
10398 gfc_expr
*init_expr
;
10401 /* These symbols should never have a default initialization. */
10402 if (sym
->attr
.allocatable
10403 || sym
->attr
.external
10405 || sym
->attr
.pointer
10406 || sym
->attr
.in_equivalence
10407 || sym
->attr
.in_common
10410 || sym
->attr
.cray_pointee
10411 || sym
->attr
.cray_pointer
10415 /* Now we'll try to build an initializer expression. */
10416 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10417 &sym
->declared_at
);
10419 /* We will only initialize integers, reals, complex, logicals, and
10420 characters, and only if the corresponding command-line flags
10421 were set. Otherwise, we free init_expr and return null. */
10422 switch (sym
->ts
.type
)
10425 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10426 mpz_set_si (init_expr
->value
.integer
,
10427 gfc_option
.flag_init_integer_value
);
10430 gfc_free_expr (init_expr
);
10436 switch (gfc_option
.flag_init_real
)
10438 case GFC_INIT_REAL_SNAN
:
10439 init_expr
->is_snan
= 1;
10440 /* Fall through. */
10441 case GFC_INIT_REAL_NAN
:
10442 mpfr_set_nan (init_expr
->value
.real
);
10445 case GFC_INIT_REAL_INF
:
10446 mpfr_set_inf (init_expr
->value
.real
, 1);
10449 case GFC_INIT_REAL_NEG_INF
:
10450 mpfr_set_inf (init_expr
->value
.real
, -1);
10453 case GFC_INIT_REAL_ZERO
:
10454 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10458 gfc_free_expr (init_expr
);
10465 switch (gfc_option
.flag_init_real
)
10467 case GFC_INIT_REAL_SNAN
:
10468 init_expr
->is_snan
= 1;
10469 /* Fall through. */
10470 case GFC_INIT_REAL_NAN
:
10471 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10472 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10475 case GFC_INIT_REAL_INF
:
10476 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10477 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10480 case GFC_INIT_REAL_NEG_INF
:
10481 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10482 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10485 case GFC_INIT_REAL_ZERO
:
10486 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10490 gfc_free_expr (init_expr
);
10497 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10498 init_expr
->value
.logical
= 0;
10499 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10500 init_expr
->value
.logical
= 1;
10503 gfc_free_expr (init_expr
);
10509 /* For characters, the length must be constant in order to
10510 create a default initializer. */
10511 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10512 && sym
->ts
.u
.cl
->length
10513 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10515 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10516 init_expr
->value
.character
.length
= char_len
;
10517 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10518 for (i
= 0; i
< char_len
; i
++)
10519 init_expr
->value
.character
.string
[i
]
10520 = (unsigned char) gfc_option
.flag_init_character_value
;
10524 gfc_free_expr (init_expr
);
10527 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10528 && sym
->ts
.u
.cl
->length
)
10530 gfc_actual_arglist
*arg
;
10531 init_expr
= gfc_get_expr ();
10532 init_expr
->where
= sym
->declared_at
;
10533 init_expr
->ts
= sym
->ts
;
10534 init_expr
->expr_type
= EXPR_FUNCTION
;
10535 init_expr
->value
.function
.isym
=
10536 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10537 init_expr
->value
.function
.name
= "repeat";
10538 arg
= gfc_get_actual_arglist ();
10539 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10541 arg
->expr
->value
.character
.string
[0]
10542 = gfc_option
.flag_init_character_value
;
10543 arg
->next
= gfc_get_actual_arglist ();
10544 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10545 init_expr
->value
.function
.actual
= arg
;
10550 gfc_free_expr (init_expr
);
10556 /* Add an initialization expression to a local variable. */
10558 apply_default_init_local (gfc_symbol
*sym
)
10560 gfc_expr
*init
= NULL
;
10562 /* The symbol should be a variable or a function return value. */
10563 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10564 || (sym
->attr
.function
&& sym
->result
!= sym
))
10567 /* Try to build the initializer expression. If we can't initialize
10568 this symbol, then init will be NULL. */
10569 init
= build_default_init_expr (sym
);
10573 /* For saved variables, we don't want to add an initializer at function
10574 entry, so we just add a static initializer. Note that automatic variables
10575 are stack allocated even with -fno-automatic; we have also to exclude
10576 result variable, which are also nonstatic. */
10577 if (sym
->attr
.save
|| sym
->ns
->save_all
10578 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10579 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10581 /* Don't clobber an existing initializer! */
10582 gcc_assert (sym
->value
== NULL
);
10587 build_init_assign (sym
, init
);
10591 /* Resolution of common features of flavors variable and procedure. */
10594 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10596 gfc_array_spec
*as
;
10598 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10599 as
= CLASS_DATA (sym
)->as
;
10603 /* Constraints on deferred shape variable. */
10604 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10606 bool pointer
, allocatable
, dimension
;
10608 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10610 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10611 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10612 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10616 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10617 allocatable
= sym
->attr
.allocatable
;
10618 dimension
= sym
->attr
.dimension
;
10623 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10625 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10626 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10629 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10630 "'%s' at %L may not be ALLOCATABLE",
10631 sym
->name
, &sym
->declared_at
))
10635 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10637 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10638 "assumed rank", sym
->name
, &sym
->declared_at
);
10644 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10645 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10647 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10648 sym
->name
, &sym
->declared_at
);
10653 /* Constraints on polymorphic variables. */
10654 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10657 if (sym
->attr
.class_ok
10658 && !sym
->attr
.select_type_temporary
10659 && !UNLIMITED_POLY (sym
)
10660 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10662 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10663 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10664 &sym
->declared_at
);
10669 /* Assume that use associated symbols were checked in the module ns.
10670 Class-variables that are associate-names are also something special
10671 and excepted from the test. */
10672 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10674 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10675 "or pointer", sym
->name
, &sym
->declared_at
);
10684 /* Additional checks for symbols with flavor variable and derived
10685 type. To be called from resolve_fl_variable. */
10688 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10690 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10692 /* Check to see if a derived type is blocked from being host
10693 associated by the presence of another class I symbol in the same
10694 namespace. 14.6.1.3 of the standard and the discussion on
10695 comp.lang.fortran. */
10696 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10697 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10700 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10701 if (s
&& s
->attr
.generic
)
10702 s
= gfc_find_dt_in_generic (s
);
10703 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10705 gfc_error ("The type '%s' cannot be host associated at %L "
10706 "because it is blocked by an incompatible object "
10707 "of the same name declared at %L",
10708 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10714 /* 4th constraint in section 11.3: "If an object of a type for which
10715 component-initialization is specified (R429) appears in the
10716 specification-part of a module and does not have the ALLOCATABLE
10717 or POINTER attribute, the object shall have the SAVE attribute."
10719 The check for initializers is performed with
10720 gfc_has_default_initializer because gfc_default_initializer generates
10721 a hidden default for allocatable components. */
10722 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10723 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10724 && !sym
->ns
->save_all
&& !sym
->attr
.save
10725 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10726 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10727 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10728 "'%s' at %L, needed due to the default "
10729 "initialization", sym
->name
, &sym
->declared_at
))
10732 /* Assign default initializer. */
10733 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10734 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10736 sym
->value
= gfc_default_initializer (&sym
->ts
);
10743 /* Resolve symbols with flavor variable. */
10746 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10748 int no_init_flag
, automatic_flag
;
10750 const char *auto_save_msg
;
10751 bool saved_specification_expr
;
10753 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10756 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10759 /* Set this flag to check that variables are parameters of all entries.
10760 This check is effected by the call to gfc_resolve_expr through
10761 is_non_constant_shape_array. */
10762 saved_specification_expr
= specification_expr
;
10763 specification_expr
= true;
10765 if (sym
->ns
->proc_name
10766 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10767 || sym
->ns
->proc_name
->attr
.is_main_program
)
10768 && !sym
->attr
.use_assoc
10769 && !sym
->attr
.allocatable
10770 && !sym
->attr
.pointer
10771 && is_non_constant_shape_array (sym
))
10773 /* The shape of a main program or module array needs to be
10775 gfc_error ("The module or main program array '%s' at %L must "
10776 "have constant shape", sym
->name
, &sym
->declared_at
);
10777 specification_expr
= saved_specification_expr
;
10781 /* Constraints on deferred type parameter. */
10782 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10784 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10785 "requires either the pointer or allocatable attribute",
10786 sym
->name
, &sym
->declared_at
);
10787 specification_expr
= saved_specification_expr
;
10791 if (sym
->ts
.type
== BT_CHARACTER
)
10793 /* Make sure that character string variables with assumed length are
10794 dummy arguments. */
10795 e
= sym
->ts
.u
.cl
->length
;
10796 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10797 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10799 gfc_error ("Entity with assumed character length at %L must be a "
10800 "dummy argument or a PARAMETER", &sym
->declared_at
);
10801 specification_expr
= saved_specification_expr
;
10805 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10807 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10808 specification_expr
= saved_specification_expr
;
10812 if (!gfc_is_constant_expr (e
)
10813 && !(e
->expr_type
== EXPR_VARIABLE
10814 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10816 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10817 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10818 || sym
->ns
->proc_name
->attr
.is_main_program
))
10820 gfc_error ("'%s' at %L must have constant character length "
10821 "in this context", sym
->name
, &sym
->declared_at
);
10822 specification_expr
= saved_specification_expr
;
10825 if (sym
->attr
.in_common
)
10827 gfc_error ("COMMON variable '%s' at %L must have constant "
10828 "character length", sym
->name
, &sym
->declared_at
);
10829 specification_expr
= saved_specification_expr
;
10835 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10836 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10838 /* Determine if the symbol may not have an initializer. */
10839 no_init_flag
= automatic_flag
= 0;
10840 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10841 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10843 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10844 && is_non_constant_shape_array (sym
))
10846 no_init_flag
= automatic_flag
= 1;
10848 /* Also, they must not have the SAVE attribute.
10849 SAVE_IMPLICIT is checked below. */
10850 if (sym
->as
&& sym
->attr
.codimension
)
10852 int corank
= sym
->as
->corank
;
10853 sym
->as
->corank
= 0;
10854 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10855 sym
->as
->corank
= corank
;
10857 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10859 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10860 specification_expr
= saved_specification_expr
;
10865 /* Ensure that any initializer is simplified. */
10867 gfc_simplify_expr (sym
->value
, 1);
10869 /* Reject illegal initializers. */
10870 if (!sym
->mark
&& sym
->value
)
10872 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10873 && CLASS_DATA (sym
)->attr
.allocatable
))
10874 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10875 sym
->name
, &sym
->declared_at
);
10876 else if (sym
->attr
.external
)
10877 gfc_error ("External '%s' at %L cannot have an initializer",
10878 sym
->name
, &sym
->declared_at
);
10879 else if (sym
->attr
.dummy
10880 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10881 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10882 sym
->name
, &sym
->declared_at
);
10883 else if (sym
->attr
.intrinsic
)
10884 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10885 sym
->name
, &sym
->declared_at
);
10886 else if (sym
->attr
.result
)
10887 gfc_error ("Function result '%s' at %L cannot have an initializer",
10888 sym
->name
, &sym
->declared_at
);
10889 else if (automatic_flag
)
10890 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10891 sym
->name
, &sym
->declared_at
);
10893 goto no_init_error
;
10894 specification_expr
= saved_specification_expr
;
10899 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10901 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10902 specification_expr
= saved_specification_expr
;
10906 specification_expr
= saved_specification_expr
;
10911 /* Resolve a procedure. */
10914 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10916 gfc_formal_arglist
*arg
;
10918 if (sym
->attr
.function
10919 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10922 if (sym
->ts
.type
== BT_CHARACTER
)
10924 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10926 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10927 && !resolve_charlen (cl
))
10930 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10931 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10933 gfc_error ("Character-valued statement function '%s' at %L must "
10934 "have constant length", sym
->name
, &sym
->declared_at
);
10939 /* Ensure that derived type for are not of a private type. Internal
10940 module procedures are excluded by 2.2.3.3 - i.e., they are not
10941 externally accessible and can access all the objects accessible in
10943 if (!(sym
->ns
->parent
10944 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10945 && gfc_check_symbol_access (sym
))
10947 gfc_interface
*iface
;
10949 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10952 && arg
->sym
->ts
.type
== BT_DERIVED
10953 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10954 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10955 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10956 "and cannot be a dummy argument"
10957 " of '%s', which is PUBLIC at %L",
10958 arg
->sym
->name
, sym
->name
,
10959 &sym
->declared_at
))
10961 /* Stop this message from recurring. */
10962 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10967 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10968 PRIVATE to the containing module. */
10969 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10971 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10974 && arg
->sym
->ts
.type
== BT_DERIVED
10975 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10976 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10977 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10978 "PUBLIC interface '%s' at %L "
10979 "takes dummy arguments of '%s' which "
10980 "is PRIVATE", iface
->sym
->name
,
10981 sym
->name
, &iface
->sym
->declared_at
,
10982 gfc_typename(&arg
->sym
->ts
)))
10984 /* Stop this message from recurring. */
10985 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10991 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10992 PRIVATE to the containing module. */
10993 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10995 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10998 && arg
->sym
->ts
.type
== BT_DERIVED
10999 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11000 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11001 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
11002 "PUBLIC interface '%s' at %L takes "
11003 "dummy arguments of '%s' which is "
11004 "PRIVATE", iface
->sym
->name
,
11005 sym
->name
, &iface
->sym
->declared_at
,
11006 gfc_typename(&arg
->sym
->ts
)))
11008 /* Stop this message from recurring. */
11009 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11016 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11017 && !sym
->attr
.proc_pointer
)
11019 gfc_error ("Function '%s' at %L cannot have an initializer",
11020 sym
->name
, &sym
->declared_at
);
11024 /* An external symbol may not have an initializer because it is taken to be
11025 a procedure. Exception: Procedure Pointers. */
11026 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11028 gfc_error ("External object '%s' at %L may not have an initializer",
11029 sym
->name
, &sym
->declared_at
);
11033 /* An elemental function is required to return a scalar 12.7.1 */
11034 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11036 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11037 "result", sym
->name
, &sym
->declared_at
);
11038 /* Reset so that the error only occurs once. */
11039 sym
->attr
.elemental
= 0;
11043 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11044 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11046 gfc_error ("Statement function '%s' at %L may not have pointer or "
11047 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11051 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11052 char-len-param shall not be array-valued, pointer-valued, recursive
11053 or pure. ....snip... A character value of * may only be used in the
11054 following ways: (i) Dummy arg of procedure - dummy associates with
11055 actual length; (ii) To declare a named constant; or (iii) External
11056 function - but length must be declared in calling scoping unit. */
11057 if (sym
->attr
.function
11058 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11059 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11061 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11062 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11064 if (sym
->as
&& sym
->as
->rank
)
11065 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11066 "array-valued", sym
->name
, &sym
->declared_at
);
11068 if (sym
->attr
.pointer
)
11069 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11070 "pointer-valued", sym
->name
, &sym
->declared_at
);
11072 if (sym
->attr
.pure
)
11073 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11074 "pure", sym
->name
, &sym
->declared_at
);
11076 if (sym
->attr
.recursive
)
11077 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11078 "recursive", sym
->name
, &sym
->declared_at
);
11083 /* Appendix B.2 of the standard. Contained functions give an
11084 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11085 character length is an F2003 feature. */
11086 if (!sym
->attr
.contained
11087 && gfc_current_form
!= FORM_FIXED
11088 && !sym
->ts
.deferred
)
11089 gfc_notify_std (GFC_STD_F95_OBS
,
11090 "CHARACTER(*) function '%s' at %L",
11091 sym
->name
, &sym
->declared_at
);
11094 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11096 gfc_formal_arglist
*curr_arg
;
11097 int has_non_interop_arg
= 0;
11099 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11100 sym
->common_block
))
11102 /* Clear these to prevent looking at them again if there was an
11104 sym
->attr
.is_bind_c
= 0;
11105 sym
->attr
.is_c_interop
= 0;
11106 sym
->ts
.is_c_interop
= 0;
11110 /* So far, no errors have been found. */
11111 sym
->attr
.is_c_interop
= 1;
11112 sym
->ts
.is_c_interop
= 1;
11115 curr_arg
= gfc_sym_get_dummy_args (sym
);
11116 while (curr_arg
!= NULL
)
11118 /* Skip implicitly typed dummy args here. */
11119 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11120 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11121 /* If something is found to fail, record the fact so we
11122 can mark the symbol for the procedure as not being
11123 BIND(C) to try and prevent multiple errors being
11125 has_non_interop_arg
= 1;
11127 curr_arg
= curr_arg
->next
;
11130 /* See if any of the arguments were not interoperable and if so, clear
11131 the procedure symbol to prevent duplicate error messages. */
11132 if (has_non_interop_arg
!= 0)
11134 sym
->attr
.is_c_interop
= 0;
11135 sym
->ts
.is_c_interop
= 0;
11136 sym
->attr
.is_bind_c
= 0;
11140 if (!sym
->attr
.proc_pointer
)
11142 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11144 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11145 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11148 if (sym
->attr
.intent
)
11150 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11151 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11154 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11156 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11157 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11160 if (sym
->attr
.external
&& sym
->attr
.function
11161 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11162 || sym
->attr
.contained
))
11164 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11165 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11168 if (strcmp ("ppr@", sym
->name
) == 0)
11170 gfc_error ("Procedure pointer result '%s' at %L "
11171 "is missing the pointer attribute",
11172 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11181 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11182 been defined and we now know their defined arguments, check that they fulfill
11183 the requirements of the standard for procedures used as finalizers. */
11186 gfc_resolve_finalizers (gfc_symbol
* derived
)
11188 gfc_finalizer
* list
;
11189 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11190 bool result
= true;
11191 bool seen_scalar
= false;
11193 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11196 /* Walk over the list of finalizer-procedures, check them, and if any one
11197 does not fit in with the standard's definition, print an error and remove
11198 it from the list. */
11199 prev_link
= &derived
->f2k_derived
->finalizers
;
11200 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11202 gfc_formal_arglist
*dummy_args
;
11207 /* Skip this finalizer if we already resolved it. */
11208 if (list
->proc_tree
)
11210 prev_link
= &(list
->next
);
11214 /* Check this exists and is a SUBROUTINE. */
11215 if (!list
->proc_sym
->attr
.subroutine
)
11217 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11218 list
->proc_sym
->name
, &list
->where
);
11222 /* We should have exactly one argument. */
11223 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11224 if (!dummy_args
|| dummy_args
->next
)
11226 gfc_error ("FINAL procedure at %L must have exactly one argument",
11230 arg
= dummy_args
->sym
;
11232 /* This argument must be of our type. */
11233 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11235 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11236 &arg
->declared_at
, derived
->name
);
11240 /* It must neither be a pointer nor allocatable nor optional. */
11241 if (arg
->attr
.pointer
)
11243 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11244 &arg
->declared_at
);
11247 if (arg
->attr
.allocatable
)
11249 gfc_error ("Argument of FINAL procedure at %L must not be"
11250 " ALLOCATABLE", &arg
->declared_at
);
11253 if (arg
->attr
.optional
)
11255 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11256 &arg
->declared_at
);
11260 /* It must not be INTENT(OUT). */
11261 if (arg
->attr
.intent
== INTENT_OUT
)
11263 gfc_error ("Argument of FINAL procedure at %L must not be"
11264 " INTENT(OUT)", &arg
->declared_at
);
11268 /* Warn if the procedure is non-scalar and not assumed shape. */
11269 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11270 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11271 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11272 " shape argument", &arg
->declared_at
);
11274 /* Check that it does not match in kind and rank with a FINAL procedure
11275 defined earlier. To really loop over the *earlier* declarations,
11276 we need to walk the tail of the list as new ones were pushed at the
11278 /* TODO: Handle kind parameters once they are implemented. */
11279 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11280 for (i
= list
->next
; i
; i
= i
->next
)
11282 gfc_formal_arglist
*dummy_args
;
11284 /* Argument list might be empty; that is an error signalled earlier,
11285 but we nevertheless continued resolving. */
11286 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11289 gfc_symbol
* i_arg
= dummy_args
->sym
;
11290 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11291 if (i_rank
== my_rank
)
11293 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11294 " rank (%d) as '%s'",
11295 list
->proc_sym
->name
, &list
->where
, my_rank
,
11296 i
->proc_sym
->name
);
11302 /* Is this the/a scalar finalizer procedure? */
11303 if (!arg
->as
|| arg
->as
->rank
== 0)
11304 seen_scalar
= true;
11306 /* Find the symtree for this procedure. */
11307 gcc_assert (!list
->proc_tree
);
11308 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11310 prev_link
= &list
->next
;
11313 /* Remove wrong nodes immediately from the list so we don't risk any
11314 troubles in the future when they might fail later expectations. */
11318 *prev_link
= list
->next
;
11319 gfc_free_finalizer (i
);
11322 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11323 were nodes in the list, must have been for arrays. It is surely a good
11324 idea to have a scalar version there if there's something to finalize. */
11325 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11326 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11327 " defined at %L, suggest also scalar one",
11328 derived
->name
, &derived
->declared_at
);
11330 gfc_find_derived_vtab (derived
);
11335 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11338 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11339 const char* generic_name
, locus where
)
11341 gfc_symbol
*sym1
, *sym2
;
11342 const char *pass1
, *pass2
;
11344 gcc_assert (t1
->specific
&& t2
->specific
);
11345 gcc_assert (!t1
->specific
->is_generic
);
11346 gcc_assert (!t2
->specific
->is_generic
);
11347 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11349 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11350 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11355 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11356 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11357 || sym1
->attr
.function
!= sym2
->attr
.function
)
11359 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11360 " GENERIC '%s' at %L",
11361 sym1
->name
, sym2
->name
, generic_name
, &where
);
11365 /* Compare the interfaces. */
11366 if (t1
->specific
->nopass
)
11368 else if (t1
->specific
->pass_arg
)
11369 pass1
= t1
->specific
->pass_arg
;
11371 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11372 if (t2
->specific
->nopass
)
11374 else if (t2
->specific
->pass_arg
)
11375 pass2
= t2
->specific
->pass_arg
;
11377 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11378 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11379 NULL
, 0, pass1
, pass2
))
11381 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11382 sym1
->name
, sym2
->name
, generic_name
, &where
);
11390 /* Worker function for resolving a generic procedure binding; this is used to
11391 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11393 The difference between those cases is finding possible inherited bindings
11394 that are overridden, as one has to look for them in tb_sym_root,
11395 tb_uop_root or tb_op, respectively. Thus the caller must already find
11396 the super-type and set p->overridden correctly. */
11399 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11400 gfc_typebound_proc
* p
, const char* name
)
11402 gfc_tbp_generic
* target
;
11403 gfc_symtree
* first_target
;
11404 gfc_symtree
* inherited
;
11406 gcc_assert (p
&& p
->is_generic
);
11408 /* Try to find the specific bindings for the symtrees in our target-list. */
11409 gcc_assert (p
->u
.generic
);
11410 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11411 if (!target
->specific
)
11413 gfc_typebound_proc
* overridden_tbp
;
11414 gfc_tbp_generic
* g
;
11415 const char* target_name
;
11417 target_name
= target
->specific_st
->name
;
11419 /* Defined for this type directly. */
11420 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11422 target
->specific
= target
->specific_st
->n
.tb
;
11423 goto specific_found
;
11426 /* Look for an inherited specific binding. */
11429 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11434 gcc_assert (inherited
->n
.tb
);
11435 target
->specific
= inherited
->n
.tb
;
11436 goto specific_found
;
11440 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11441 " at %L", target_name
, name
, &p
->where
);
11444 /* Once we've found the specific binding, check it is not ambiguous with
11445 other specifics already found or inherited for the same GENERIC. */
11447 gcc_assert (target
->specific
);
11449 /* This must really be a specific binding! */
11450 if (target
->specific
->is_generic
)
11452 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11453 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11457 /* Check those already resolved on this type directly. */
11458 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11459 if (g
!= target
&& g
->specific
11460 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11463 /* Check for ambiguity with inherited specific targets. */
11464 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11465 overridden_tbp
= overridden_tbp
->overridden
)
11466 if (overridden_tbp
->is_generic
)
11468 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11470 gcc_assert (g
->specific
);
11471 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11477 /* If we attempt to "overwrite" a specific binding, this is an error. */
11478 if (p
->overridden
&& !p
->overridden
->is_generic
)
11480 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11481 " the same name", name
, &p
->where
);
11485 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11486 all must have the same attributes here. */
11487 first_target
= p
->u
.generic
->specific
->u
.specific
;
11488 gcc_assert (first_target
);
11489 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11490 p
->function
= first_target
->n
.sym
->attr
.function
;
11496 /* Resolve a GENERIC procedure binding for a derived type. */
11499 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11501 gfc_symbol
* super_type
;
11503 /* Find the overridden binding if any. */
11504 st
->n
.tb
->overridden
= NULL
;
11505 super_type
= gfc_get_derived_super_type (derived
);
11508 gfc_symtree
* overridden
;
11509 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11512 if (overridden
&& overridden
->n
.tb
)
11513 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11516 /* Resolve using worker function. */
11517 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11521 /* Retrieve the target-procedure of an operator binding and do some checks in
11522 common for intrinsic and user-defined type-bound operators. */
11525 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11527 gfc_symbol
* target_proc
;
11529 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11530 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11531 gcc_assert (target_proc
);
11533 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11534 if (target
->specific
->nopass
)
11536 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11540 return target_proc
;
11544 /* Resolve a type-bound intrinsic operator. */
11547 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11548 gfc_typebound_proc
* p
)
11550 gfc_symbol
* super_type
;
11551 gfc_tbp_generic
* target
;
11553 /* If there's already an error here, do nothing (but don't fail again). */
11557 /* Operators should always be GENERIC bindings. */
11558 gcc_assert (p
->is_generic
);
11560 /* Look for an overridden binding. */
11561 super_type
= gfc_get_derived_super_type (derived
);
11562 if (super_type
&& super_type
->f2k_derived
)
11563 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11566 p
->overridden
= NULL
;
11568 /* Resolve general GENERIC properties using worker function. */
11569 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11572 /* Check the targets to be procedures of correct interface. */
11573 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11575 gfc_symbol
* target_proc
;
11577 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11581 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11584 /* Add target to non-typebound operator list. */
11585 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11586 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11588 gfc_interface
*head
, *intr
;
11589 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11591 head
= derived
->ns
->op
[op
];
11592 intr
= gfc_get_interface ();
11593 intr
->sym
= target_proc
;
11594 intr
->where
= p
->where
;
11596 derived
->ns
->op
[op
] = intr
;
11608 /* Resolve a type-bound user operator (tree-walker callback). */
11610 static gfc_symbol
* resolve_bindings_derived
;
11611 static bool resolve_bindings_result
;
11613 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11616 resolve_typebound_user_op (gfc_symtree
* stree
)
11618 gfc_symbol
* super_type
;
11619 gfc_tbp_generic
* target
;
11621 gcc_assert (stree
&& stree
->n
.tb
);
11623 if (stree
->n
.tb
->error
)
11626 /* Operators should always be GENERIC bindings. */
11627 gcc_assert (stree
->n
.tb
->is_generic
);
11629 /* Find overridden procedure, if any. */
11630 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11631 if (super_type
&& super_type
->f2k_derived
)
11633 gfc_symtree
* overridden
;
11634 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11635 stree
->name
, true, NULL
);
11637 if (overridden
&& overridden
->n
.tb
)
11638 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11641 stree
->n
.tb
->overridden
= NULL
;
11643 /* Resolve basically using worker function. */
11644 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11647 /* Check the targets to be functions of correct interface. */
11648 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11650 gfc_symbol
* target_proc
;
11652 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11656 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11663 resolve_bindings_result
= false;
11664 stree
->n
.tb
->error
= 1;
11668 /* Resolve the type-bound procedures for a derived type. */
11671 resolve_typebound_procedure (gfc_symtree
* stree
)
11675 gfc_symbol
* me_arg
;
11676 gfc_symbol
* super_type
;
11677 gfc_component
* comp
;
11679 gcc_assert (stree
);
11681 /* Undefined specific symbol from GENERIC target definition. */
11685 if (stree
->n
.tb
->error
)
11688 /* If this is a GENERIC binding, use that routine. */
11689 if (stree
->n
.tb
->is_generic
)
11691 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11696 /* Get the target-procedure to check it. */
11697 gcc_assert (!stree
->n
.tb
->is_generic
);
11698 gcc_assert (stree
->n
.tb
->u
.specific
);
11699 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11700 where
= stree
->n
.tb
->where
;
11702 /* Default access should already be resolved from the parser. */
11703 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11705 if (stree
->n
.tb
->deferred
)
11707 if (!check_proc_interface (proc
, &where
))
11712 /* Check for F08:C465. */
11713 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11714 || (proc
->attr
.proc
!= PROC_MODULE
11715 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11716 || proc
->attr
.abstract
)
11718 gfc_error ("'%s' must be a module procedure or an external procedure with"
11719 " an explicit interface at %L", proc
->name
, &where
);
11724 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11725 stree
->n
.tb
->function
= proc
->attr
.function
;
11727 /* Find the super-type of the current derived type. We could do this once and
11728 store in a global if speed is needed, but as long as not I believe this is
11729 more readable and clearer. */
11730 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11732 /* If PASS, resolve and check arguments if not already resolved / loaded
11733 from a .mod file. */
11734 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11736 gfc_formal_arglist
*dummy_args
;
11738 dummy_args
= gfc_sym_get_dummy_args (proc
);
11739 if (stree
->n
.tb
->pass_arg
)
11741 gfc_formal_arglist
*i
;
11743 /* If an explicit passing argument name is given, walk the arg-list
11744 and look for it. */
11747 stree
->n
.tb
->pass_arg_num
= 1;
11748 for (i
= dummy_args
; i
; i
= i
->next
)
11750 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11755 ++stree
->n
.tb
->pass_arg_num
;
11760 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11762 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11763 stree
->n
.tb
->pass_arg
);
11769 /* Otherwise, take the first one; there should in fact be at least
11771 stree
->n
.tb
->pass_arg_num
= 1;
11774 gfc_error ("Procedure '%s' with PASS at %L must have at"
11775 " least one argument", proc
->name
, &where
);
11778 me_arg
= dummy_args
->sym
;
11781 /* Now check that the argument-type matches and the passed-object
11782 dummy argument is generally fine. */
11784 gcc_assert (me_arg
);
11786 if (me_arg
->ts
.type
!= BT_CLASS
)
11788 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11789 " at %L", proc
->name
, &where
);
11793 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11794 != resolve_bindings_derived
)
11796 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11797 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11798 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11802 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11803 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11805 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11806 " scalar", proc
->name
, &where
);
11809 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11811 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11812 " be ALLOCATABLE", proc
->name
, &where
);
11815 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11817 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11818 " be POINTER", proc
->name
, &where
);
11823 /* If we are extending some type, check that we don't override a procedure
11824 flagged NON_OVERRIDABLE. */
11825 stree
->n
.tb
->overridden
= NULL
;
11828 gfc_symtree
* overridden
;
11829 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11830 stree
->name
, true, NULL
);
11834 if (overridden
->n
.tb
)
11835 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11837 if (!gfc_check_typebound_override (stree
, overridden
))
11842 /* See if there's a name collision with a component directly in this type. */
11843 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11844 if (!strcmp (comp
->name
, stree
->name
))
11846 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11848 stree
->name
, &where
, resolve_bindings_derived
->name
);
11852 /* Try to find a name collision with an inherited component. */
11853 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11855 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11856 " component of '%s'",
11857 stree
->name
, &where
, resolve_bindings_derived
->name
);
11861 stree
->n
.tb
->error
= 0;
11865 resolve_bindings_result
= false;
11866 stree
->n
.tb
->error
= 1;
11871 resolve_typebound_procedures (gfc_symbol
* derived
)
11874 gfc_symbol
* super_type
;
11876 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11879 super_type
= gfc_get_derived_super_type (derived
);
11881 resolve_symbol (super_type
);
11883 resolve_bindings_derived
= derived
;
11884 resolve_bindings_result
= true;
11886 /* Make sure the vtab has been generated. */
11887 gfc_find_derived_vtab (derived
);
11889 if (derived
->f2k_derived
->tb_sym_root
)
11890 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11891 &resolve_typebound_procedure
);
11893 if (derived
->f2k_derived
->tb_uop_root
)
11894 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11895 &resolve_typebound_user_op
);
11897 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11899 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11900 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11901 (gfc_intrinsic_op
)op
, p
))
11902 resolve_bindings_result
= false;
11905 return resolve_bindings_result
;
11909 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11910 to give all identical derived types the same backend_decl. */
11912 add_dt_to_dt_list (gfc_symbol
*derived
)
11914 gfc_dt_list
*dt_list
;
11916 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11917 if (derived
== dt_list
->derived
)
11920 dt_list
= gfc_get_dt_list ();
11921 dt_list
->next
= gfc_derived_types
;
11922 dt_list
->derived
= derived
;
11923 gfc_derived_types
= dt_list
;
11927 /* Ensure that a derived-type is really not abstract, meaning that every
11928 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11931 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11936 if (!ensure_not_abstract_walker (sub
, st
->left
))
11938 if (!ensure_not_abstract_walker (sub
, st
->right
))
11941 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11943 gfc_symtree
* overriding
;
11944 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11947 gcc_assert (overriding
->n
.tb
);
11948 if (overriding
->n
.tb
->deferred
)
11950 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11951 " '%s' is DEFERRED and not overridden",
11952 sub
->name
, &sub
->declared_at
, st
->name
);
11961 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11963 /* The algorithm used here is to recursively travel up the ancestry of sub
11964 and for each ancestor-type, check all bindings. If any of them is
11965 DEFERRED, look it up starting from sub and see if the found (overriding)
11966 binding is not DEFERRED.
11967 This is not the most efficient way to do this, but it should be ok and is
11968 clearer than something sophisticated. */
11970 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11972 if (!ancestor
->attr
.abstract
)
11975 /* Walk bindings of this ancestor. */
11976 if (ancestor
->f2k_derived
)
11979 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11984 /* Find next ancestor type and recurse on it. */
11985 ancestor
= gfc_get_derived_super_type (ancestor
);
11987 return ensure_not_abstract (sub
, ancestor
);
11993 /* This check for typebound defined assignments is done recursively
11994 since the order in which derived types are resolved is not always in
11995 order of the declarations. */
11998 check_defined_assignments (gfc_symbol
*derived
)
12002 for (c
= derived
->components
; c
; c
= c
->next
)
12004 if (c
->ts
.type
!= BT_DERIVED
12006 || c
->attr
.allocatable
12007 || c
->attr
.proc_pointer_comp
12008 || c
->attr
.class_pointer
12009 || c
->attr
.proc_pointer
)
12012 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12013 || (c
->ts
.u
.derived
->f2k_derived
12014 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12016 derived
->attr
.defined_assign_comp
= 1;
12020 check_defined_assignments (c
->ts
.u
.derived
);
12021 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12023 derived
->attr
.defined_assign_comp
= 1;
12030 /* Resolve the components of a derived type. This does not have to wait until
12031 resolution stage, but can be done as soon as the dt declaration has been
12035 resolve_fl_derived0 (gfc_symbol
*sym
)
12037 gfc_symbol
* super_type
;
12040 if (sym
->attr
.unlimited_polymorphic
)
12043 super_type
= gfc_get_derived_super_type (sym
);
12046 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12048 gfc_error ("As extending type '%s' at %L has a coarray component, "
12049 "parent type '%s' shall also have one", sym
->name
,
12050 &sym
->declared_at
, super_type
->name
);
12054 /* Ensure the extended type gets resolved before we do. */
12055 if (super_type
&& !resolve_fl_derived0 (super_type
))
12058 /* An ABSTRACT type must be extensible. */
12059 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12061 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12062 sym
->name
, &sym
->declared_at
);
12066 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12069 for ( ; c
!= NULL
; c
= c
->next
)
12071 if (c
->attr
.artificial
)
12074 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12075 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
12077 gfc_error ("Deferred-length character component '%s' at %L is not "
12078 "yet supported", c
->name
, &c
->loc
);
12083 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12084 && c
->attr
.codimension
12085 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12087 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12088 "deferred shape", c
->name
, &c
->loc
);
12093 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12094 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12096 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12097 "shall not be a coarray", c
->name
, &c
->loc
);
12102 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12103 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12104 || c
->attr
.allocatable
))
12106 gfc_error ("Component '%s' at %L with coarray component "
12107 "shall be a nonpointer, nonallocatable scalar",
12113 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12115 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12116 "is not an array pointer", c
->name
, &c
->loc
);
12120 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12122 gfc_symbol
*ifc
= c
->ts
.interface
;
12124 if (!sym
->attr
.vtype
12125 && !check_proc_interface (ifc
, &c
->loc
))
12128 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12130 /* Resolve interface and copy attributes. */
12131 if (ifc
->formal
&& !ifc
->formal_ns
)
12132 resolve_symbol (ifc
);
12133 if (ifc
->attr
.intrinsic
)
12134 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12138 c
->ts
= ifc
->result
->ts
;
12139 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12140 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12141 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12142 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12143 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12148 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12149 c
->attr
.pointer
= ifc
->attr
.pointer
;
12150 c
->attr
.dimension
= ifc
->attr
.dimension
;
12151 c
->as
= gfc_copy_array_spec (ifc
->as
);
12152 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12154 c
->ts
.interface
= ifc
;
12155 c
->attr
.function
= ifc
->attr
.function
;
12156 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12158 c
->attr
.pure
= ifc
->attr
.pure
;
12159 c
->attr
.elemental
= ifc
->attr
.elemental
;
12160 c
->attr
.recursive
= ifc
->attr
.recursive
;
12161 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12162 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12163 /* Copy char length. */
12164 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12166 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12167 if (cl
->length
&& !cl
->resolved
12168 && !gfc_resolve_expr (cl
->length
))
12174 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12176 /* Since PPCs are not implicitly typed, a PPC without an explicit
12177 interface must be a subroutine. */
12178 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12181 /* Procedure pointer components: Check PASS arg. */
12182 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12183 && !sym
->attr
.vtype
)
12185 gfc_symbol
* me_arg
;
12187 if (c
->tb
->pass_arg
)
12189 gfc_formal_arglist
* i
;
12191 /* If an explicit passing argument name is given, walk the arg-list
12192 and look for it. */
12195 c
->tb
->pass_arg_num
= 1;
12196 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12198 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12203 c
->tb
->pass_arg_num
++;
12208 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12209 "at %L has no argument '%s'", c
->name
,
12210 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12217 /* Otherwise, take the first one; there should in fact be at least
12219 c
->tb
->pass_arg_num
= 1;
12220 if (!c
->ts
.interface
->formal
)
12222 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12223 "must have at least one argument",
12228 me_arg
= c
->ts
.interface
->formal
->sym
;
12231 /* Now check that the argument-type matches. */
12232 gcc_assert (me_arg
);
12233 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12234 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12235 || (me_arg
->ts
.type
== BT_CLASS
12236 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12238 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12239 " the derived type '%s'", me_arg
->name
, c
->name
,
12240 me_arg
->name
, &c
->loc
, sym
->name
);
12245 /* Check for C453. */
12246 if (me_arg
->attr
.dimension
)
12248 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12249 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12255 if (me_arg
->attr
.pointer
)
12257 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12258 "may not have the POINTER attribute", me_arg
->name
,
12259 c
->name
, me_arg
->name
, &c
->loc
);
12264 if (me_arg
->attr
.allocatable
)
12266 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12267 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12268 me_arg
->name
, &c
->loc
);
12273 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12274 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12275 " at %L", c
->name
, &c
->loc
);
12279 /* Check type-spec if this is not the parent-type component. */
12280 if (((sym
->attr
.is_class
12281 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12282 || c
!= sym
->components
->ts
.u
.derived
->components
))
12283 || (!sym
->attr
.is_class
12284 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12285 && !sym
->attr
.vtype
12286 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12289 /* If this type is an extension, set the accessibility of the parent
12292 && ((sym
->attr
.is_class
12293 && c
== sym
->components
->ts
.u
.derived
->components
)
12294 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12295 && strcmp (super_type
->name
, c
->name
) == 0)
12296 c
->attr
.access
= super_type
->attr
.access
;
12298 /* If this type is an extension, see if this component has the same name
12299 as an inherited type-bound procedure. */
12300 if (super_type
&& !sym
->attr
.is_class
12301 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12303 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12304 " inherited type-bound procedure",
12305 c
->name
, sym
->name
, &c
->loc
);
12309 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12310 && !c
->ts
.deferred
)
12312 if (c
->ts
.u
.cl
->length
== NULL
12313 || (!resolve_charlen(c
->ts
.u
.cl
))
12314 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12316 gfc_error ("Character length of component '%s' needs to "
12317 "be a constant specification expression at %L",
12319 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12324 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12325 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12327 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12328 "length must be a POINTER or ALLOCATABLE",
12329 c
->name
, sym
->name
, &c
->loc
);
12333 if (c
->ts
.type
== BT_DERIVED
12334 && sym
->component_access
!= ACCESS_PRIVATE
12335 && gfc_check_symbol_access (sym
)
12336 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12337 && !c
->ts
.u
.derived
->attr
.use_assoc
12338 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12339 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12340 "PRIVATE type and cannot be a component of "
12341 "'%s', which is PUBLIC at %L", c
->name
,
12342 sym
->name
, &sym
->declared_at
))
12345 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12347 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12348 "type %s", c
->name
, &c
->loc
, sym
->name
);
12352 if (sym
->attr
.sequence
)
12354 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12356 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12357 "not have the SEQUENCE attribute",
12358 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12363 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12364 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12365 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12366 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12367 CLASS_DATA (c
)->ts
.u
.derived
12368 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12370 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12371 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12372 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12374 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12375 "that has not been declared", c
->name
, sym
->name
,
12380 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12381 && CLASS_DATA (c
)->attr
.class_pointer
12382 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12383 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12384 && !UNLIMITED_POLY (c
))
12386 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12387 "that has not been declared", c
->name
, sym
->name
,
12393 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12394 && (!c
->attr
.class_ok
12395 || !(CLASS_DATA (c
)->attr
.class_pointer
12396 || CLASS_DATA (c
)->attr
.allocatable
)))
12398 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12399 "or pointer", c
->name
, &c
->loc
);
12400 /* Prevent a recurrence of the error. */
12401 c
->ts
.type
= BT_UNKNOWN
;
12405 /* Ensure that all the derived type components are put on the
12406 derived type list; even in formal namespaces, where derived type
12407 pointer components might not have been declared. */
12408 if (c
->ts
.type
== BT_DERIVED
12410 && c
->ts
.u
.derived
->components
12412 && sym
!= c
->ts
.u
.derived
)
12413 add_dt_to_dt_list (c
->ts
.u
.derived
);
12415 if (!gfc_resolve_array_spec (c
->as
,
12416 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12417 || c
->attr
.allocatable
)))
12420 if (c
->initializer
&& !sym
->attr
.vtype
12421 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12425 check_defined_assignments (sym
);
12427 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12428 sym
->attr
.defined_assign_comp
12429 = super_type
->attr
.defined_assign_comp
;
12431 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12432 all DEFERRED bindings are overridden. */
12433 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12434 && !sym
->attr
.is_class
12435 && !ensure_not_abstract (sym
, super_type
))
12438 /* Add derived type to the derived type list. */
12439 add_dt_to_dt_list (sym
);
12441 /* Check if the type is finalizable. This is done in order to ensure that the
12442 finalization wrapper is generated early enough. */
12443 gfc_is_finalizable (sym
, NULL
);
12449 /* The following procedure does the full resolution of a derived type,
12450 including resolution of all type-bound procedures (if present). In contrast
12451 to 'resolve_fl_derived0' this can only be done after the module has been
12452 parsed completely. */
12455 resolve_fl_derived (gfc_symbol
*sym
)
12457 gfc_symbol
*gen_dt
= NULL
;
12459 if (sym
->attr
.unlimited_polymorphic
)
12462 if (!sym
->attr
.is_class
)
12463 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12464 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12465 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12466 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12467 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12468 "'%s' at %L being the same name as derived "
12469 "type at %L", sym
->name
,
12470 gen_dt
->generic
->sym
== sym
12471 ? gen_dt
->generic
->next
->sym
->name
12472 : gen_dt
->generic
->sym
->name
,
12473 gen_dt
->generic
->sym
== sym
12474 ? &gen_dt
->generic
->next
->sym
->declared_at
12475 : &gen_dt
->generic
->sym
->declared_at
,
12476 &sym
->declared_at
))
12479 /* Resolve the finalizer procedures. */
12480 if (!gfc_resolve_finalizers (sym
))
12483 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12485 /* Fix up incomplete CLASS symbols. */
12486 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12487 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12489 /* Nothing more to do for unlimited polymorphic entities. */
12490 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12492 else if (vptr
->ts
.u
.derived
== NULL
)
12494 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12496 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12500 if (!resolve_fl_derived0 (sym
))
12503 /* Resolve the type-bound procedures. */
12504 if (!resolve_typebound_procedures (sym
))
12512 resolve_fl_namelist (gfc_symbol
*sym
)
12517 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12519 /* Check again, the check in match only works if NAMELIST comes
12521 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12523 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12524 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12528 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12529 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12530 "with assumed shape in namelist '%s' at %L",
12531 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12534 if (is_non_constant_shape_array (nl
->sym
)
12535 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12536 "with nonconstant shape in namelist '%s' at %L",
12537 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12540 if (nl
->sym
->ts
.type
== BT_CHARACTER
12541 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12542 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12543 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12544 "nonconstant character length in "
12545 "namelist '%s' at %L", nl
->sym
->name
,
12546 sym
->name
, &sym
->declared_at
))
12549 /* FIXME: Once UDDTIO is implemented, the following can be
12551 if (nl
->sym
->ts
.type
== BT_CLASS
)
12553 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12554 "polymorphic and requires a defined input/output "
12555 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12559 if (nl
->sym
->ts
.type
== BT_DERIVED
12560 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12561 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12563 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12564 "namelist '%s' at %L with ALLOCATABLE "
12565 "or POINTER components", nl
->sym
->name
,
12566 sym
->name
, &sym
->declared_at
))
12569 /* FIXME: Once UDDTIO is implemented, the following can be
12571 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12572 "ALLOCATABLE or POINTER components and thus requires "
12573 "a defined input/output procedure", nl
->sym
->name
,
12574 sym
->name
, &sym
->declared_at
);
12579 /* Reject PRIVATE objects in a PUBLIC namelist. */
12580 if (gfc_check_symbol_access (sym
))
12582 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12584 if (!nl
->sym
->attr
.use_assoc
12585 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12586 && !gfc_check_symbol_access (nl
->sym
))
12588 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12589 "cannot be member of PUBLIC namelist '%s' at %L",
12590 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12594 /* Types with private components that came here by USE-association. */
12595 if (nl
->sym
->ts
.type
== BT_DERIVED
12596 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12598 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12599 "components and cannot be member of namelist '%s' at %L",
12600 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12604 /* Types with private components that are defined in the same module. */
12605 if (nl
->sym
->ts
.type
== BT_DERIVED
12606 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12607 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12609 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12610 "cannot be a member of PUBLIC namelist '%s' at %L",
12611 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12618 /* 14.1.2 A module or internal procedure represent local entities
12619 of the same type as a namelist member and so are not allowed. */
12620 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12622 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12625 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12626 if ((nl
->sym
== sym
->ns
->proc_name
)
12628 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12633 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12634 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12636 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12637 "attribute in '%s' at %L", nlsym
->name
,
12638 &sym
->declared_at
);
12648 resolve_fl_parameter (gfc_symbol
*sym
)
12650 /* A parameter array's shape needs to be constant. */
12651 if (sym
->as
!= NULL
12652 && (sym
->as
->type
== AS_DEFERRED
12653 || is_non_constant_shape_array (sym
)))
12655 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12656 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12660 /* Make sure a parameter that has been implicitly typed still
12661 matches the implicit type, since PARAMETER statements can precede
12662 IMPLICIT statements. */
12663 if (sym
->attr
.implicit_type
12664 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12667 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12668 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12672 /* Make sure the types of derived parameters are consistent. This
12673 type checking is deferred until resolution because the type may
12674 refer to a derived type from the host. */
12675 if (sym
->ts
.type
== BT_DERIVED
12676 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12678 gfc_error ("Incompatible derived type in PARAMETER at %L",
12679 &sym
->value
->where
);
12686 /* Do anything necessary to resolve a symbol. Right now, we just
12687 assume that an otherwise unknown symbol is a variable. This sort
12688 of thing commonly happens for symbols in module. */
12691 resolve_symbol (gfc_symbol
*sym
)
12693 int check_constant
, mp_flag
;
12694 gfc_symtree
*symtree
;
12695 gfc_symtree
*this_symtree
;
12698 symbol_attribute class_attr
;
12699 gfc_array_spec
*as
;
12700 bool saved_specification_expr
;
12706 if (sym
->attr
.artificial
)
12709 if (sym
->attr
.unlimited_polymorphic
)
12712 if (sym
->attr
.flavor
== FL_UNKNOWN
12713 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12714 && !sym
->attr
.generic
&& !sym
->attr
.external
12715 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12718 /* If we find that a flavorless symbol is an interface in one of the
12719 parent namespaces, find its symtree in this namespace, free the
12720 symbol and set the symtree to point to the interface symbol. */
12721 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12723 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12724 if (symtree
&& (symtree
->n
.sym
->generic
||
12725 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12726 && sym
->ns
->construct_entities
)))
12728 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12730 gfc_release_symbol (sym
);
12731 symtree
->n
.sym
->refs
++;
12732 this_symtree
->n
.sym
= symtree
->n
.sym
;
12737 /* Otherwise give it a flavor according to such attributes as
12739 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12740 && sym
->attr
.intrinsic
== 0)
12741 sym
->attr
.flavor
= FL_VARIABLE
;
12742 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12744 sym
->attr
.flavor
= FL_PROCEDURE
;
12745 if (sym
->attr
.dimension
)
12746 sym
->attr
.function
= 1;
12750 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12751 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12753 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12754 && !resolve_procedure_interface (sym
))
12757 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12758 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12760 if (sym
->attr
.external
)
12761 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12762 "at %L", &sym
->declared_at
);
12764 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12765 "at %L", &sym
->declared_at
);
12770 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12773 /* Symbols that are module procedures with results (functions) have
12774 the types and array specification copied for type checking in
12775 procedures that call them, as well as for saving to a module
12776 file. These symbols can't stand the scrutiny that their results
12778 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12780 /* Make sure that the intrinsic is consistent with its internal
12781 representation. This needs to be done before assigning a default
12782 type to avoid spurious warnings. */
12783 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12784 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12787 /* Resolve associate names. */
12789 resolve_assoc_var (sym
, true);
12791 /* Assign default type to symbols that need one and don't have one. */
12792 if (sym
->ts
.type
== BT_UNKNOWN
)
12794 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12796 gfc_set_default_type (sym
, 1, NULL
);
12799 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12800 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12801 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12802 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12804 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12806 /* The specific case of an external procedure should emit an error
12807 in the case that there is no implicit type. */
12809 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12812 /* Result may be in another namespace. */
12813 resolve_symbol (sym
->result
);
12815 if (!sym
->result
->attr
.proc_pointer
)
12817 sym
->ts
= sym
->result
->ts
;
12818 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12819 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12820 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12821 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12822 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12827 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12829 bool saved_specification_expr
= specification_expr
;
12830 specification_expr
= true;
12831 gfc_resolve_array_spec (sym
->result
->as
, false);
12832 specification_expr
= saved_specification_expr
;
12835 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12837 as
= CLASS_DATA (sym
)->as
;
12838 class_attr
= CLASS_DATA (sym
)->attr
;
12839 class_attr
.pointer
= class_attr
.class_pointer
;
12843 class_attr
= sym
->attr
;
12848 if (sym
->attr
.contiguous
12849 && (!class_attr
.dimension
12850 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12851 && !class_attr
.pointer
)))
12853 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12854 "array pointer or an assumed-shape or assumed-rank array",
12855 sym
->name
, &sym
->declared_at
);
12859 /* Assumed size arrays and assumed shape arrays must be dummy
12860 arguments. Array-spec's of implied-shape should have been resolved to
12861 AS_EXPLICIT already. */
12865 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12866 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12867 || as
->type
== AS_ASSUMED_SHAPE
)
12868 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12870 if (as
->type
== AS_ASSUMED_SIZE
)
12871 gfc_error ("Assumed size array at %L must be a dummy argument",
12872 &sym
->declared_at
);
12874 gfc_error ("Assumed shape array at %L must be a dummy argument",
12875 &sym
->declared_at
);
12878 /* TS 29113, C535a. */
12879 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12880 && !sym
->attr
.select_type_temporary
)
12882 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12883 &sym
->declared_at
);
12886 if (as
->type
== AS_ASSUMED_RANK
12887 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12889 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12890 "CODIMENSION attribute", &sym
->declared_at
);
12895 /* Make sure symbols with known intent or optional are really dummy
12896 variable. Because of ENTRY statement, this has to be deferred
12897 until resolution time. */
12899 if (!sym
->attr
.dummy
12900 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12902 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12906 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12908 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12909 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12913 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12915 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12916 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12918 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12919 "attribute must have constant length",
12920 sym
->name
, &sym
->declared_at
);
12924 if (sym
->ts
.is_c_interop
12925 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12927 gfc_error ("C interoperable character dummy variable '%s' at %L "
12928 "with VALUE attribute must have length one",
12929 sym
->name
, &sym
->declared_at
);
12934 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12935 && sym
->ts
.u
.derived
->attr
.generic
)
12937 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12938 if (!sym
->ts
.u
.derived
)
12940 gfc_error ("The derived type '%s' at %L is of type '%s', "
12941 "which has not been defined", sym
->name
,
12942 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12943 sym
->ts
.type
= BT_UNKNOWN
;
12948 /* Use the same constraints as TYPE(*), except for the type check
12949 and that only scalars and assumed-size arrays are permitted. */
12950 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
12952 if (!sym
->attr
.dummy
)
12954 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12955 "a dummy argument", sym
->name
, &sym
->declared_at
);
12959 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
12960 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
12961 && sym
->ts
.type
!= BT_COMPLEX
)
12963 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12964 "of type TYPE(*) or of an numeric intrinsic type",
12965 sym
->name
, &sym
->declared_at
);
12969 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12970 || sym
->attr
.pointer
|| sym
->attr
.value
)
12972 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12973 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
12974 "attribute", sym
->name
, &sym
->declared_at
);
12978 if (sym
->attr
.intent
== INTENT_OUT
)
12980 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12981 "have the INTENT(OUT) attribute",
12982 sym
->name
, &sym
->declared_at
);
12985 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
12987 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
12988 "either be a scalar or an assumed-size array",
12989 sym
->name
, &sym
->declared_at
);
12993 /* Set the type to TYPE(*) and add a dimension(*) to ensure
12994 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
12996 sym
->ts
.type
= BT_ASSUMED
;
12997 sym
->as
= gfc_get_array_spec ();
12998 sym
->as
->type
= AS_ASSUMED_SIZE
;
13000 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13002 else if (sym
->ts
.type
== BT_ASSUMED
)
13004 /* TS 29113, C407a. */
13005 if (!sym
->attr
.dummy
)
13007 gfc_error ("Assumed type of variable %s at %L is only permitted "
13008 "for dummy variables", sym
->name
, &sym
->declared_at
);
13011 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13012 || sym
->attr
.pointer
|| sym
->attr
.value
)
13014 gfc_error ("Assumed-type variable %s at %L may not have the "
13015 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13016 sym
->name
, &sym
->declared_at
);
13019 if (sym
->attr
.intent
== INTENT_OUT
)
13021 gfc_error ("Assumed-type variable %s at %L may not have the "
13022 "INTENT(OUT) attribute",
13023 sym
->name
, &sym
->declared_at
);
13026 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13028 gfc_error ("Assumed-type variable %s at %L shall not be an "
13029 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13034 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13035 do this for something that was implicitly typed because that is handled
13036 in gfc_set_default_type. Handle dummy arguments and procedure
13037 definitions separately. Also, anything that is use associated is not
13038 handled here but instead is handled in the module it is declared in.
13039 Finally, derived type definitions are allowed to be BIND(C) since that
13040 only implies that they're interoperable, and they are checked fully for
13041 interoperability when a variable is declared of that type. */
13042 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13043 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13044 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13048 /* First, make sure the variable is declared at the
13049 module-level scope (J3/04-007, Section 15.3). */
13050 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13051 sym
->attr
.in_common
== 0)
13053 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13054 "is neither a COMMON block nor declared at the "
13055 "module level scope", sym
->name
, &(sym
->declared_at
));
13058 else if (sym
->common_head
!= NULL
)
13060 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13064 /* If type() declaration, we need to verify that the components
13065 of the given type are all C interoperable, etc. */
13066 if (sym
->ts
.type
== BT_DERIVED
&&
13067 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13069 /* Make sure the user marked the derived type as BIND(C). If
13070 not, call the verify routine. This could print an error
13071 for the derived type more than once if multiple variables
13072 of that type are declared. */
13073 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13074 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13078 /* Verify the variable itself as C interoperable if it
13079 is BIND(C). It is not possible for this to succeed if
13080 the verify_bind_c_derived_type failed, so don't have to handle
13081 any error returned by verify_bind_c_derived_type. */
13082 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13083 sym
->common_block
);
13088 /* clear the is_bind_c flag to prevent reporting errors more than
13089 once if something failed. */
13090 sym
->attr
.is_bind_c
= 0;
13095 /* If a derived type symbol has reached this point, without its
13096 type being declared, we have an error. Notice that most
13097 conditions that produce undefined derived types have already
13098 been dealt with. However, the likes of:
13099 implicit type(t) (t) ..... call foo (t) will get us here if
13100 the type is not declared in the scope of the implicit
13101 statement. Change the type to BT_UNKNOWN, both because it is so
13102 and to prevent an ICE. */
13103 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13104 && sym
->ts
.u
.derived
->components
== NULL
13105 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13107 gfc_error ("The derived type '%s' at %L is of type '%s', "
13108 "which has not been defined", sym
->name
,
13109 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13110 sym
->ts
.type
= BT_UNKNOWN
;
13114 /* Make sure that the derived type has been resolved and that the
13115 derived type is visible in the symbol's namespace, if it is a
13116 module function and is not PRIVATE. */
13117 if (sym
->ts
.type
== BT_DERIVED
13118 && sym
->ts
.u
.derived
->attr
.use_assoc
13119 && sym
->ns
->proc_name
13120 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13121 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13124 /* Unless the derived-type declaration is use associated, Fortran 95
13125 does not allow public entries of private derived types.
13126 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13127 161 in 95-006r3. */
13128 if (sym
->ts
.type
== BT_DERIVED
13129 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13130 && !sym
->ts
.u
.derived
->attr
.use_assoc
13131 && gfc_check_symbol_access (sym
)
13132 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13133 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13134 "derived type '%s'",
13135 (sym
->attr
.flavor
== FL_PARAMETER
)
13136 ? "parameter" : "variable",
13137 sym
->name
, &sym
->declared_at
,
13138 sym
->ts
.u
.derived
->name
))
13141 /* F2008, C1302. */
13142 if (sym
->ts
.type
== BT_DERIVED
13143 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13144 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13145 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13146 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13148 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13149 "type LOCK_TYPE must be a coarray", sym
->name
,
13150 &sym
->declared_at
);
13154 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13155 default initialization is defined (5.1.2.4.4). */
13156 if (sym
->ts
.type
== BT_DERIVED
13158 && sym
->attr
.intent
== INTENT_OUT
13160 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13162 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13164 if (c
->initializer
)
13166 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13167 "ASSUMED SIZE and so cannot have a default initializer",
13168 sym
->name
, &sym
->declared_at
);
13175 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13176 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13178 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13179 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13184 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13185 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13186 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13187 || class_attr
.codimension
)
13188 && (sym
->attr
.result
|| sym
->result
== sym
))
13190 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13191 "a coarray component", sym
->name
, &sym
->declared_at
);
13196 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13197 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13199 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13200 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13205 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13206 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13207 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13208 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13209 || class_attr
.allocatable
))
13211 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13212 "nonpointer, nonallocatable scalar, which is not a coarray",
13213 sym
->name
, &sym
->declared_at
);
13217 /* F2008, C526. The function-result case was handled above. */
13218 if (class_attr
.codimension
13219 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13220 || sym
->attr
.select_type_temporary
13221 || sym
->ns
->save_all
13222 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13223 || sym
->ns
->proc_name
->attr
.is_main_program
13224 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13226 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13227 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13231 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13232 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13234 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13235 "deferred shape", sym
->name
, &sym
->declared_at
);
13238 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13239 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13241 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13242 "deferred shape", sym
->name
, &sym
->declared_at
);
13247 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13248 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13249 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13250 || (class_attr
.codimension
&& class_attr
.allocatable
))
13251 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13253 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13254 "allocatable coarray or have coarray components",
13255 sym
->name
, &sym
->declared_at
);
13259 if (class_attr
.codimension
&& sym
->attr
.dummy
13260 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13262 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13263 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13264 sym
->ns
->proc_name
->name
);
13268 if (sym
->ts
.type
== BT_LOGICAL
13269 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13270 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13271 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13274 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13275 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13277 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13278 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13279 "%L with non-C_Bool kind in BIND(C) procedure "
13280 "'%s'", sym
->name
, &sym
->declared_at
,
13281 sym
->ns
->proc_name
->name
))
13283 else if (!gfc_logical_kinds
[i
].c_bool
13284 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13285 "'%s' at %L with non-C_Bool kind in "
13286 "BIND(C) procedure '%s'", sym
->name
,
13288 sym
->attr
.function
? sym
->name
13289 : sym
->ns
->proc_name
->name
))
13293 switch (sym
->attr
.flavor
)
13296 if (!resolve_fl_variable (sym
, mp_flag
))
13301 if (!resolve_fl_procedure (sym
, mp_flag
))
13306 if (!resolve_fl_namelist (sym
))
13311 if (!resolve_fl_parameter (sym
))
13319 /* Resolve array specifier. Check as well some constraints
13320 on COMMON blocks. */
13322 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13324 /* Set the formal_arg_flag so that check_conflict will not throw
13325 an error for host associated variables in the specification
13326 expression for an array_valued function. */
13327 if (sym
->attr
.function
&& sym
->as
)
13328 formal_arg_flag
= 1;
13330 saved_specification_expr
= specification_expr
;
13331 specification_expr
= true;
13332 gfc_resolve_array_spec (sym
->as
, check_constant
);
13333 specification_expr
= saved_specification_expr
;
13335 formal_arg_flag
= 0;
13337 /* Resolve formal namespaces. */
13338 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13339 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13340 gfc_resolve (sym
->formal_ns
);
13342 /* Make sure the formal namespace is present. */
13343 if (sym
->formal
&& !sym
->formal_ns
)
13345 gfc_formal_arglist
*formal
= sym
->formal
;
13346 while (formal
&& !formal
->sym
)
13347 formal
= formal
->next
;
13351 sym
->formal_ns
= formal
->sym
->ns
;
13352 if (sym
->ns
!= formal
->sym
->ns
)
13353 sym
->formal_ns
->refs
++;
13357 /* Check threadprivate restrictions. */
13358 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13359 && (!sym
->attr
.in_common
13360 && sym
->module
== NULL
13361 && (sym
->ns
->proc_name
== NULL
13362 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13363 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13365 /* If we have come this far we can apply default-initializers, as
13366 described in 14.7.5, to those variables that have not already
13367 been assigned one. */
13368 if (sym
->ts
.type
== BT_DERIVED
13370 && !sym
->attr
.allocatable
13371 && !sym
->attr
.alloc_comp
)
13373 symbol_attribute
*a
= &sym
->attr
;
13375 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13376 && !a
->in_common
&& !a
->use_assoc
13377 && (a
->referenced
|| a
->result
)
13378 && !(a
->function
&& sym
!= sym
->result
))
13379 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13380 apply_default_init (sym
);
13383 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13384 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13385 && !CLASS_DATA (sym
)->attr
.class_pointer
13386 && !CLASS_DATA (sym
)->attr
.allocatable
)
13387 apply_default_init (sym
);
13389 /* If this symbol has a type-spec, check it. */
13390 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13391 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13392 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13397 /************* Resolve DATA statements *************/
13401 gfc_data_value
*vnode
;
13407 /* Advance the values structure to point to the next value in the data list. */
13410 next_data_value (void)
13412 while (mpz_cmp_ui (values
.left
, 0) == 0)
13415 if (values
.vnode
->next
== NULL
)
13418 values
.vnode
= values
.vnode
->next
;
13419 mpz_set (values
.left
, values
.vnode
->repeat
);
13427 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13433 ar_type mark
= AR_UNKNOWN
;
13435 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13441 if (!gfc_resolve_expr (var
->expr
))
13445 mpz_init_set_si (offset
, 0);
13448 if (e
->expr_type
!= EXPR_VARIABLE
)
13449 gfc_internal_error ("check_data_variable(): Bad expression");
13451 sym
= e
->symtree
->n
.sym
;
13453 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13455 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13456 sym
->name
, &sym
->declared_at
);
13459 if (e
->ref
== NULL
&& sym
->as
)
13461 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13462 " declaration", sym
->name
, where
);
13466 has_pointer
= sym
->attr
.pointer
;
13468 if (gfc_is_coindexed (e
))
13470 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13475 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13477 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13481 && ref
->type
== REF_ARRAY
13482 && ref
->u
.ar
.type
!= AR_FULL
)
13484 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13485 "be a full array", sym
->name
, where
);
13490 if (e
->rank
== 0 || has_pointer
)
13492 mpz_init_set_ui (size
, 1);
13499 /* Find the array section reference. */
13500 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13502 if (ref
->type
!= REF_ARRAY
)
13504 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13510 /* Set marks according to the reference pattern. */
13511 switch (ref
->u
.ar
.type
)
13519 /* Get the start position of array section. */
13520 gfc_get_section_index (ar
, section_index
, &offset
);
13525 gcc_unreachable ();
13528 if (!gfc_array_size (e
, &size
))
13530 gfc_error ("Nonconstant array section at %L in DATA statement",
13532 mpz_clear (offset
);
13539 while (mpz_cmp_ui (size
, 0) > 0)
13541 if (!next_data_value ())
13543 gfc_error ("DATA statement at %L has more variables than values",
13549 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13553 /* If we have more than one element left in the repeat count,
13554 and we have more than one element left in the target variable,
13555 then create a range assignment. */
13556 /* FIXME: Only done for full arrays for now, since array sections
13558 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13559 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13563 if (mpz_cmp (size
, values
.left
) >= 0)
13565 mpz_init_set (range
, values
.left
);
13566 mpz_sub (size
, size
, values
.left
);
13567 mpz_set_ui (values
.left
, 0);
13571 mpz_init_set (range
, size
);
13572 mpz_sub (values
.left
, values
.left
, size
);
13573 mpz_set_ui (size
, 0);
13576 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13579 mpz_add (offset
, offset
, range
);
13586 /* Assign initial value to symbol. */
13589 mpz_sub_ui (values
.left
, values
.left
, 1);
13590 mpz_sub_ui (size
, size
, 1);
13592 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13597 if (mark
== AR_FULL
)
13598 mpz_add_ui (offset
, offset
, 1);
13600 /* Modify the array section indexes and recalculate the offset
13601 for next element. */
13602 else if (mark
== AR_SECTION
)
13603 gfc_advance_section (section_index
, ar
, &offset
);
13607 if (mark
== AR_SECTION
)
13609 for (i
= 0; i
< ar
->dimen
; i
++)
13610 mpz_clear (section_index
[i
]);
13614 mpz_clear (offset
);
13620 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13622 /* Iterate over a list of elements in a DATA statement. */
13625 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13628 iterator_stack frame
;
13629 gfc_expr
*e
, *start
, *end
, *step
;
13630 bool retval
= true;
13632 mpz_init (frame
.value
);
13635 start
= gfc_copy_expr (var
->iter
.start
);
13636 end
= gfc_copy_expr (var
->iter
.end
);
13637 step
= gfc_copy_expr (var
->iter
.step
);
13639 if (!gfc_simplify_expr (start
, 1)
13640 || start
->expr_type
!= EXPR_CONSTANT
)
13642 gfc_error ("start of implied-do loop at %L could not be "
13643 "simplified to a constant value", &start
->where
);
13647 if (!gfc_simplify_expr (end
, 1)
13648 || end
->expr_type
!= EXPR_CONSTANT
)
13650 gfc_error ("end of implied-do loop at %L could not be "
13651 "simplified to a constant value", &start
->where
);
13655 if (!gfc_simplify_expr (step
, 1)
13656 || step
->expr_type
!= EXPR_CONSTANT
)
13658 gfc_error ("step of implied-do loop at %L could not be "
13659 "simplified to a constant value", &start
->where
);
13664 mpz_set (trip
, end
->value
.integer
);
13665 mpz_sub (trip
, trip
, start
->value
.integer
);
13666 mpz_add (trip
, trip
, step
->value
.integer
);
13668 mpz_div (trip
, trip
, step
->value
.integer
);
13670 mpz_set (frame
.value
, start
->value
.integer
);
13672 frame
.prev
= iter_stack
;
13673 frame
.variable
= var
->iter
.var
->symtree
;
13674 iter_stack
= &frame
;
13676 while (mpz_cmp_ui (trip
, 0) > 0)
13678 if (!traverse_data_var (var
->list
, where
))
13684 e
= gfc_copy_expr (var
->expr
);
13685 if (!gfc_simplify_expr (e
, 1))
13692 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13694 mpz_sub_ui (trip
, trip
, 1);
13698 mpz_clear (frame
.value
);
13701 gfc_free_expr (start
);
13702 gfc_free_expr (end
);
13703 gfc_free_expr (step
);
13705 iter_stack
= frame
.prev
;
13710 /* Type resolve variables in the variable list of a DATA statement. */
13713 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13717 for (; var
; var
= var
->next
)
13719 if (var
->expr
== NULL
)
13720 t
= traverse_data_list (var
, where
);
13722 t
= check_data_variable (var
, where
);
13732 /* Resolve the expressions and iterators associated with a data statement.
13733 This is separate from the assignment checking because data lists should
13734 only be resolved once. */
13737 resolve_data_variables (gfc_data_variable
*d
)
13739 for (; d
; d
= d
->next
)
13741 if (d
->list
== NULL
)
13743 if (!gfc_resolve_expr (d
->expr
))
13748 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13751 if (!resolve_data_variables (d
->list
))
13760 /* Resolve a single DATA statement. We implement this by storing a pointer to
13761 the value list into static variables, and then recursively traversing the
13762 variables list, expanding iterators and such. */
13765 resolve_data (gfc_data
*d
)
13768 if (!resolve_data_variables (d
->var
))
13771 values
.vnode
= d
->value
;
13772 if (d
->value
== NULL
)
13773 mpz_set_ui (values
.left
, 0);
13775 mpz_set (values
.left
, d
->value
->repeat
);
13777 if (!traverse_data_var (d
->var
, &d
->where
))
13780 /* At this point, we better not have any values left. */
13782 if (next_data_value ())
13783 gfc_error ("DATA statement at %L has more values than variables",
13788 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13789 accessed by host or use association, is a dummy argument to a pure function,
13790 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13791 is storage associated with any such variable, shall not be used in the
13792 following contexts: (clients of this function). */
13794 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13795 procedure. Returns zero if assignment is OK, nonzero if there is a
13798 gfc_impure_variable (gfc_symbol
*sym
)
13803 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13806 /* Check if the symbol's ns is inside the pure procedure. */
13807 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13811 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13815 proc
= sym
->ns
->proc_name
;
13816 if (sym
->attr
.dummy
13817 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13818 || proc
->attr
.function
))
13821 /* TODO: Sort out what can be storage associated, if anything, and include
13822 it here. In principle equivalences should be scanned but it does not
13823 seem to be possible to storage associate an impure variable this way. */
13828 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13829 current namespace is inside a pure procedure. */
13832 gfc_pure (gfc_symbol
*sym
)
13834 symbol_attribute attr
;
13839 /* Check if the current namespace or one of its parents
13840 belongs to a pure procedure. */
13841 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13843 sym
= ns
->proc_name
;
13847 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13855 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13859 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13860 checks if the current namespace is implicitly pure. Note that this
13861 function returns false for a PURE procedure. */
13864 gfc_implicit_pure (gfc_symbol
*sym
)
13870 /* Check if the current procedure is implicit_pure. Walk up
13871 the procedure list until we find a procedure. */
13872 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13874 sym
= ns
->proc_name
;
13878 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13883 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13884 && !sym
->attr
.pure
;
13888 /* Test whether the current procedure is elemental or not. */
13891 gfc_elemental (gfc_symbol
*sym
)
13893 symbol_attribute attr
;
13896 sym
= gfc_current_ns
->proc_name
;
13901 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13905 /* Warn about unused labels. */
13908 warn_unused_fortran_label (gfc_st_label
*label
)
13913 warn_unused_fortran_label (label
->left
);
13915 if (label
->defined
== ST_LABEL_UNKNOWN
)
13918 switch (label
->referenced
)
13920 case ST_LABEL_UNKNOWN
:
13921 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13925 case ST_LABEL_BAD_TARGET
:
13926 gfc_warning ("Label %d at %L defined but cannot be used",
13927 label
->value
, &label
->where
);
13934 warn_unused_fortran_label (label
->right
);
13938 /* Returns the sequence type of a symbol or sequence. */
13941 sequence_type (gfc_typespec ts
)
13950 if (ts
.u
.derived
->components
== NULL
)
13951 return SEQ_NONDEFAULT
;
13953 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13954 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13955 if (sequence_type (c
->ts
) != result
)
13961 if (ts
.kind
!= gfc_default_character_kind
)
13962 return SEQ_NONDEFAULT
;
13964 return SEQ_CHARACTER
;
13967 if (ts
.kind
!= gfc_default_integer_kind
)
13968 return SEQ_NONDEFAULT
;
13970 return SEQ_NUMERIC
;
13973 if (!(ts
.kind
== gfc_default_real_kind
13974 || ts
.kind
== gfc_default_double_kind
))
13975 return SEQ_NONDEFAULT
;
13977 return SEQ_NUMERIC
;
13980 if (ts
.kind
!= gfc_default_complex_kind
)
13981 return SEQ_NONDEFAULT
;
13983 return SEQ_NUMERIC
;
13986 if (ts
.kind
!= gfc_default_logical_kind
)
13987 return SEQ_NONDEFAULT
;
13989 return SEQ_NUMERIC
;
13992 return SEQ_NONDEFAULT
;
13997 /* Resolve derived type EQUIVALENCE object. */
14000 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14002 gfc_component
*c
= derived
->components
;
14007 /* Shall not be an object of nonsequence derived type. */
14008 if (!derived
->attr
.sequence
)
14010 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14011 "attribute to be an EQUIVALENCE object", sym
->name
,
14016 /* Shall not have allocatable components. */
14017 if (derived
->attr
.alloc_comp
)
14019 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14020 "components to be an EQUIVALENCE object",sym
->name
,
14025 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14027 gfc_error ("Derived type variable '%s' at %L with default "
14028 "initialization cannot be in EQUIVALENCE with a variable "
14029 "in COMMON", sym
->name
, &e
->where
);
14033 for (; c
; c
= c
->next
)
14035 if (c
->ts
.type
== BT_DERIVED
14036 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14039 /* Shall not be an object of sequence derived type containing a pointer
14040 in the structure. */
14041 if (c
->attr
.pointer
)
14043 gfc_error ("Derived type variable '%s' at %L with pointer "
14044 "component(s) cannot be an EQUIVALENCE object",
14045 sym
->name
, &e
->where
);
14053 /* Resolve equivalence object.
14054 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14055 an allocatable array, an object of nonsequence derived type, an object of
14056 sequence derived type containing a pointer at any level of component
14057 selection, an automatic object, a function name, an entry name, a result
14058 name, a named constant, a structure component, or a subobject of any of
14059 the preceding objects. A substring shall not have length zero. A
14060 derived type shall not have components with default initialization nor
14061 shall two objects of an equivalence group be initialized.
14062 Either all or none of the objects shall have an protected attribute.
14063 The simple constraints are done in symbol.c(check_conflict) and the rest
14064 are implemented here. */
14067 resolve_equivalence (gfc_equiv
*eq
)
14070 gfc_symbol
*first_sym
;
14073 locus
*last_where
= NULL
;
14074 seq_type eq_type
, last_eq_type
;
14075 gfc_typespec
*last_ts
;
14076 int object
, cnt_protected
;
14079 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14081 first_sym
= eq
->expr
->symtree
->n
.sym
;
14085 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14089 e
->ts
= e
->symtree
->n
.sym
->ts
;
14090 /* match_varspec might not know yet if it is seeing
14091 array reference or substring reference, as it doesn't
14093 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14095 gfc_ref
*ref
= e
->ref
;
14096 sym
= e
->symtree
->n
.sym
;
14098 if (sym
->attr
.dimension
)
14100 ref
->u
.ar
.as
= sym
->as
;
14104 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14105 if (e
->ts
.type
== BT_CHARACTER
14107 && ref
->type
== REF_ARRAY
14108 && ref
->u
.ar
.dimen
== 1
14109 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14110 && ref
->u
.ar
.stride
[0] == NULL
)
14112 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14113 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14116 /* Optimize away the (:) reference. */
14117 if (start
== NULL
&& end
== NULL
)
14120 e
->ref
= ref
->next
;
14122 e
->ref
->next
= ref
->next
;
14127 ref
->type
= REF_SUBSTRING
;
14129 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14131 ref
->u
.ss
.start
= start
;
14132 if (end
== NULL
&& e
->ts
.u
.cl
)
14133 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14134 ref
->u
.ss
.end
= end
;
14135 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14142 /* Any further ref is an error. */
14145 gcc_assert (ref
->type
== REF_ARRAY
);
14146 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14152 if (!gfc_resolve_expr (e
))
14155 sym
= e
->symtree
->n
.sym
;
14157 if (sym
->attr
.is_protected
)
14159 if (cnt_protected
> 0 && cnt_protected
!= object
)
14161 gfc_error ("Either all or none of the objects in the "
14162 "EQUIVALENCE set at %L shall have the "
14163 "PROTECTED attribute",
14168 /* Shall not equivalence common block variables in a PURE procedure. */
14169 if (sym
->ns
->proc_name
14170 && sym
->ns
->proc_name
->attr
.pure
14171 && sym
->attr
.in_common
)
14173 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14174 "object in the pure procedure '%s'",
14175 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14179 /* Shall not be a named constant. */
14180 if (e
->expr_type
== EXPR_CONSTANT
)
14182 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14183 "object", sym
->name
, &e
->where
);
14187 if (e
->ts
.type
== BT_DERIVED
14188 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14191 /* Check that the types correspond correctly:
14193 A numeric sequence structure may be equivalenced to another sequence
14194 structure, an object of default integer type, default real type, double
14195 precision real type, default logical type such that components of the
14196 structure ultimately only become associated to objects of the same
14197 kind. A character sequence structure may be equivalenced to an object
14198 of default character kind or another character sequence structure.
14199 Other objects may be equivalenced only to objects of the same type and
14200 kind parameters. */
14202 /* Identical types are unconditionally OK. */
14203 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14204 goto identical_types
;
14206 last_eq_type
= sequence_type (*last_ts
);
14207 eq_type
= sequence_type (sym
->ts
);
14209 /* Since the pair of objects is not of the same type, mixed or
14210 non-default sequences can be rejected. */
14212 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14213 "statement at %L with different type objects";
14215 && last_eq_type
== SEQ_MIXED
14216 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14217 || (eq_type
== SEQ_MIXED
14218 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14221 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14222 "statement at %L with objects of different type";
14224 && last_eq_type
== SEQ_NONDEFAULT
14225 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14226 || (eq_type
== SEQ_NONDEFAULT
14227 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14230 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14231 "EQUIVALENCE statement at %L";
14232 if (last_eq_type
== SEQ_CHARACTER
14233 && eq_type
!= SEQ_CHARACTER
14234 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14237 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14238 "EQUIVALENCE statement at %L";
14239 if (last_eq_type
== SEQ_NUMERIC
14240 && eq_type
!= SEQ_NUMERIC
14241 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14246 last_where
= &e
->where
;
14251 /* Shall not be an automatic array. */
14252 if (e
->ref
->type
== REF_ARRAY
14253 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14255 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14256 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14263 /* Shall not be a structure component. */
14264 if (r
->type
== REF_COMPONENT
)
14266 gfc_error ("Structure component '%s' at %L cannot be an "
14267 "EQUIVALENCE object",
14268 r
->u
.c
.component
->name
, &e
->where
);
14272 /* A substring shall not have length zero. */
14273 if (r
->type
== REF_SUBSTRING
)
14275 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14277 gfc_error ("Substring at %L has length zero",
14278 &r
->u
.ss
.start
->where
);
14288 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14291 resolve_fntype (gfc_namespace
*ns
)
14293 gfc_entry_list
*el
;
14296 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14299 /* If there are any entries, ns->proc_name is the entry master
14300 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14302 sym
= ns
->entries
->sym
;
14304 sym
= ns
->proc_name
;
14305 if (sym
->result
== sym
14306 && sym
->ts
.type
== BT_UNKNOWN
14307 && !gfc_set_default_type (sym
, 0, NULL
)
14308 && !sym
->attr
.untyped
)
14310 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14311 sym
->name
, &sym
->declared_at
);
14312 sym
->attr
.untyped
= 1;
14315 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14316 && !sym
->attr
.contained
14317 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14318 && gfc_check_symbol_access (sym
))
14320 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14321 "%L of PRIVATE type '%s'", sym
->name
,
14322 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14326 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14328 if (el
->sym
->result
== el
->sym
14329 && el
->sym
->ts
.type
== BT_UNKNOWN
14330 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14331 && !el
->sym
->attr
.untyped
)
14333 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14334 el
->sym
->name
, &el
->sym
->declared_at
);
14335 el
->sym
->attr
.untyped
= 1;
14341 /* 12.3.2.1.1 Defined operators. */
14344 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14346 gfc_formal_arglist
*formal
;
14348 if (!sym
->attr
.function
)
14350 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14351 sym
->name
, &where
);
14355 if (sym
->ts
.type
== BT_CHARACTER
14356 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14357 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14358 && sym
->result
->ts
.u
.cl
->length
))
14360 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14361 "character length", sym
->name
, &where
);
14365 formal
= gfc_sym_get_dummy_args (sym
);
14366 if (!formal
|| !formal
->sym
)
14368 gfc_error ("User operator procedure '%s' at %L must have at least "
14369 "one argument", sym
->name
, &where
);
14373 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14375 gfc_error ("First argument of operator interface at %L must be "
14376 "INTENT(IN)", &where
);
14380 if (formal
->sym
->attr
.optional
)
14382 gfc_error ("First argument of operator interface at %L cannot be "
14383 "optional", &where
);
14387 formal
= formal
->next
;
14388 if (!formal
|| !formal
->sym
)
14391 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14393 gfc_error ("Second argument of operator interface at %L must be "
14394 "INTENT(IN)", &where
);
14398 if (formal
->sym
->attr
.optional
)
14400 gfc_error ("Second argument of operator interface at %L cannot be "
14401 "optional", &where
);
14407 gfc_error ("Operator interface at %L must have, at most, two "
14408 "arguments", &where
);
14416 gfc_resolve_uops (gfc_symtree
*symtree
)
14418 gfc_interface
*itr
;
14420 if (symtree
== NULL
)
14423 gfc_resolve_uops (symtree
->left
);
14424 gfc_resolve_uops (symtree
->right
);
14426 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14427 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14431 /* Examine all of the expressions associated with a program unit,
14432 assign types to all intermediate expressions, make sure that all
14433 assignments are to compatible types and figure out which names
14434 refer to which functions or subroutines. It doesn't check code
14435 block, which is handled by resolve_code. */
14438 resolve_types (gfc_namespace
*ns
)
14444 gfc_namespace
* old_ns
= gfc_current_ns
;
14446 /* Check that all IMPLICIT types are ok. */
14447 if (!ns
->seen_implicit_none
)
14450 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14451 if (ns
->set_flag
[letter
]
14452 && !resolve_typespec_used (&ns
->default_type
[letter
],
14453 &ns
->implicit_loc
[letter
], NULL
))
14457 gfc_current_ns
= ns
;
14459 resolve_entries (ns
);
14461 resolve_common_vars (ns
->blank_common
.head
, false);
14462 resolve_common_blocks (ns
->common_root
);
14464 resolve_contained_functions (ns
);
14466 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14467 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14468 resolve_formal_arglist (ns
->proc_name
);
14470 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14472 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14473 resolve_charlen (cl
);
14475 gfc_traverse_ns (ns
, resolve_symbol
);
14477 resolve_fntype (ns
);
14479 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14481 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14482 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14483 "also be PURE", n
->proc_name
->name
,
14484 &n
->proc_name
->declared_at
);
14490 gfc_do_concurrent_flag
= 0;
14491 gfc_check_interfaces (ns
);
14493 gfc_traverse_ns (ns
, resolve_values
);
14499 for (d
= ns
->data
; d
; d
= d
->next
)
14503 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14505 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14507 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14508 resolve_equivalence (eq
);
14510 /* Warn about unused labels. */
14511 if (warn_unused_label
)
14512 warn_unused_fortran_label (ns
->st_labels
);
14514 gfc_resolve_uops (ns
->uop_root
);
14516 gfc_current_ns
= old_ns
;
14520 /* Call resolve_code recursively. */
14523 resolve_codes (gfc_namespace
*ns
)
14526 bitmap_obstack old_obstack
;
14528 if (ns
->resolved
== 1)
14531 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14534 gfc_current_ns
= ns
;
14536 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14537 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14540 /* Set to an out of range value. */
14541 current_entry_id
= -1;
14543 old_obstack
= labels_obstack
;
14544 bitmap_obstack_initialize (&labels_obstack
);
14546 resolve_code (ns
->code
, ns
);
14548 bitmap_obstack_release (&labels_obstack
);
14549 labels_obstack
= old_obstack
;
14553 /* This function is called after a complete program unit has been compiled.
14554 Its purpose is to examine all of the expressions associated with a program
14555 unit, assign types to all intermediate expressions, make sure that all
14556 assignments are to compatible types and figure out which names refer to
14557 which functions or subroutines. */
14560 gfc_resolve (gfc_namespace
*ns
)
14562 gfc_namespace
*old_ns
;
14563 code_stack
*old_cs_base
;
14569 old_ns
= gfc_current_ns
;
14570 old_cs_base
= cs_base
;
14572 resolve_types (ns
);
14573 component_assignment_level
= 0;
14574 resolve_codes (ns
);
14576 gfc_current_ns
= old_ns
;
14577 cs_base
= old_cs_base
;
14580 gfc_run_passes (ns
);